moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
authorblanchet
Tue Mar 22 12:39:37 2016 +0100 (2016-03-22)
changeset 626920701f25fac39
parent 62691 9bfcbab7cd99
child 62693 0ae225877b68
moved 'corec' from ssh://hg@bitbucket.org/jasmin_blanchette/nonprim-corec to Isabelle
src/HOL/Library/BNF_Corec.thy
src/HOL/Library/Library.thy
src/HOL/Tools/BNF/bnf_gfp_grec.ML
src/HOL/Tools/BNF/bnf_gfp_grec_sugar.ML
src/HOL/Tools/BNF/bnf_gfp_grec_sugar_tactics.ML
src/HOL/Tools/BNF/bnf_gfp_grec_sugar_util.ML
src/HOL/Tools/BNF/bnf_gfp_grec_tactics.ML
src/HOL/Tools/BNF/bnf_gfp_grec_unique_sugar.ML
     1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/HOL/Library/BNF_Corec.thy	Tue Mar 22 12:39:37 2016 +0100
     1.3 @@ -0,0 +1,213 @@
     1.4 +(*  Title:      HOL/Library/BNF_Corec.thy
     1.5 +    Author:     Jasmin Blanchette, Inria, LORIA, MPII
     1.6 +    Author:     Aymeric Bouzy, Ecole polytechnique
     1.7 +    Author:     Dmitriy Traytel, ETH Zurich
     1.8 +    Copyright   2015, 2016
     1.9 +
    1.10 +Generalized corecursor sugar ("corec" and friends).
    1.11 +*)
    1.12 +
    1.13 +chapter {* Generalized Corecursor Sugar (corec and friends) *}
    1.14 +
    1.15 +theory BNF_Corec
    1.16 +imports Main
    1.17 +keywords
    1.18 +  "corec" :: thy_decl and
    1.19 +  "corecursive" :: thy_goal and
    1.20 +  "friend_of_corec" :: thy_goal and
    1.21 +  "coinduction_upto" :: thy_decl
    1.22 +begin
    1.23 +
    1.24 +lemma obj_distinct_prems: "P \<longrightarrow> P \<longrightarrow> Q \<Longrightarrow> P \<Longrightarrow> Q"
    1.25 +  by auto
    1.26 +
    1.27 +lemma inject_refine: "g (f x) = x \<Longrightarrow> g (f y) = y \<Longrightarrow> f x = f y \<longleftrightarrow> x = y"
    1.28 +  by (metis (no_types))
    1.29 +
    1.30 +lemma convol_apply: "BNF_Def.convol f g x = (f x, g x)"
    1.31 +  unfolding convol_def ..
    1.32 +
    1.33 +lemma Grp_UNIV_id: "BNF_Def.Grp UNIV id = (op =)"
    1.34 +  unfolding BNF_Def.Grp_def by auto
    1.35 +
    1.36 +lemma sum_comp_cases:
    1.37 +  assumes "f o Inl = g o Inl" and "f o Inr = g o Inr"
    1.38 +  shows "f = g"
    1.39 +proof (rule ext)
    1.40 +  fix a show "f a = g a"
    1.41 +    using assms unfolding comp_def fun_eq_iff by (cases a) auto
    1.42 +qed
    1.43 +
    1.44 +lemma case_sum_Inl_Inr_L: "case_sum (f o Inl) (f o Inr) = f"
    1.45 +  by (metis case_sum_expand_Inr')
    1.46 +
    1.47 +lemma eq_o_InrI: "\<lbrakk>g o Inl = h; case_sum h f = g\<rbrakk> \<Longrightarrow> f = g o Inr"
    1.48 +  by (auto simp: fun_eq_iff split: sum.splits)
    1.49 +
    1.50 +lemma id_bnf_o: "BNF_Composition.id_bnf \<circ> f = f"
    1.51 +  unfolding BNF_Composition.id_bnf_def by (rule o_def)
    1.52 +
    1.53 +lemma o_id_bnf: "f \<circ> BNF_Composition.id_bnf = f"
    1.54 +  unfolding BNF_Composition.id_bnf_def by (rule o_def)
    1.55 +
    1.56 +lemma if_True_False:
    1.57 +  "(if P then True else Q) \<longleftrightarrow> P \<or> Q"
    1.58 +  "(if P then False else Q) \<longleftrightarrow> \<not> P \<and> Q"
    1.59 +  "(if P then Q else True) \<longleftrightarrow> \<not> P \<or> Q"
    1.60 +  "(if P then Q else False) \<longleftrightarrow> P \<and> Q"
    1.61 +  by auto
    1.62 +
    1.63 +lemma if_distrib_fun: "(if c then f else g) x = (if c then f x else g x)"
    1.64 +  by simp
    1.65 +
    1.66 +
    1.67 +section \<open>Coinduction\<close>
    1.68 +
    1.69 +lemma eq_comp_compI: "a o b = f o x \<Longrightarrow> x o c = id \<Longrightarrow> f = a o (b o c)"
    1.70 +  unfolding fun_eq_iff by simp
    1.71 +
    1.72 +lemma self_bounded_weaken_left: "(a :: 'a :: semilattice_inf) \<le> inf a b \<Longrightarrow> a \<le> b"
    1.73 +  by (erule le_infE)
    1.74 +
    1.75 +lemma self_bounded_weaken_right: "(a :: 'a :: semilattice_inf) \<le> inf b a \<Longrightarrow> a \<le> b"
    1.76 +  by (erule le_infE)
    1.77 +
    1.78 +lemma symp_iff: "symp R \<longleftrightarrow> R = R^--1"
    1.79 +  by (metis antisym conversep.cases conversep_le_swap predicate2I symp_def)
    1.80 +
    1.81 +lemma equivp_inf: "\<lbrakk>equivp R; equivp S\<rbrakk> \<Longrightarrow> equivp (inf R S)"
    1.82 +  unfolding equivp_def inf_fun_def inf_bool_def by metis
    1.83 +
    1.84 +lemma vimage2p_rel_prod:
    1.85 +  "(\<lambda>x y. rel_prod R S (BNF_Def.convol f1 g1 x) (BNF_Def.convol f2 g2 y)) =
    1.86 +   (inf (BNF_Def.vimage2p f1 f2 R) (BNF_Def.vimage2p g1 g2 S))"
    1.87 +  unfolding vimage2p_def rel_prod.simps convol_def by auto
    1.88 +
    1.89 +lemma predicate2I_obj: "(\<forall>x y. P x y \<longrightarrow> Q x y) \<Longrightarrow> P \<le> Q"
    1.90 +  by auto
    1.91 +
    1.92 +lemma predicate2D_obj: "P \<le> Q \<Longrightarrow> P x y \<longrightarrow> Q x y"
    1.93 +  by auto
    1.94 +
    1.95 +locale cong =
    1.96 +  fixes rel :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> 'b \<Rightarrow> bool)"
    1.97 +    and eval :: "'b \<Rightarrow> 'a"
    1.98 +    and retr :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'a \<Rightarrow> bool)"
    1.99 +  assumes rel_mono: "\<And>R S. R \<le> S \<Longrightarrow> rel R \<le> rel S"
   1.100 +    and equivp_retr: "\<And>R. equivp R \<Longrightarrow> equivp (retr R)"
   1.101 +    and retr_eval: "\<And>R x y. \<lbrakk>(rel_fun (rel R) R) eval eval; rel (inf R (retr R)) x y\<rbrakk> \<Longrightarrow>
   1.102 +      retr R (eval x) (eval y)"
   1.103 +begin
   1.104 +
   1.105 +definition cong :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> bool" where
   1.106 +  "cong R \<equiv> equivp R \<and> (rel_fun (rel R) R) eval eval"
   1.107 +
   1.108 +lemma cong_retr: "cong R \<Longrightarrow> cong (inf R (retr R))"
   1.109 +  unfolding cong_def
   1.110 +  by (auto simp: rel_fun_def dest: predicate2D[OF rel_mono, rotated]
   1.111 +    intro: equivp_inf equivp_retr retr_eval)
   1.112 +
   1.113 +lemma cong_equivp: "cong R \<Longrightarrow> equivp R"
   1.114 +  unfolding cong_def by simp
   1.115 +
   1.116 +definition gen_cong :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool" where
   1.117 +  "gen_cong R j1 j2 \<equiv> \<forall>R'. R \<le> R' \<and> cong R' \<longrightarrow> R' j1 j2"
   1.118 +
   1.119 +lemma gen_cong_reflp[intro, simp]: "x = y \<Longrightarrow> gen_cong R x y"
   1.120 +  unfolding gen_cong_def by (auto dest: cong_equivp equivp_reflp)
   1.121 +
   1.122 +lemma gen_cong_symp[intro]: "gen_cong R x y \<Longrightarrow> gen_cong R y x"
   1.123 +  unfolding gen_cong_def by (auto dest: cong_equivp equivp_symp)
   1.124 +
   1.125 +lemma gen_cong_transp[intro]: "gen_cong R x y \<Longrightarrow> gen_cong R y z \<Longrightarrow> gen_cong R x z"
   1.126 +  unfolding gen_cong_def by (auto dest: cong_equivp equivp_transp)
   1.127 +
   1.128 +lemma equivp_gen_cong: "equivp (gen_cong R)"
   1.129 +  by (intro equivpI reflpI sympI transpI) auto
   1.130 +
   1.131 +lemma leq_gen_cong: "R \<le> gen_cong R"
   1.132 +  unfolding gen_cong_def[abs_def] by auto
   1.133 +
   1.134 +lemmas imp_gen_cong[intro] = predicate2D[OF leq_gen_cong]
   1.135 +
   1.136 +lemma gen_cong_minimal: "\<lbrakk>R \<le> R'; cong R'\<rbrakk> \<Longrightarrow> gen_cong R \<le> R'"
   1.137 +  unfolding gen_cong_def[abs_def] by (rule predicate2I) metis
   1.138 +
   1.139 +lemma congdd_base_gen_congdd_base_aux:
   1.140 +  "rel (gen_cong R) x y \<Longrightarrow> R \<le> R' \<Longrightarrow> cong R' \<Longrightarrow> R' (eval x) (eval y)"
   1.141 +   by (force simp: rel_fun_def gen_cong_def cong_def dest: spec[of _ R'] predicate2D[OF rel_mono, rotated -1, of _ _ _ R'])
   1.142 +
   1.143 +lemma cong_gen_cong: "cong (gen_cong R)"
   1.144 +proof -
   1.145 +  { fix R' x y
   1.146 +    have "rel (gen_cong R) x y \<Longrightarrow> R \<le> R' \<Longrightarrow> cong R' \<Longrightarrow> R' (eval x) (eval y)"
   1.147 +      by (force simp: rel_fun_def gen_cong_def cong_def dest: spec[of _ R']
   1.148 +        predicate2D[OF rel_mono, rotated -1, of _ _ _ R'])
   1.149 +  }
   1.150 +  then show "cong (gen_cong R)" by (auto simp: equivp_gen_cong rel_fun_def gen_cong_def cong_def)
   1.151 +qed
   1.152 +
   1.153 +lemma gen_cong_eval_rel_fun:
   1.154 +  "(rel_fun (rel (gen_cong R)) (gen_cong R)) eval eval"
   1.155 +  using cong_gen_cong[of R] unfolding cong_def by simp
   1.156 +
   1.157 +lemma gen_cong_eval:
   1.158 +  "rel (gen_cong R) x y \<Longrightarrow> gen_cong R (eval x) (eval y)"
   1.159 +  by (erule rel_funD[OF gen_cong_eval_rel_fun])
   1.160 +
   1.161 +lemma gen_cong_idem: "gen_cong (gen_cong R) = gen_cong R"
   1.162 +  by (simp add: antisym cong_gen_cong gen_cong_minimal leq_gen_cong)
   1.163 +
   1.164 +lemma gen_cong_rho:
   1.165 +  "\<rho> = eval o f \<Longrightarrow> rel (gen_cong R) (f x) (f y) \<Longrightarrow> gen_cong R (\<rho> x) (\<rho> y)"
   1.166 +  by (simp add: gen_cong_eval)
   1.167 +lemma coinduction:
   1.168 +  assumes coind: "\<forall>R. R \<le> retr R \<longrightarrow> R \<le> op ="
   1.169 +  assumes cih: "R \<le> retr (gen_cong R)"
   1.170 +  shows "R \<le> op ="
   1.171 +  apply (rule order_trans[OF leq_gen_cong mp[OF spec[OF coind]]])
   1.172 +  apply (rule self_bounded_weaken_left[OF gen_cong_minimal])
   1.173 +   apply (rule inf_greatest[OF leq_gen_cong cih])
   1.174 +  apply (rule cong_retr[OF cong_gen_cong])
   1.175 +  done
   1.176 +
   1.177 +end
   1.178 +
   1.179 +lemma rel_sum_case_sum:
   1.180 +  "rel_fun (rel_sum R S) T (case_sum f1 g1) (case_sum f2 g2) = (rel_fun R T f1 f2 \<and> rel_fun S T g1 g2)"
   1.181 +  by (auto simp: rel_fun_def rel_sum.simps split: sum.splits)
   1.182 +
   1.183 +context
   1.184 +  fixes rel eval rel' eval' retr emb
   1.185 +  assumes base: "cong rel eval retr"
   1.186 +  and step: "cong rel' eval' retr"
   1.187 +  and emb: "eval' o emb = eval"
   1.188 +  and emb_transfer: "rel_fun (rel R) (rel' R) emb emb"
   1.189 +begin
   1.190 +
   1.191 +interpretation base: cong rel eval retr by (rule base)
   1.192 +interpretation step: cong rel' eval' retr by (rule step)
   1.193 +
   1.194 +lemma gen_cong_emb: "base.gen_cong R \<le> step.gen_cong R"
   1.195 +proof (rule base.gen_cong_minimal[OF step.leq_gen_cong])
   1.196 +  note step.gen_cong_eval_rel_fun[transfer_rule] emb_transfer[transfer_rule]
   1.197 +  have "(rel_fun (rel (step.gen_cong R)) (step.gen_cong R)) eval eval"
   1.198 +    unfolding emb[symmetric] by transfer_prover
   1.199 +  then show "base.cong (step.gen_cong R)"
   1.200 +    by (auto simp: base.cong_def step.equivp_gen_cong)
   1.201 +qed
   1.202 +
   1.203 +end
   1.204 +
   1.205 +ML_file "../Tools/BNF/bnf_gfp_grec_tactics.ML"
   1.206 +ML_file "../Tools/BNF/bnf_gfp_grec.ML"
   1.207 +ML_file "../Tools/BNF/bnf_gfp_grec_sugar_util.ML"
   1.208 +ML_file "../Tools/BNF/bnf_gfp_grec_sugar_tactics.ML"
   1.209 +ML_file "../Tools/BNF/bnf_gfp_grec_sugar.ML"
   1.210 +ML_file "../Tools/BNF/bnf_gfp_grec_unique_sugar.ML"
   1.211 +
   1.212 +method_setup corec_unique = \<open>
   1.213 +  Scan.succeed (SIMPLE_METHOD' o BNF_GFP_Grec_Unique_Sugar.corec_unique_tac)
   1.214 +\<close> "prove uniqueness of corecursive equation"
   1.215 +
   1.216 +end
     2.1 --- a/src/HOL/Library/Library.thy	Tue Mar 22 12:39:37 2016 +0100
     2.2 +++ b/src/HOL/Library/Library.thy	Tue Mar 22 12:39:37 2016 +0100
     2.3 @@ -5,6 +5,7 @@
     2.4    BigO
     2.5    Bit
     2.6    BNF_Axiomatization
     2.7 +  BNF_Corec
     2.8    Boolean_Algebra
     2.9    Bourbaki_Witt_Fixpoint
    2.10    Char_ord
     3.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     3.2 +++ b/src/HOL/Tools/BNF/bnf_gfp_grec.ML	Tue Mar 22 12:39:37 2016 +0100
     3.3 @@ -0,0 +1,3234 @@
     3.4 +(*  Title:      HOL/Tools/BNF/bnf_gfp_grec.ML
     3.5 +    Author:     Jasmin Blanchette, Inria, LORIA, MPII
     3.6 +    Author:     Aymeric Bouzy, Ecole polytechnique
     3.7 +    Author:     Dmitriy Traytel, ETH Zürich
     3.8 +    Copyright   2015, 2016
     3.9 +
    3.10 +Generalized corecursor construction.
    3.11 +*)
    3.12 +
    3.13 +signature BNF_GFP_GREC =
    3.14 +sig
    3.15 +  val Tsubst: typ -> typ -> typ -> typ
    3.16 +  val substT: typ -> typ -> term -> term
    3.17 +  val freeze_types: Proof.context -> (indexname * sort) list -> typ list -> typ list
    3.18 +  val dummify_atomic_types: term -> term
    3.19 +  val enforce_type: Proof.context -> (typ -> typ) -> typ -> term -> term
    3.20 +  val define_const: bool -> binding -> int -> string -> term -> local_theory ->
    3.21 +    (term * thm) * local_theory
    3.22 +
    3.23 +  type buffer =
    3.24 +    {Oper: term,
    3.25 +     VLeaf: term,
    3.26 +     CLeaf: term,
    3.27 +     ctr_wrapper: term,
    3.28 +     friends: (typ * term) Symtab.table}
    3.29 +
    3.30 +  val map_buffer: (term -> term) -> buffer -> buffer
    3.31 +  val specialize_buffer_types: buffer -> buffer
    3.32 +
    3.33 +  type dtor_coinduct_info =
    3.34 +    {dtor_coinduct: thm,
    3.35 +     cong_def: thm,
    3.36 +     cong_locale: thm,
    3.37 +     cong_base: thm,
    3.38 +     cong_refl: thm,
    3.39 +     cong_sym: thm,
    3.40 +     cong_trans: thm,
    3.41 +     cong_alg_intros: thm list}
    3.42 +
    3.43 +  type corec_info =
    3.44 +    {fp_b: binding,
    3.45 +     version: int,
    3.46 +     fpT: typ,
    3.47 +     Y: typ,
    3.48 +     Z: typ,
    3.49 +     friend_names: string list,
    3.50 +     sig_fp_sugars: BNF_FP_Def_Sugar.fp_sugar list,
    3.51 +     ssig_fp_sugar: BNF_FP_Def_Sugar.fp_sugar,
    3.52 +     Lam: term,
    3.53 +     proto_sctr: term,
    3.54 +     flat: term,
    3.55 +     eval_core: term,
    3.56 +     eval: term,
    3.57 +     algLam: term,
    3.58 +     corecUU: term,
    3.59 +     dtor_transfer: thm,
    3.60 +     Lam_transfer: thm,
    3.61 +     Lam_pointful_natural: thm,
    3.62 +     proto_sctr_transfer: thm,
    3.63 +     flat_simps: thm list,
    3.64 +     eval_core_simps: thm list,
    3.65 +     eval_thm: thm,
    3.66 +     eval_simps: thm list,
    3.67 +     all_algLam_algs: thm list,
    3.68 +     algLam_thm: thm,
    3.69 +     dtor_algLam: thm,
    3.70 +     corecUU_thm: thm,
    3.71 +     corecUU_unique: thm,
    3.72 +     corecUU_transfer: thm,
    3.73 +     buffer: buffer,
    3.74 +     all_dead_k_bnfs: BNF_Def.bnf list,
    3.75 +     Retr: term,
    3.76 +     equivp_Retr: thm,
    3.77 +     Retr_coinduct: thm,
    3.78 +     dtor_coinduct_info: dtor_coinduct_info}
    3.79 +
    3.80 +  type friend_info =
    3.81 +    {algrho: term,
    3.82 +     dtor_algrho: thm,
    3.83 +     algLam_algrho: thm}
    3.84 +
    3.85 +  val not_codatatype: Proof.context -> typ -> 'a
    3.86 +  val mk_fp_binding: binding -> string -> binding
    3.87 +  val bnf_kill_all_but: int -> BNF_Def.bnf -> local_theory -> BNF_Def.bnf * local_theory
    3.88 +
    3.89 +  val print_corec_infos: Proof.context -> unit
    3.90 +  val has_no_corec_info: Proof.context -> string -> bool
    3.91 +  val corec_info_of: typ -> local_theory -> corec_info * local_theory
    3.92 +  val maybe_corec_info_of: Proof.context -> typ -> corec_info option
    3.93 +  val corec_infos_of: Proof.context -> string -> corec_info list
    3.94 +  val corec_infos_of_generic: Context.generic -> Symtab.key -> corec_info list
    3.95 +  val prepare_friend_corec: string -> typ -> local_theory ->
    3.96 +    (corec_info * binding * int * typ * typ * typ * typ * typ * BNF_Def.bnf * BNF_Def.bnf
    3.97 +     * BNF_FP_Def_Sugar.fp_sugar * BNF_FP_Def_Sugar.fp_sugar * buffer) * local_theory
    3.98 +  val register_friend_corec: string -> binding -> int -> typ -> typ -> typ -> BNF_Def.bnf ->
    3.99 +    BNF_FP_Def_Sugar.fp_sugar -> BNF_FP_Def_Sugar.fp_sugar -> term -> term -> thm -> corec_info ->
   3.100 +    local_theory -> friend_info * local_theory
   3.101 +end;
   3.102 +
   3.103 +structure BNF_GFP_Grec : BNF_GFP_GREC =
   3.104 +struct
   3.105 +
   3.106 +open Ctr_Sugar
   3.107 +open BNF_Util
   3.108 +open BNF_Def
   3.109 +open BNF_Comp
   3.110 +open BNF_FP_Util
   3.111 +open BNF_LFP
   3.112 +open BNF_FP_Def_Sugar
   3.113 +open BNF_LFP_Rec_Sugar
   3.114 +open BNF_GFP_Grec_Tactics
   3.115 +
   3.116 +val algLamN = "algLam";
   3.117 +val algLam_algLamN = "algLam_algLam";
   3.118 +val algLam_algrhoN = "algLam_algrho";
   3.119 +val algrhoN = "algrho";
   3.120 +val CLeafN = "CLeaf";
   3.121 +val congN = "congclp";
   3.122 +val cong_alg_introsN = "cong_alg_intros";
   3.123 +val cong_localeN = "cong_locale";
   3.124 +val corecUUN = "corecUU";
   3.125 +val corecUU_transferN = "corecUU_transfer";
   3.126 +val corecUU_uniqueN = "corecUU_unique";
   3.127 +val cutSsigN = "cutSsig";
   3.128 +val dtor_algLamN = "dtor_algLam";
   3.129 +val dtor_algrhoN = "dtor_algrho";
   3.130 +val dtor_coinductN = "dtor_coinduct";
   3.131 +val dtor_transferN = "dtor_transfer";
   3.132 +val embLN = "embL";
   3.133 +val embLLN = "embLL";
   3.134 +val embLRN = "embLR";
   3.135 +val embL_pointful_naturalN = "embL_pointful_natural";
   3.136 +val embL_transferN = "embL_transfer";
   3.137 +val equivp_RetrN = "equivp_Retr";
   3.138 +val evalN = "eval";
   3.139 +val eval_coreN = "eval_core";
   3.140 +val eval_core_pointful_naturalN = "eval_core_pointful_natural";
   3.141 +val eval_core_transferN = "eval_core_transfer";
   3.142 +val eval_flatN = "eval_flat";
   3.143 +val eval_simpsN = "eval_simps";
   3.144 +val flatN = "flat";
   3.145 +val flat_pointful_naturalN = "flat_pointful_natural";
   3.146 +val flat_transferN = "flat_transfer";
   3.147 +val k_as_ssig_naturalN = "k_as_ssig_natural";
   3.148 +val k_as_ssig_transferN = "k_as_ssig_transfer";
   3.149 +val LamN = "Lam";
   3.150 +val Lam_transferN = "Lam_transfer";
   3.151 +val Lam_pointful_naturalN = "Lam_pointful_natural";
   3.152 +val OperN = "Oper";
   3.153 +val proto_sctrN = "proto_sctr";
   3.154 +val proto_sctr_pointful_naturalN = "proto_sctr_pointful_natural";
   3.155 +val proto_sctr_transferN = "proto_sctr_transfer";
   3.156 +val rho_transferN = "rho_transfer";
   3.157 +val Retr_coinductN = "Retr_coinduct";
   3.158 +val sctrN = "sctr";
   3.159 +val sctr_transferN = "sctr_transfer";
   3.160 +val sctr_pointful_naturalN = "sctr_pointful_natural";
   3.161 +val sigN = "sig";
   3.162 +val SigN = "Sig";
   3.163 +val Sig_pointful_naturalN = "Sig_pointful_natural";
   3.164 +val corecUN = "corecU";
   3.165 +val corecU_ctorN = "corecU_ctor";
   3.166 +val corecU_uniqueN = "corecU_unique";
   3.167 +val unsigN = "unsig";
   3.168 +val VLeafN = "VLeaf";
   3.169 +
   3.170 +val s_prefix = "s"; (* transforms "sig" into "ssig" *)
   3.171 +
   3.172 +fun not_codatatype ctxt T =
   3.173 +  error ("Not a codatatype: " ^ Syntax.string_of_typ ctxt T);
   3.174 +fun mutual_codatatype () =
   3.175 +  error ("Mutually corecursive codatatypes are not supported (try " ^
   3.176 +    quote (#1 @{command_keyword primcorec}) ^ " instead of " ^
   3.177 +    quote (#1 @{command_keyword corec}) ^ ")");
   3.178 +fun noncorecursive_codatatype () =
   3.179 +  error ("Noncorecursive codatatypes are not supported (try " ^
   3.180 +    quote (#1 @{command_keyword definition}) ^ " instead of " ^
   3.181 +    quote (#1 @{command_keyword corec}) ^ ")");
   3.182 +fun singleton_codatatype ctxt =
   3.183 +  error ("Singleton corecursive codatatypes are not supported (use " ^
   3.184 +    quote (Syntax.string_of_typ ctxt @{typ unit}) ^ " instead)");
   3.185 +
   3.186 +fun merge_lists eq old1 old2 = (old1 |> subtract eq old2) @ old2;
   3.187 +
   3.188 +fun add_type_namesT (Type (s, Ts)) = insert (op =) s #> fold add_type_namesT Ts
   3.189 +  | add_type_namesT _ = I;
   3.190 +
   3.191 +fun Tsubst Y T = Term.typ_subst_atomic [(Y, T)];
   3.192 +fun substT Y T = Term.subst_atomic_types [(Y, T)];
   3.193 +
   3.194 +fun freeze_types ctxt except_tvars Ts =
   3.195 +  let
   3.196 +    val As = fold Term.add_tvarsT Ts [] |> subtract (op =) except_tvars;
   3.197 +    val (Bs, _) = ctxt |> mk_TFrees' (map snd As);
   3.198 +  in
   3.199 +    map (Term.typ_subst_TVars (map fst As ~~ Bs)) Ts
   3.200 +  end;
   3.201 +
   3.202 +fun typ_unify_disjointly thy (T, T') =
   3.203 +  if T = T' then
   3.204 +    T
   3.205 +  else
   3.206 +    let
   3.207 +      val tvars = Term.add_tvar_namesT T [];
   3.208 +      val tvars' = Term.add_tvar_namesT T' [];
   3.209 +      val maxidx' = maxidx_of_typ T';
   3.210 +      val T = T |> exists (member (op =) tvars') tvars ? Logic.incr_tvar (maxidx' + 1);
   3.211 +      val maxidx = Integer.max (maxidx_of_typ T) maxidx';
   3.212 +      val (tyenv, _) = Sign.typ_unify thy (T, T') (Vartab.empty, maxidx);
   3.213 +    in
   3.214 +      Envir.subst_type tyenv T
   3.215 +    end;
   3.216 +
   3.217 +val dummify_atomic_types = Term.map_types (Term.map_atyps (K Term.dummyT));
   3.218 +
   3.219 +fun enforce_type ctxt get_T T t =
   3.220 +  Term.subst_TVars (tvar_subst (Proof_Context.theory_of ctxt) [get_T (fastype_of t)] [T]) t;
   3.221 +
   3.222 +fun mk_internal internal ctxt f =
   3.223 +  if internal andalso not (Config.get ctxt bnf_internals) then f else I
   3.224 +fun mk_fp_binding fp_b pre = Binding.map_name (K pre) fp_b
   3.225 +  |> Binding.qualify true (Binding.name_of fp_b);
   3.226 +fun mk_version_binding version = Binding.qualify false ("v" ^ string_of_int version);
   3.227 +fun mk_version_fp_binding internal ctxt =
   3.228 +  mk_internal internal ctxt Binding.concealed ooo (mk_fp_binding oo mk_version_binding);
   3.229 +(*FIXME: get rid of ugly names when typedef and primrec respect qualification*)
   3.230 +fun mk_version_binding_ugly version = Binding.suffix_name ("_v" ^ string_of_int version);
   3.231 +fun mk_version_fp_binding_ugly internal ctxt version fp_b pre =
   3.232 +  Binding.prefix_name (pre ^ "_") fp_b
   3.233 +  |> mk_version_binding_ugly version
   3.234 +  |> mk_internal internal ctxt Binding.concealed;
   3.235 +
   3.236 +fun mk_mapN ctxt live_AsBs TA bnf =
   3.237 +  let val TB = Term.typ_subst_atomic live_AsBs TA in
   3.238 +    enforce_type ctxt (snd o strip_typeN (length live_AsBs)) (TA --> TB) (map_of_bnf bnf)
   3.239 +  end;
   3.240 +
   3.241 +fun mk_relN ctxt live_AsBs TA bnf =
   3.242 +  let val TB = Term.typ_subst_atomic live_AsBs TA in
   3.243 +    enforce_type ctxt (snd o strip_typeN (length live_AsBs)) (mk_pred2T TA TB) (rel_of_bnf bnf)
   3.244 +  end;
   3.245 +
   3.246 +fun mk_map1 ctxt Y Z = mk_mapN ctxt [(Y, Z)];
   3.247 +fun mk_rel1 ctxt Y Z = mk_relN ctxt [(Y, Z)];
   3.248 +
   3.249 +fun define_const internal fp_b version name rhs lthy =
   3.250 +  let
   3.251 +    val b = mk_version_fp_binding internal lthy version fp_b name;
   3.252 +
   3.253 +    val ((free, (_, def_free)), (lthy, lthy_old)) = lthy
   3.254 +      |> Local_Theory.open_target |> snd
   3.255 +      |> Local_Theory.define ((b, NoSyn), ((Thm.def_binding b |> Binding.concealed, []), rhs))
   3.256 +      ||> `Local_Theory.close_target;
   3.257 +
   3.258 +    val phi = Proof_Context.export_morphism lthy_old lthy;
   3.259 +
   3.260 +    val const = Morphism.term phi free;
   3.261 +    val const' = enforce_type lthy I (fastype_of free) const;
   3.262 +  in
   3.263 +    ((const', Morphism.thm phi def_free), lthy)
   3.264 +  end;
   3.265 +
   3.266 +fun define_single_primrec b eqs lthy =
   3.267 +  let
   3.268 +    val (([free], [def_free], [simps_free]), (lthy, lthy_old)) = lthy
   3.269 +      |> Local_Theory.open_target |> snd
   3.270 +      |> Local_Theory.map_background_naming (mk_internal true lthy Name_Space.concealed) (*TODO check*)
   3.271 +      |> primrec [(b, NONE, NoSyn)] (map (pair Attrib.empty_binding) eqs)
   3.272 +      ||> `Local_Theory.close_target;
   3.273 +
   3.274 +    val phi = Proof_Context.export_morphism lthy_old lthy;
   3.275 +
   3.276 +    val const = Morphism.term phi free;
   3.277 +    val const' = enforce_type lthy I (fastype_of free) const;
   3.278 +  in
   3.279 +    ((const', Morphism.thm phi def_free, map (Morphism.thm phi) simps_free), lthy)
   3.280 +  end;
   3.281 +
   3.282 +type buffer =
   3.283 +  {Oper: term,
   3.284 +   VLeaf: term,
   3.285 +   CLeaf: term,
   3.286 +   ctr_wrapper: term,
   3.287 +   friends: (typ * term) Symtab.table};
   3.288 +
   3.289 +fun map_buffer f {Oper, VLeaf, CLeaf, ctr_wrapper, friends} =
   3.290 +  {Oper = f Oper, VLeaf = f VLeaf, CLeaf = f CLeaf, ctr_wrapper = f ctr_wrapper,
   3.291 +   friends = Symtab.map (K (apsnd f)) friends};
   3.292 +
   3.293 +fun morph_buffer phi = map_buffer (Morphism.term phi);
   3.294 +
   3.295 +fun specialize_buffer_types {Oper, VLeaf, CLeaf, ctr_wrapper, friends} =
   3.296 +  let
   3.297 +    val ssig_T as Type (_, Ts) = body_type (fastype_of VLeaf);
   3.298 +    val Y = List.last Ts;
   3.299 +    val ssigifyT = substT Y ssig_T;
   3.300 +  in
   3.301 +    {Oper = Oper, VLeaf = VLeaf, CLeaf = CLeaf, ctr_wrapper = ssigifyT ctr_wrapper,
   3.302 +     friends = Symtab.map (K (apsnd ssigifyT)) friends}
   3.303 +  end;
   3.304 +
   3.305 +type dtor_coinduct_info =
   3.306 +  {dtor_coinduct: thm,
   3.307 +   cong_def: thm,
   3.308 +   cong_locale: thm,
   3.309 +   cong_base: thm,
   3.310 +   cong_refl: thm,
   3.311 +   cong_sym: thm,
   3.312 +   cong_trans: thm,
   3.313 +   cong_alg_intros: thm list};
   3.314 +
   3.315 +fun map_dtor_coinduct_info f {dtor_coinduct, cong_def, cong_locale, cong_base, cong_refl, cong_sym,
   3.316 +    cong_trans, cong_alg_intros} =
   3.317 +  {dtor_coinduct = f dtor_coinduct, cong_def = f cong_def, cong_locale = f cong_locale,
   3.318 +   cong_base = f cong_base, cong_refl = f cong_refl, cong_sym = f cong_sym,
   3.319 +   cong_trans = f cong_trans, cong_alg_intros = map f cong_alg_intros};
   3.320 +
   3.321 +fun morph_dtor_coinduct_info phi = map_dtor_coinduct_info (Morphism.thm phi);
   3.322 +
   3.323 +type corec_ad =
   3.324 +  {fpT: typ,
   3.325 +   friend_names: string list};
   3.326 +
   3.327 +fun morph_corec_ad phi {fpT, friend_names} =
   3.328 +  {fpT = Morphism.typ phi fpT, friend_names = friend_names};
   3.329 +
   3.330 +type corec_info =
   3.331 +  {fp_b: binding,
   3.332 +   version: int,
   3.333 +   fpT: typ,
   3.334 +   Y: typ,
   3.335 +   Z: typ,
   3.336 +   friend_names: string list,
   3.337 +   sig_fp_sugars: fp_sugar list,
   3.338 +   ssig_fp_sugar: fp_sugar,
   3.339 +   Lam: term,
   3.340 +   proto_sctr: term,
   3.341 +   flat: term,
   3.342 +   eval_core: term,
   3.343 +   eval: term,
   3.344 +   algLam: term,
   3.345 +   corecUU: term,
   3.346 +   dtor_transfer: thm,
   3.347 +   Lam_transfer: thm,
   3.348 +   Lam_pointful_natural: thm,
   3.349 +   proto_sctr_transfer: thm,
   3.350 +   flat_simps: thm list,
   3.351 +   eval_core_simps: thm list,
   3.352 +   eval_thm: thm,
   3.353 +   eval_simps: thm list,
   3.354 +   all_algLam_algs: thm list,
   3.355 +   algLam_thm: thm,
   3.356 +   dtor_algLam: thm,
   3.357 +   corecUU_thm: thm,
   3.358 +   corecUU_unique: thm,
   3.359 +   corecUU_transfer: thm,
   3.360 +   buffer: buffer,
   3.361 +   all_dead_k_bnfs: BNF_Def.bnf list,
   3.362 +   Retr: term,
   3.363 +   equivp_Retr: thm,
   3.364 +   Retr_coinduct: thm,
   3.365 +   dtor_coinduct_info: dtor_coinduct_info};
   3.366 +
   3.367 +fun morph_corec_info phi
   3.368 +    ({fp_b, version, fpT, Y, Z, friend_names, sig_fp_sugars, ssig_fp_sugar, Lam, proto_sctr, flat,
   3.369 +      eval_core, eval, algLam, corecUU, dtor_transfer, Lam_transfer, Lam_pointful_natural,
   3.370 +      proto_sctr_transfer, flat_simps, eval_core_simps, eval_thm, eval_simps, all_algLam_algs,
   3.371 +      algLam_thm, dtor_algLam, corecUU_thm, corecUU_unique, corecUU_transfer, buffer,
   3.372 +      all_dead_k_bnfs, Retr, equivp_Retr, Retr_coinduct, dtor_coinduct_info} : corec_info) =
   3.373 +  {fp_b = fp_b, version = version, fpT = Morphism.typ phi fpT, Y = Morphism.typ phi Y,
   3.374 +   Z = Morphism.typ phi Z, friend_names = friend_names, sig_fp_sugars = sig_fp_sugars (*no morph*),
   3.375 +   ssig_fp_sugar = ssig_fp_sugar (*no morph*), Lam = Morphism.term phi Lam,
   3.376 +   proto_sctr = Morphism.term phi proto_sctr, flat = Morphism.term phi flat,
   3.377 +   eval_core = Morphism.term phi eval_core, eval = Morphism.term phi eval,
   3.378 +   algLam = Morphism.term phi algLam, corecUU = Morphism.term phi corecUU,
   3.379 +   dtor_transfer = dtor_transfer, Lam_transfer = Morphism.thm phi Lam_transfer,
   3.380 +   Lam_pointful_natural = Morphism.thm phi Lam_pointful_natural,
   3.381 +   proto_sctr_transfer = Morphism.thm phi proto_sctr_transfer,
   3.382 +   flat_simps = map (Morphism.thm phi) flat_simps,
   3.383 +   eval_core_simps = map (Morphism.thm phi) eval_core_simps, eval_thm = Morphism.thm phi eval_thm,
   3.384 +   eval_simps = map (Morphism.thm phi) eval_simps,
   3.385 +   all_algLam_algs = map (Morphism.thm phi) all_algLam_algs,
   3.386 +   algLam_thm = Morphism.thm phi algLam_thm, dtor_algLam = Morphism.thm phi dtor_algLam,
   3.387 +   corecUU_thm = Morphism.thm phi corecUU_thm, corecUU_unique = Morphism.thm phi corecUU_unique,
   3.388 +   corecUU_transfer = Morphism.thm phi corecUU_transfer, buffer = morph_buffer phi buffer,
   3.389 +   all_dead_k_bnfs = map (morph_bnf phi) all_dead_k_bnfs, Retr = Morphism.term phi Retr,
   3.390 +   equivp_Retr = Morphism.thm phi equivp_Retr, Retr_coinduct = Morphism.thm phi Retr_coinduct,
   3.391 +   dtor_coinduct_info = morph_dtor_coinduct_info phi dtor_coinduct_info};
   3.392 +
   3.393 +datatype ('a, 'b) expr =
   3.394 +  Ad of 'a * (local_theory -> 'b * local_theory) |
   3.395 +  Info of 'b;
   3.396 +
   3.397 +fun is_Ad (Ad _) = true
   3.398 +  | is_Ad _ = false;
   3.399 +
   3.400 +fun is_Info (Info _) = true
   3.401 +  | is_Info _ = false;
   3.402 +
   3.403 +type corec_info_expr = (corec_ad, corec_info) expr;
   3.404 +
   3.405 +fun morph_corec_info_expr phi (Ad (ad, f)) = Ad (morph_corec_ad phi ad, f)
   3.406 +  | morph_corec_info_expr phi (Info info) = Info (morph_corec_info phi info);
   3.407 +
   3.408 +val transfer_corec_info_expr = morph_corec_info_expr o Morphism.transfer_morphism;
   3.409 +
   3.410 +type corec_data = int Symtab.table * corec_info_expr list Symtab.table list;
   3.411 +
   3.412 +structure Data = Generic_Data
   3.413 +(
   3.414 +  type T = corec_data;
   3.415 +  val empty = (Symtab.empty, [Symtab.empty]);
   3.416 +  val extend = I;
   3.417 +  fun merge ((version_tab1, info_tabs1), (version_tab2, info_tabs2)) : T =
   3.418 +    (Symtab.join (K Int.max) (version_tab1, version_tab2), info_tabs1 @ info_tabs2);
   3.419 +);
   3.420 +
   3.421 +fun corec_ad_of_expr (Ad (ad, _)) = ad
   3.422 +  | corec_ad_of_expr (Info {fpT, friend_names, ...}) = {fpT = fpT, friend_names = friend_names};
   3.423 +
   3.424 +fun corec_info_exprs_of_generic context fpT_name =
   3.425 +  let
   3.426 +    val thy = Context.theory_of context;
   3.427 +    val info_tabs = snd (Data.get context);
   3.428 +  in
   3.429 +    maps (fn info_tab => these (Symtab.lookup info_tab fpT_name)) info_tabs
   3.430 +    |> map (transfer_corec_info_expr thy)
   3.431 +  end;
   3.432 +
   3.433 +val corec_info_exprs_of = corec_info_exprs_of_generic o Context.Proof;
   3.434 +
   3.435 +val keep_corec_infos = map_filter (fn Ad _ => NONE | Info info => SOME info);
   3.436 +
   3.437 +val corec_infos_of_generic = keep_corec_infos oo corec_info_exprs_of_generic;
   3.438 +val corec_infos_of = keep_corec_infos oo corec_info_exprs_of;
   3.439 +
   3.440 +fun str_of_corec_ad ctxt {fpT, friend_names} =
   3.441 +  "[" ^ Syntax.string_of_typ ctxt fpT ^ "; " ^ commas friend_names ^ "]";
   3.442 +
   3.443 +fun str_of_corec_info ctxt {fpT, version, friend_names, ...} =
   3.444 +  "{" ^ Syntax.string_of_typ ctxt fpT ^ "; " ^ commas friend_names ^ "; v" ^ string_of_int version ^
   3.445 +  "}";
   3.446 +
   3.447 +fun str_of_corec_info_expr ctxt (Ad (ad, _)) = str_of_corec_ad ctxt ad
   3.448 +  | str_of_corec_info_expr ctxt (Info info) = str_of_corec_info ctxt info;
   3.449 +
   3.450 +fun print_corec_infos ctxt =
   3.451 +  Symtab.fold (fn (fpT_name, exprs) => fn () =>
   3.452 +      writeln (fpT_name ^ ":\n" ^
   3.453 +        cat_lines (map (prefix "  " o str_of_corec_info_expr ctxt) exprs)))
   3.454 +    (the_single (snd (Data.get (Context.Proof ctxt)))) ();
   3.455 +
   3.456 +val has_no_corec_info = null oo corec_info_exprs_of;
   3.457 +
   3.458 +fun get_name_next_version_of fpT_name ctxt =
   3.459 +  let
   3.460 +    val (version_tab, info_tabs) = Data.get (Context.Theory (Proof_Context.theory_of ctxt));
   3.461 +    val fp_base = Long_Name.base_name fpT_name;
   3.462 +    val fp_b = Binding.name fp_base;
   3.463 +    val version_tab' = Symtab.map_default (fp_base, ~1) (Integer.add 1) version_tab;
   3.464 +    val SOME version = Symtab.lookup version_tab' fp_base;
   3.465 +    val ctxt' = ctxt
   3.466 +      |> Local_Theory.background_theory (Context.theory_map (Data.put (version_tab', info_tabs)));
   3.467 +  in
   3.468 +    ((fp_b, version), ctxt')
   3.469 +  end;
   3.470 +
   3.471 +type friend_info =
   3.472 +  {algrho: term,
   3.473 +   dtor_algrho: thm,
   3.474 +   algLam_algrho: thm};
   3.475 +
   3.476 +fun morph_friend_info phi ({algrho, dtor_algrho, algLam_algrho} : friend_info) =
   3.477 +  {algrho = Morphism.term phi algrho, dtor_algrho = Morphism.thm phi dtor_algrho,
   3.478 +   algLam_algrho = Morphism.thm phi algLam_algrho};
   3.479 +
   3.480 +fun checked_fp_sugar_of ctxt fpT_name =
   3.481 +  let
   3.482 +    val fp_sugar as {X, fp_res = {Ts = fpTs, ...}, fp_ctr_sugar = {ctrXs_Tss, ...}, ...} =
   3.483 +      (case fp_sugar_of ctxt fpT_name of
   3.484 +        SOME (fp_sugar as {fp = Greatest_FP, ...}) => fp_sugar
   3.485 +      | _ => not_codatatype ctxt (Type (fpT_name, [] (*yuck*))));
   3.486 +
   3.487 +    val _ =
   3.488 +      if length fpTs > 1 then
   3.489 +        mutual_codatatype ()
   3.490 +      else if not (exists (exists (Term.exists_subtype (curry (op =) X))) ctrXs_Tss) then
   3.491 +        noncorecursive_codatatype ()
   3.492 +      else if ctrXs_Tss = [[X]] then
   3.493 +        singleton_codatatype ctxt
   3.494 +      else
   3.495 +        ();
   3.496 +  in
   3.497 +    fp_sugar
   3.498 +  end;
   3.499 +
   3.500 +fun inline_pre_bnfs f lthy =
   3.501 +  lthy
   3.502 +  |> Config.put typedef_threshold ~1
   3.503 +  |> f
   3.504 +  |> Config.put typedef_threshold (Config.get lthy typedef_threshold);
   3.505 +
   3.506 +fun bnf_kill_all_but nn bnf lthy =
   3.507 +  ((empty_comp_cache, empty_unfolds), lthy)
   3.508 +  |> kill_bnf I (live_of_bnf bnf - nn) bnf
   3.509 +  ||> snd;
   3.510 +
   3.511 +fun bnf_with_deads_and_lives dead_Es live_As Y fpT T lthy =
   3.512 +   let
   3.513 +     val qsoty = quote o Syntax.string_of_typ lthy;
   3.514 +
   3.515 +     val unfreeze_fp = Tsubst Y fpT;
   3.516 +
   3.517 +    fun flatten_tyargs Ass =
   3.518 +      map dest_TFree live_As
   3.519 +      |> filter (fn T => exists (fn Ts => member (op =) Ts T) Ass);
   3.520 +
   3.521 +     val ((bnf, _), (_, lthy)) =
   3.522 +      bnf_of_typ false Do_Inline I flatten_tyargs [Term.dest_TFree Y]
   3.523 +        (map Term.dest_TFree dead_Es) T ((empty_comp_cache, empty_unfolds), lthy)
   3.524 +      handle BAD_DEAD (Y, Y_backdrop) =>
   3.525 +        (case Y_backdrop of
   3.526 +          Type (bad_tc, _) =>
   3.527 +          let
   3.528 +            val T = qsoty (unfreeze_fp Y);
   3.529 +            val T_backdrop = qsoty (unfreeze_fp Y_backdrop);
   3.530 +            fun register_hint () =
   3.531 +              "\nUse the " ^ quote (#1 @{command_keyword "bnf"}) ^ " command to register " ^
   3.532 +              quote bad_tc ^ " as a bounded natural functor to allow nested (co)recursion through \
   3.533 +              \it";
   3.534 +          in
   3.535 +            if is_some (bnf_of lthy bad_tc) orelse is_some (fp_sugar_of lthy bad_tc) then
   3.536 +              error ("Inadmissible occurrence of type " ^ T ^ " in type expression " ^
   3.537 +                T_backdrop)
   3.538 +            else
   3.539 +              error ("Unsupported occurrence of type " ^ T ^ " via type constructor " ^
   3.540 +                quote bad_tc ^ " in type expression " ^ T_backdrop ^ register_hint ())
   3.541 +          end);
   3.542 +
   3.543 +    val phi =
   3.544 +      Morphism.term_morphism "BNF" (Raw_Simplifier.rewrite_term (Proof_Context.theory_of lthy)
   3.545 +        @{thms BNF_Composition.id_bnf_def} [])
   3.546 +      $> Morphism.thm_morphism "BNF" (unfold_thms lthy @{thms BNF_Composition.id_bnf_def});
   3.547 +  in
   3.548 +    (morph_bnf phi bnf, lthy)
   3.549 +  end;
   3.550 +
   3.551 +fun define_sig_type fp_b version fp_alives Es Y rhsT lthy =
   3.552 +  let
   3.553 +    val T_b = mk_version_fp_binding_ugly true lthy version fp_b sigN;
   3.554 +    val ctr_b = mk_version_fp_binding false lthy version fp_b SigN;
   3.555 +    val sel_b = mk_version_fp_binding true lthy version fp_b unsigN;
   3.556 +
   3.557 +    val lthy = Local_Theory.open_target lthy |> snd;
   3.558 +
   3.559 +    val T_name = Local_Theory.full_name lthy T_b;
   3.560 +
   3.561 +    val tyargs = map2 (fn alive => pair (if alive then SOME Binding.empty else NONE)
   3.562 +      o rpair @{sort type}) (fp_alives @ [true]) (Es @ [Y]);
   3.563 +    val ctr_specs = [(((Binding.empty, ctr_b), [(sel_b, rhsT)]), NoSyn)];
   3.564 +    val spec = (((((tyargs, T_b), NoSyn), ctr_specs),
   3.565 +      (Binding.empty, Binding.empty, Binding.empty)), []);
   3.566 +
   3.567 +    val plugins = Plugin_Name.make_filter lthy (K (curry (op =) transfer_plugin));
   3.568 +    val discs_sels = true;
   3.569 +
   3.570 +    val lthy = lthy
   3.571 +      |> Local_Theory.map_background_naming (mk_internal true lthy Name_Space.concealed) (*TODO check*)
   3.572 +      |> inline_pre_bnfs (co_datatypes Least_FP construct_lfp ((plugins, discs_sels), [spec]))
   3.573 +      |> Local_Theory.close_target;
   3.574 +
   3.575 +    val SOME fp_sugar = fp_sugar_of lthy T_name;
   3.576 +  in
   3.577 +    (fp_sugar, lthy)
   3.578 +  end;
   3.579 +
   3.580 +fun define_ssig_type fp_b version fp_alives Es Y fpT lthy =
   3.581 +  let
   3.582 +    val sig_T_b = mk_version_fp_binding_ugly true lthy version fp_b sigN;
   3.583 +    val T_b = Binding.prefix_name s_prefix sig_T_b;
   3.584 +    val Oper_b = mk_version_fp_binding false lthy version fp_b OperN;
   3.585 +    val VLeaf_b = mk_version_fp_binding false lthy version fp_b VLeafN;
   3.586 +    val CLeaf_b = mk_version_fp_binding false lthy version fp_b CLeafN;
   3.587 +
   3.588 +    val lthy = Local_Theory.open_target lthy |> snd;
   3.589 +
   3.590 +    val sig_T_name = Local_Theory.full_name lthy sig_T_b;
   3.591 +    val T_name = Long_Name.map_base_name (prefix s_prefix) sig_T_name;
   3.592 +
   3.593 +    val As = Es @ [Y];
   3.594 +    val ssig_sig_T = Type (sig_T_name, Es @ [Type (T_name, As)]);
   3.595 +
   3.596 +    val tyargs = map2 (fn alive => pair (if alive then SOME Binding.empty else NONE)
   3.597 +      o rpair @{sort type}) (fp_alives @ [true]) As;
   3.598 +    val ctr_specs =
   3.599 +      [(((Binding.empty, Oper_b), [(Binding.empty, ssig_sig_T)]), NoSyn),
   3.600 +       (((Binding.empty, VLeaf_b), [(Binding.empty, Y)]), NoSyn),
   3.601 +       (((Binding.empty, CLeaf_b), [(Binding.empty, fpT)]), NoSyn)];
   3.602 +    val spec = (((((tyargs, T_b), NoSyn), ctr_specs),
   3.603 +      (Binding.empty, Binding.empty, Binding.empty)), []);
   3.604 +
   3.605 +    val plugins = Plugin_Name.make_filter lthy (K (curry (op =) transfer_plugin));
   3.606 +    val discs_sels = false;
   3.607 +
   3.608 +    val lthy = lthy
   3.609 +      |> Local_Theory.map_background_naming (mk_internal true lthy Name_Space.concealed) (*TODO check*)
   3.610 +      |> inline_pre_bnfs (co_datatypes Least_FP construct_lfp ((plugins, discs_sels), [spec]))
   3.611 +      |> Local_Theory.close_target;
   3.612 +
   3.613 +    val SOME fp_sugar = fp_sugar_of lthy T_name;
   3.614 +  in
   3.615 +    (fp_sugar, lthy)
   3.616 +  end;
   3.617 +
   3.618 +fun embed_Sig ctxt Sig inl_or_r t =
   3.619 +  Library.foldl1 HOLogic.mk_comp [Sig, inl_or_r, dummify_atomic_types t]
   3.620 +  |> Syntax.check_term ctxt;
   3.621 +
   3.622 +fun mk_ctr_wrapper_friends ctxt friend_name friend_T old_sig_T k_T Sig old_buffer =
   3.623 +  let
   3.624 +    val embed_Sig_inl = embed_Sig ctxt Sig (Inl_const old_sig_T k_T);
   3.625 +
   3.626 +    val ctr_wrapper = embed_Sig_inl (#ctr_wrapper old_buffer);
   3.627 +    val friends = Symtab.map (K (apsnd embed_Sig_inl)) (#friends old_buffer)
   3.628 +      |> Symtab.update_new (friend_name, (friend_T,
   3.629 +        HOLogic.mk_comp (Sig, Inr_const old_sig_T k_T)));
   3.630 +  in
   3.631 +    (ctr_wrapper, friends)
   3.632 +  end;
   3.633 +
   3.634 +fun pre_type_of_ctor Y ctor =
   3.635 +  let
   3.636 +    val (fp_preT, fpT) = dest_funT (fastype_of ctor);
   3.637 +  in
   3.638 +    typ_subst_nonatomic [(fpT, Y)] fp_preT
   3.639 +  end;
   3.640 +
   3.641 +fun mk_k_as_ssig Z old_sig_T k_T ssig_T Sig dead_sig_map Oper VLeaf =
   3.642 +  let
   3.643 +    val inr' = Inr_const old_sig_T k_T;
   3.644 +    val dead_sig_map' = substT Z ssig_T dead_sig_map;
   3.645 +  in
   3.646 +    Library.foldl1 HOLogic.mk_comp [Oper, dead_sig_map' $ VLeaf, Sig, inr']
   3.647 +  end;
   3.648 +
   3.649 +fun define_embL name fp_b version Y Z fpT old_sig_T old_ssig_T other_summand_T ssig_T Inl_or_r_const
   3.650 +    dead_old_sig_map Sig old_Oper old_VLeaf old_CLeaf Oper VLeaf CLeaf lthy =
   3.651 +  let
   3.652 +    val embL_b = mk_version_fp_binding true lthy version fp_b name;
   3.653 +    val old_ssig_old_sig_T = Tsubst Y old_ssig_T old_sig_T;
   3.654 +    val ssig_old_sig_T = Tsubst Y ssig_T old_sig_T;
   3.655 +    val ssig_other_summand_T = Tsubst Y ssig_T other_summand_T;
   3.656 +
   3.657 +    val sigx = Var (("s", 0), old_ssig_old_sig_T);
   3.658 +    val x = Var (("x", 0), Y);
   3.659 +    val j = Var (("j", 0), fpT);
   3.660 +    val embL = Free (Binding.name_of embL_b, old_ssig_T --> ssig_T);
   3.661 +    val dead_old_sig_map' = Term.subst_atomic_types [(Y, old_ssig_T), (Z, ssig_T)] dead_old_sig_map;
   3.662 +    val Sig' = substT Y ssig_T Sig;
   3.663 +    val inl' = Inl_or_r_const ssig_old_sig_T ssig_other_summand_T;
   3.664 +
   3.665 +    val Oper_eq = mk_Trueprop_eq (embL $ (old_Oper $ sigx),
   3.666 +        Oper $ (Sig' $ (inl' $ (dead_old_sig_map' $ embL $ sigx))))
   3.667 +      |> Logic.all sigx;
   3.668 +    val VLeaf_eq = mk_Trueprop_eq (embL $ (old_VLeaf $ x), VLeaf $ x)
   3.669 +      |> Logic.all x;
   3.670 +    val CLeaf_eq = mk_Trueprop_eq (embL $ (old_CLeaf $ j), CLeaf $ j)
   3.671 +      |> Logic.all j;
   3.672 +  in
   3.673 +    define_single_primrec embL_b [Oper_eq, VLeaf_eq, CLeaf_eq] lthy
   3.674 +  end;
   3.675 +
   3.676 +fun define_Lam_base fp_b version Y Z preT ssig_T dead_pre_map Sig unsig dead_sig_map Oper VLeaf
   3.677 +    lthy =
   3.678 +  let
   3.679 +    val YpreT = HOLogic.mk_prodT (Y, preT);
   3.680 +
   3.681 +    val snd' = snd_const YpreT;
   3.682 +    val dead_pre_map' = substT Z ssig_T dead_pre_map;
   3.683 +    val Sig' = substT Y ssig_T Sig;
   3.684 +    val unsig' = substT Y ssig_T unsig;
   3.685 +    val dead_sig_map' = Term.subst_atomic_types [(Y, YpreT), (Z, ssig_T)] dead_sig_map;
   3.686 +
   3.687 +    val rhs = HOLogic.mk_comp (unsig', dead_sig_map'
   3.688 +      $ Library.foldl1 HOLogic.mk_comp [Oper, Sig', dead_pre_map' $ VLeaf, snd']);
   3.689 +  in
   3.690 +    define_const true fp_b version LamN rhs lthy
   3.691 +  end;
   3.692 +
   3.693 +fun define_Lam_step_or_merge fp_b version Y preT unsig left_case right_case lthy =
   3.694 +  let
   3.695 +    val YpreT = HOLogic.mk_prodT (Y, preT);
   3.696 +
   3.697 +    val unsig' = substT Y YpreT unsig;
   3.698 +
   3.699 +    val rhs = HOLogic.mk_comp (mk_case_sum (left_case, right_case), unsig');
   3.700 +  in
   3.701 +    define_const true fp_b version LamN rhs lthy
   3.702 +  end;
   3.703 +
   3.704 +fun define_Lam_step fp_b version Y Z preT old_ssig_T ssig_T dead_pre_map unsig rho embL old_Lam
   3.705 +    lthy =
   3.706 +  let
   3.707 +    val dead_pre_map' = Term.subst_atomic_types [(Y, old_ssig_T), (Z, ssig_T)] dead_pre_map;
   3.708 +    val left_case = HOLogic.mk_comp (dead_pre_map' $ embL, old_Lam);
   3.709 +  in
   3.710 +    define_Lam_step_or_merge fp_b version Y preT unsig left_case rho lthy
   3.711 +  end;
   3.712 +
   3.713 +fun define_Lam_merge fp_b version Y Z preT old1_ssig_T old2_ssig_T ssig_T dead_pre_map unsig embLL
   3.714 +    embLR old1_Lam old2_Lam lthy =
   3.715 +  let
   3.716 +    val dead_pre_map' = Term.subst_atomic_types [(Y, old1_ssig_T), (Z, ssig_T)] dead_pre_map;
   3.717 +    val dead_pre_map'' = Term.subst_atomic_types [(Y, old2_ssig_T), (Z, ssig_T)] dead_pre_map;
   3.718 +    val left_case = HOLogic.mk_comp (dead_pre_map' $ embLL, old1_Lam);
   3.719 +    val right_case = HOLogic.mk_comp (dead_pre_map'' $ embLR, old2_Lam);
   3.720 +  in
   3.721 +    define_Lam_step_or_merge fp_b version Y preT unsig left_case right_case lthy
   3.722 +  end;
   3.723 +
   3.724 +fun define_proto_sctr_step_or_merge fp_b version old_sig_T right_T Sig old_proto_sctr =
   3.725 +  let
   3.726 +    val rhs = Library.foldl1 HOLogic.mk_comp [Sig, Inl_const old_sig_T right_T, old_proto_sctr];
   3.727 +  in
   3.728 +    define_const true fp_b version proto_sctrN rhs
   3.729 +  end;
   3.730 +
   3.731 +fun define_flat fp_b version Y Z fpT sig_T ssig_T Oper VLeaf CLeaf dead_sig_map lthy =
   3.732 +  let
   3.733 +    val flat_b = mk_version_fp_binding true lthy version fp_b flatN;
   3.734 +    val ssig_sig_T = Tsubst Y ssig_T sig_T;
   3.735 +    val ssig_ssig_sig_T = Tsubst Y ssig_T ssig_sig_T;
   3.736 +    val ssig_ssig_T = Tsubst Y ssig_T ssig_T;
   3.737 +
   3.738 +    val sigx = Var (("s", 0), ssig_ssig_sig_T);
   3.739 +    val x = Var (("x", 0), ssig_T);
   3.740 +    val j = Var (("j", 0), fpT);
   3.741 +    val flat = Free (Binding.name_of flat_b, ssig_ssig_T --> ssig_T);
   3.742 +    val Oper' = substT Y ssig_T Oper;
   3.743 +    val VLeaf' = substT Y ssig_T VLeaf;
   3.744 +    val CLeaf' = substT Y ssig_T CLeaf;
   3.745 +    val dead_sig_map' = Term.subst_atomic_types [(Y, ssig_ssig_T), (Z, ssig_T)] dead_sig_map;
   3.746 +
   3.747 +    val Oper_eq = mk_Trueprop_eq (flat $ (Oper' $ sigx), Oper $ (dead_sig_map' $ flat $ sigx))
   3.748 +      |> Logic.all sigx;
   3.749 +    val VLeaf_eq = mk_Trueprop_eq (flat $ (VLeaf' $ x), x)
   3.750 +      |> Logic.all x;
   3.751 +    val CLeaf_eq = mk_Trueprop_eq (flat $ (CLeaf' $ j), CLeaf $ j)
   3.752 +      |> Logic.all j;
   3.753 +  in
   3.754 +    define_single_primrec flat_b [Oper_eq, VLeaf_eq, CLeaf_eq] lthy
   3.755 +  end;
   3.756 +
   3.757 +fun define_eval_core fp_b version Y Z preT fpT sig_T ssig_T dtor Oper VLeaf CLeaf dead_pre_map
   3.758 +    dead_sig_map dead_ssig_map flat Lam lthy =
   3.759 +  let
   3.760 +    val eval_core_b = mk_version_fp_binding true lthy version fp_b eval_coreN;
   3.761 +    val YpreT = HOLogic.mk_prodT (Y, preT);
   3.762 +    val Ypre_ssig_T = Tsubst Y YpreT ssig_T;
   3.763 +    val Ypre_ssig_sig_T = Tsubst Y Ypre_ssig_T sig_T;
   3.764 +    val ssig_preT = Tsubst Y ssig_T preT;
   3.765 +    val ssig_YpreT = Tsubst Y ssig_T YpreT;
   3.766 +    val ssig_ssig_T = Tsubst Y ssig_T ssig_T;
   3.767 +
   3.768 +    val sigx = Var (("s", 0), Ypre_ssig_sig_T);
   3.769 +    val x = Var (("x", 0), YpreT);
   3.770 +    val j = Var (("j", 0), fpT);
   3.771 +    val eval_core = Free (Binding.name_of eval_core_b, Ypre_ssig_T --> ssig_preT);
   3.772 +    val Oper' = substT Y YpreT Oper;
   3.773 +    val VLeaf' = substT Y YpreT VLeaf;
   3.774 +    val CLeaf' = substT Y YpreT CLeaf;
   3.775 +    val dead_pre_map' = Term.subst_atomic_types [(Y, ssig_ssig_T), (Z, ssig_T)] dead_pre_map;
   3.776 +    val dead_pre_map'' = substT Z ssig_T dead_pre_map;
   3.777 +    val dead_pre_map''' = Term.subst_atomic_types [(Y, fpT), (Z, ssig_T)] dead_pre_map;
   3.778 +    val dead_sig_map' = Term.subst_atomic_types [(Y, Ypre_ssig_T), (Z, ssig_YpreT)] dead_sig_map;
   3.779 +    val dead_ssig_map' = Term.subst_atomic_types [(Y, YpreT), (Z, Y)] dead_ssig_map;
   3.780 +    val Lam' = substT Y ssig_T Lam;
   3.781 +    val fst' = fst_const YpreT;
   3.782 +    val snd' = snd_const YpreT;
   3.783 +
   3.784 +    val Oper_eq = mk_Trueprop_eq (eval_core $ (Oper' $ sigx),
   3.785 +        dead_pre_map' $ flat $ (Lam' $ (dead_sig_map' $ (Abs (Name.uu, Ypre_ssig_T,
   3.786 +          HOLogic.mk_prod (dead_ssig_map' $ fst' $ Bound 0, eval_core $ Bound 0))) $ sigx)))
   3.787 +      |> Logic.all sigx;
   3.788 +    val VLeaf_eq = mk_Trueprop_eq (eval_core $ (VLeaf' $ x), dead_pre_map'' $ VLeaf $ (snd' $ x))
   3.789 +      |> Logic.all x;
   3.790 +    val CLeaf_eq = mk_Trueprop_eq (eval_core $ (CLeaf' $ j), dead_pre_map''' $ CLeaf $ (dtor $ j))
   3.791 +      |> Logic.all j;
   3.792 +  in
   3.793 +    define_single_primrec eval_core_b [Oper_eq, VLeaf_eq, CLeaf_eq] lthy
   3.794 +  end;
   3.795 +
   3.796 +fun define_eval fp_b version Y Z preT fpT ssig_T dtor dtor_unfold dead_ssig_map eval_core lthy =
   3.797 +  let
   3.798 +    val fp_preT = Tsubst Y fpT preT;
   3.799 +    val fppreT = HOLogic.mk_prodT (fpT, fp_preT);
   3.800 +    val fp_ssig_T = Tsubst Y fpT ssig_T;
   3.801 +
   3.802 +    val dtor_unfold' = substT Z fp_ssig_T dtor_unfold;
   3.803 +    val dead_ssig_map' = Term.subst_atomic_types [(Y, fpT), (Z, fppreT)] dead_ssig_map;
   3.804 +    val eval_core' = substT Y fpT eval_core;
   3.805 +    val id' = HOLogic.id_const fpT;
   3.806 +
   3.807 +    val rhs = dtor_unfold' $ HOLogic.mk_comp (eval_core', dead_ssig_map' $ mk_convol (id', dtor));
   3.808 +  in
   3.809 +    define_const true fp_b version evalN rhs lthy
   3.810 +  end;
   3.811 +
   3.812 +fun define_cutSsig fp_b version Y Z preT ssig_T dead_pre_map VLeaf dead_ssig_map flat eval_core
   3.813 +    lthy =
   3.814 +  let
   3.815 +    val ssig_preT = Tsubst Y ssig_T preT;
   3.816 +    val ssig_ssig_T = Tsubst Y ssig_T ssig_T;
   3.817 +    val ssig_ssig_preT = HOLogic.mk_prodT (ssig_T, ssig_preT);
   3.818 +
   3.819 +    val h = Var (("h", 0), Y --> ssig_preT);
   3.820 +    val dead_pre_map' = Term.subst_atomic_types [(Y, ssig_ssig_T), (Z, ssig_T)] dead_pre_map;
   3.821 +    val dead_ssig_map' = substT Z ssig_ssig_preT dead_ssig_map;
   3.822 +    val eval_core' = substT Y ssig_T eval_core;
   3.823 +
   3.824 +    val rhs = Library.foldl1 HOLogic.mk_comp [dead_pre_map' $ flat, eval_core',
   3.825 +        dead_ssig_map' $ mk_convol (VLeaf, h)]
   3.826 +      |> Term.lambda h;
   3.827 +  in
   3.828 +    define_const true fp_b version cutSsigN rhs lthy
   3.829 +  end;
   3.830 +
   3.831 +fun define_algLam fp_b version Y Z fpT ssig_T Oper VLeaf dead_sig_map eval lthy =
   3.832 +  let
   3.833 +    val fp_ssig_T = Tsubst Y fpT ssig_T;
   3.834 +
   3.835 +    val Oper' = substT Y fpT Oper;
   3.836 +    val VLeaf' = substT Y fpT VLeaf;
   3.837 +    val dead_sig_map' = Term.subst_atomic_types [(Y, fpT), (Z, fp_ssig_T)] dead_sig_map;
   3.838 +
   3.839 +    val rhs = Library.foldl1 HOLogic.mk_comp [eval, Oper', dead_sig_map' $ VLeaf'];
   3.840 +  in
   3.841 +    define_const true fp_b version algLamN rhs lthy
   3.842 +  end;
   3.843 +
   3.844 +fun define_corecU fp_b version Y Z preT ssig_T dtor_unfold VLeaf cutSsig lthy =
   3.845 +  let
   3.846 +    val ssig_preT = Tsubst Y ssig_T preT;
   3.847 +
   3.848 +    val h = Var (("h", 0), Y --> ssig_preT);
   3.849 +    val dtor_unfold' = substT Z ssig_T dtor_unfold;
   3.850 +
   3.851 +    val rhs = HOLogic.mk_comp (dtor_unfold' $ (cutSsig $ h), VLeaf)
   3.852 +      |> Term.lambda h;
   3.853 +  in
   3.854 +    define_const true fp_b version corecUN rhs lthy
   3.855 +  end;
   3.856 +
   3.857 +fun define_corecUU fp_b version Y Z preT ssig_T dead_pre_map dead_ssig_map flat eval_core sctr
   3.858 +    corecU lthy =
   3.859 +  let
   3.860 +    val ssig_preT = Tsubst Y ssig_T preT;
   3.861 +    val ssig_ssig_T = Tsubst Y ssig_T ssig_T
   3.862 +    val ssig_ssig_preT = HOLogic.mk_prodT (ssig_T, ssig_preT);
   3.863 +
   3.864 +    val ssig_pre_ssig_T = Tsubst Y ssig_preT ssig_T;
   3.865 +
   3.866 +    val h = Var (("h", 0), Y --> ssig_pre_ssig_T);
   3.867 +    val dead_pre_map' = Term.subst_atomic_types [(Y, ssig_ssig_T), (Z, ssig_T)] dead_pre_map;
   3.868 +    val eval_core' = substT Y ssig_T eval_core;
   3.869 +    val dead_ssig_map' =
   3.870 +      Term.subst_atomic_types [(Y, ssig_preT), (Z, ssig_ssig_preT)] dead_ssig_map;
   3.871 +    val id' = HOLogic.id_const ssig_preT;
   3.872 +
   3.873 +    val rhs = corecU $ Library.foldl1 HOLogic.mk_comp
   3.874 +        [dead_pre_map' $ flat, eval_core', dead_ssig_map' $ mk_convol (sctr, id'), h]
   3.875 +      |> Term.lambda h;
   3.876 +  in
   3.877 +    define_const true fp_b version corecUUN rhs lthy
   3.878 +  end;
   3.879 +
   3.880 +fun derive_sig_transfer maybe_swap ctxt live_AsBs pre_rel sig_rel Rs R const pre_rel_def
   3.881 +    preT_rel_eqs transfer_thm =
   3.882 +  let
   3.883 +    val RRpre_rel = list_comb (pre_rel, Rs) $ R;
   3.884 +    val RRsig_rel = list_comb (sig_rel, Rs) $ R;
   3.885 +    val constB = Term.subst_atomic_types live_AsBs const;
   3.886 +
   3.887 +    val goal = uncurry mk_rel_fun (maybe_swap (RRpre_rel, RRsig_rel)) $ const $ constB
   3.888 +      |> HOLogic.mk_Trueprop;
   3.889 +  in
   3.890 +    Variable.add_free_names ctxt goal []
   3.891 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
   3.892 +      mk_sig_transfer_tac ctxt pre_rel_def preT_rel_eqs transfer_thm))
   3.893 +    |> Thm.close_derivation
   3.894 +  end;
   3.895 +
   3.896 +fun derive_transfer_by_transfer_prover ctxt live_AsBs Rs R const const_defs rel_eqs transfers =
   3.897 +  let
   3.898 +    val constB = Term.subst_atomic_types live_AsBs const;
   3.899 +    val goal = mk_parametricity_goal ctxt (Rs @ [R]) const constB;
   3.900 +  in
   3.901 +    Variable.add_free_names ctxt goal []
   3.902 +    |> (fn vars => Goal.prove_sorry (*FIXME*) (*no sorry*) ctxt vars [] goal (fn {context = ctxt, prems = _} =>
   3.903 +      mk_transfer_by_transfer_prover_tac ctxt (const_defs @ map (fn thm => thm RS sym) rel_eqs)
   3.904 +        rel_eqs transfers))
   3.905 +    |> Thm.close_derivation
   3.906 +  end;
   3.907 +
   3.908 +fun derive_dtor_transfer ctxt live_EsFs Y Z pre_rel fp_rel Rs dtor dtor_rel_thm =
   3.909 +  let
   3.910 +    val Type (@{type_name fun}, [fpT, Type (@{type_name fun}, [fpTB, @{typ bool}])]) =
   3.911 +      snd (strip_typeN (length live_EsFs) (fastype_of fp_rel));
   3.912 +
   3.913 +    val pre_rel' = Term.subst_atomic_types [(Y, fpT), (Z, fpTB)] pre_rel;
   3.914 +    val Rpre_rel = list_comb (pre_rel', Rs);
   3.915 +    val Rfp_rel = list_comb (fp_rel, Rs);
   3.916 +    val dtorB = Term.subst_atomic_types live_EsFs dtor;
   3.917 +
   3.918 +    val goal = HOLogic.mk_Trueprop (mk_rel_fun Rfp_rel (Rpre_rel $ Rfp_rel) $ dtor $ dtorB);
   3.919 +  in
   3.920 +    Variable.add_free_names ctxt goal []
   3.921 +    |> (fn vars => Goal.prove_sorry (*FIXME*) (*no sorry*) ctxt vars [] goal (fn {context = ctxt, prems = _} =>
   3.922 +      mk_dtor_transfer_tac ctxt dtor_rel_thm))
   3.923 +    |> Thm.close_derivation
   3.924 +  end;
   3.925 +
   3.926 +fun derive_Lam_or_eval_core_transfer ctxt live_AsBs Y Z preT ssig_T Rs R pre_rel sig_or_ssig_rel
   3.927 +    ssig_rel const const_def rel_eqs transfers =
   3.928 +  let
   3.929 +    val YpreT = HOLogic.mk_prodT (Y, preT);
   3.930 +    val ZpreTB = typ_subst_atomic live_AsBs YpreT;
   3.931 +    val ssig_TB = typ_subst_atomic live_AsBs ssig_T;
   3.932 +
   3.933 +    val pre_rel' = Term.subst_atomic_types [(Y, ssig_T), (Z, ssig_TB)] pre_rel;
   3.934 +    val sig_or_ssig_rel' = Term.subst_atomic_types [(Y, YpreT), (Z, ZpreTB)] sig_or_ssig_rel;
   3.935 +    val Rsig_or_ssig_rel' = list_comb (sig_or_ssig_rel', Rs);
   3.936 +    val RRpre_rel = list_comb (pre_rel, Rs) $ R;
   3.937 +    val RRssig_rel = list_comb (ssig_rel, Rs) $ R;
   3.938 +    val Rpre_rel' = list_comb (pre_rel', Rs);
   3.939 +    val constB = subst_atomic_types live_AsBs const;
   3.940 +
   3.941 +    val goal = mk_rel_fun (Rsig_or_ssig_rel' $ mk_rel_prod R RRpre_rel) (Rpre_rel' $ RRssig_rel)
   3.942 +        $ const $ constB
   3.943 +      |> HOLogic.mk_Trueprop;
   3.944 +  in
   3.945 +    Variable.add_free_names ctxt goal []
   3.946 +    |> (fn vars => Goal.prove_sorry (*FIXME*) (*no sorry*) ctxt vars [] goal (fn {context = ctxt, prems = _} =>
   3.947 +      mk_transfer_by_transfer_prover_tac ctxt [const_def] rel_eqs transfers))
   3.948 +    |> Thm.close_derivation
   3.949 +  end;
   3.950 +
   3.951 +fun derive_proto_sctr_transfer_step_or_merge ctxt Y Z R dead_pre_rel dead_sig_rel proto_sctr
   3.952 +    proto_sctr_def fp_k_T_rel_eqs transfers =
   3.953 +  let
   3.954 +    val proto_sctrZ = substT Y Z proto_sctr;
   3.955 +    val goal = mk_rel_fun (dead_pre_rel $ R) (dead_sig_rel $ R) $ proto_sctr $ proto_sctrZ
   3.956 +      |> HOLogic.mk_Trueprop;
   3.957 +  in
   3.958 +    Variable.add_free_names ctxt goal []
   3.959 +    |> (fn vars => Goal.prove_sorry (*FIXME*) (*no sorry*) ctxt vars [] goal (fn {context = ctxt, prems = _} =>
   3.960 +      mk_transfer_by_transfer_prover_tac ctxt [proto_sctr_def] fp_k_T_rel_eqs transfers))
   3.961 +    |> Thm.close_derivation
   3.962 +  end;
   3.963 +
   3.964 +fun derive_sctr_transfer ctxt live_AsBs Y Z ssig_T Rs R pre_rel ssig_rel sctr sctr_def
   3.965 +    fp_k_T_rel_eqs transfers =
   3.966 +  let
   3.967 +    val ssig_TB = typ_subst_atomic live_AsBs ssig_T;
   3.968 +
   3.969 +    val pre_rel' = Term.subst_atomic_types [(Y, ssig_T), (Z, ssig_TB)] pre_rel;
   3.970 +    val Rpre_rel' = list_comb (pre_rel', Rs);
   3.971 +    val RRssig_rel = list_comb (ssig_rel, Rs) $ R;
   3.972 +    val sctrB = subst_atomic_types live_AsBs sctr;
   3.973 +
   3.974 +    val goal = HOLogic.mk_Trueprop (mk_rel_fun (Rpre_rel' $ RRssig_rel) RRssig_rel $ sctr $ sctrB);
   3.975 +  in
   3.976 +    Variable.add_free_names ctxt goal []
   3.977 +    |> (fn vars => Goal.prove_sorry (*FIXME*) (*no sorry*) ctxt vars [] goal (fn {context = ctxt, prems = _} =>
   3.978 +      mk_transfer_by_transfer_prover_tac ctxt [sctr_def] fp_k_T_rel_eqs transfers))
   3.979 +    |> Thm.close_derivation
   3.980 +  end;
   3.981 +
   3.982 +fun derive_corecUU_transfer ctxt live_AsBs Y Z Rs R preT ssig_T pre_rel fp_rel ssig_rel corecUU
   3.983 +    cutSsig_def corecU_def corecUU_def fp_k_T_rel_eqs transfers =
   3.984 +  let
   3.985 +    val ssig_preT = Tsubst Y ssig_T preT;
   3.986 +    val ssig_TB = typ_subst_atomic live_AsBs ssig_T;
   3.987 +    val ssig_preTB = typ_subst_atomic live_AsBs ssig_preT;
   3.988 +
   3.989 +    val pre_rel' = Term.subst_atomic_types [(Y, ssig_T), (Z, ssig_TB)] pre_rel;
   3.990 +    val ssig_rel' = Term.subst_atomic_types [(Y, ssig_preT), (Z, ssig_preTB)] ssig_rel;
   3.991 +    val Rpre_rel' = list_comb (pre_rel', Rs);
   3.992 +    val Rfp_rel = list_comb (fp_rel, Rs);
   3.993 +    val RRssig_rel = list_comb (ssig_rel, Rs) $ R;
   3.994 +    val Rssig_rel' = list_comb (ssig_rel', Rs);
   3.995 +    val corecUUB = subst_atomic_types live_AsBs corecUU;
   3.996 +
   3.997 +    val goal = mk_rel_fun (mk_rel_fun R (Rssig_rel' $ (Rpre_rel' $ RRssig_rel)))
   3.998 +        (mk_rel_fun R Rfp_rel) $ corecUU $ corecUUB
   3.999 +      |> HOLogic.mk_Trueprop;
  3.1000 +  in
  3.1001 +    Variable.add_free_names ctxt goal []
  3.1002 +    |> (fn vars => Goal.prove_sorry (*FIXME*) (*no sorry*) ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1003 +      mk_transfer_by_transfer_prover_tac ctxt [cutSsig_def, corecU_def, corecUU_def] fp_k_T_rel_eqs
  3.1004 +        transfers))
  3.1005 +    |> Thm.close_derivation
  3.1006 +  end;
  3.1007 +
  3.1008 +fun mk_natural_goal ctxt simple_T_mapfs fs t u =
  3.1009 +  let
  3.1010 +    fun build_simple (T, _) =
  3.1011 +      (case AList.lookup (op =) simple_T_mapfs T of
  3.1012 +        SOME mapf => mapf
  3.1013 +      | NONE => the (find_first (fn f => domain_type (fastype_of f) = T) fs));
  3.1014 +
  3.1015 +    val simple_Ts = map fst simple_T_mapfs;
  3.1016 +
  3.1017 +    val t_map = build_map ctxt simple_Ts build_simple (apply2 (range_type o fastype_of) (t, u));
  3.1018 +    val u_map = build_map ctxt simple_Ts build_simple (apply2 (domain_type o fastype_of) (t, u));
  3.1019 +  in
  3.1020 +    mk_Trueprop_eq (HOLogic.mk_comp (u, u_map), HOLogic.mk_comp (t_map, t))
  3.1021 +  end;
  3.1022 +
  3.1023 +fun derive_natural_by_unfolding ctxt live_AsBs preT pre_map fs f const map_thms =
  3.1024 +  let
  3.1025 +    val ffpre_map = list_comb (pre_map, fs) $ f;
  3.1026 +    val constB = subst_atomic_types live_AsBs const;
  3.1027 +
  3.1028 +    val goal = mk_natural_goal ctxt [(preT, ffpre_map)] (fs @ [f]) const constB;
  3.1029 +  in
  3.1030 +    Variable.add_free_names ctxt goal []
  3.1031 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1032 +      mk_natural_by_unfolding_tac ctxt map_thms))
  3.1033 +    |> Thm.close_derivation
  3.1034 +  end;
  3.1035 +
  3.1036 +fun derive_natural_from_transfer ctxt live_AsBs simple_T_mapfs fs f const transfer bnfs subst_bnfs =
  3.1037 +  let
  3.1038 +    val m = length live_AsBs;
  3.1039 +
  3.1040 +    val constB = Term.subst_atomic_types live_AsBs const;
  3.1041 +    val goal = mk_natural_goal ctxt simple_T_mapfs (fs @ [f]) const constB;
  3.1042 +  in
  3.1043 +    Variable.add_free_names ctxt goal []
  3.1044 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1045 +      mk_natural_from_transfer_tac ctxt m (replicate m true) transfer [] (map rel_Grp_of_bnf bnfs)
  3.1046 +        (map rel_Grp_of_bnf subst_bnfs)))
  3.1047 +    |> Thm.close_derivation
  3.1048 +  end;
  3.1049 +
  3.1050 +fun derive_natural_from_transfer_with_pre_type ctxt live_AsBs Y Z preT ssig_T pre_map ssig_map fs
  3.1051 +    f =
  3.1052 +  let
  3.1053 +    val ssig_TB = typ_subst_atomic live_AsBs ssig_T;
  3.1054 +    val preT' = Term.typ_subst_atomic [(Y, ssig_T), (Z, ssig_TB)] preT;
  3.1055 +
  3.1056 +    val ffpre_map = list_comb (pre_map, fs) $ f;
  3.1057 +    val pre_map' = Term.subst_atomic_types [(Y, ssig_T), (Z, ssig_TB)] pre_map;
  3.1058 +    val fpre_map' = list_comb (pre_map', fs);
  3.1059 +    val ffssig_map = list_comb (ssig_map, fs) $ f;
  3.1060 +
  3.1061 +    val preT_mapfs = [(preT, ffpre_map), (preT', fpre_map' $ ffssig_map)];
  3.1062 +  in
  3.1063 +    derive_natural_from_transfer ctxt live_AsBs preT_mapfs fs f
  3.1064 +  end;
  3.1065 +
  3.1066 +fun derive_Lam_Inl_Inr ctxt Y Z preT old_sig_T old_ssig_T k_T ssig_T dead_pre_map Sig embL old_Lam
  3.1067 +    Lam rho unsig_thm Lam_def =
  3.1068 +  let
  3.1069 +    val YpreT = HOLogic.mk_prodT (Y, preT);
  3.1070 +    val Ypre_old_sig_T = Tsubst Y YpreT old_sig_T;
  3.1071 +    val Ypre_k_T = Tsubst Y YpreT k_T;
  3.1072 +
  3.1073 +    val inl' = Inl_const Ypre_old_sig_T Ypre_k_T;
  3.1074 +    val inr' = Inr_const Ypre_old_sig_T Ypre_k_T;
  3.1075 +    val dead_pre_map' = Term.subst_atomic_types [(Y, old_ssig_T), (Z, ssig_T)] dead_pre_map;
  3.1076 +    val Sig' = substT Y YpreT Sig;
  3.1077 +    val Lam_o_Sig = HOLogic.mk_comp (Lam, Sig');
  3.1078 +
  3.1079 +    val inl_goal = mk_Trueprop_eq (HOLogic.mk_comp (Lam_o_Sig, inl'),
  3.1080 +      HOLogic.mk_comp (dead_pre_map' $ embL, old_Lam));
  3.1081 +    val inr_goal = mk_Trueprop_eq (HOLogic.mk_comp (Lam_o_Sig, inr'), rho);
  3.1082 +    val goals = [inl_goal, inr_goal];
  3.1083 +    val goal = Logic.mk_conjunction_balanced goals;
  3.1084 +  in
  3.1085 +    Variable.add_free_names ctxt goal []
  3.1086 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal
  3.1087 +      (fn {context = ctxt, prems = _} => mk_Lam_Inl_Inr_tac ctxt unsig_thm Lam_def))
  3.1088 +    |> Conjunction.elim_balanced (length goals)
  3.1089 +    |> map Thm.close_derivation
  3.1090 +  end;
  3.1091 +
  3.1092 +fun derive_flat_VLeaf ctxt Y Z ssig_T x VLeaf dead_ssig_map flat ssig_induct fp_map_id sig_map_cong
  3.1093 +    sig_map_ident sig_map_comp ssig_map_thms flat_simps =
  3.1094 +  let
  3.1095 +    val x' = substT Y ssig_T x;
  3.1096 +    val dead_ssig_map' = substT Z ssig_T dead_ssig_map;
  3.1097 +
  3.1098 +    val goal = mk_Trueprop_eq (flat $ (dead_ssig_map' $ VLeaf $ x'), x');
  3.1099 +
  3.1100 +    val ssig_induct' = infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt x')] ssig_induct;
  3.1101 +  in
  3.1102 +    Variable.add_free_names ctxt goal []
  3.1103 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1104 +      mk_flat_VLeaf_or_flat_tac ctxt ssig_induct' sig_map_cong
  3.1105 +        (fp_map_id :: sig_map_ident :: sig_map_comp :: ssig_map_thms @ flat_simps @
  3.1106 +         @{thms o_apply id_apply id_def[symmetric]})))
  3.1107 +    |> Thm.close_derivation
  3.1108 +  end;
  3.1109 +
  3.1110 +fun derive_flat_flat ctxt Y Z ssig_T x dead_ssig_map flat ssig_induct fp_map_id sig_map_cong
  3.1111 +    sig_map_comp ssig_map_thms flat_simps =
  3.1112 +  let
  3.1113 +    val ssig_ssig_T = Tsubst Y ssig_T ssig_T;
  3.1114 +    val ssig_ssig_ssig_T = Tsubst Y ssig_T ssig_ssig_T;
  3.1115 +
  3.1116 +    val x' = substT Y ssig_ssig_ssig_T x;
  3.1117 +    val dead_ssig_map' = Term.subst_atomic_types [(Y, ssig_ssig_T), (Z, ssig_T)] dead_ssig_map;
  3.1118 +    val flat' = substT Y ssig_T flat;
  3.1119 +
  3.1120 +    val goal = mk_Trueprop_eq (flat $ (dead_ssig_map' $ flat $ x'), flat $ (flat' $ x'));
  3.1121 +
  3.1122 +    val ssig_induct' = infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt x')] ssig_induct;
  3.1123 +  in
  3.1124 +    Variable.add_free_names ctxt goal []
  3.1125 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1126 +      mk_flat_VLeaf_or_flat_tac ctxt ssig_induct' sig_map_cong
  3.1127 +        (o_apply :: fp_map_id :: sig_map_comp :: ssig_map_thms @ flat_simps)))
  3.1128 +    |> Thm.close_derivation
  3.1129 +  end;
  3.1130 +
  3.1131 +fun derive_eval_core_flat ctxt Y Z preT ssig_T dead_pre_map dead_ssig_map flat eval_core x
  3.1132 +    ssig_induct dead_pre_map_id dead_pre_map_comp0 dead_pre_map_comp fp_map_id sig_map_comp
  3.1133 +    sig_map_cong ssig_map_thms ssig_map_comp flat_simps flat_pointful_natural flat_flat
  3.1134 +    Lam_pointful_natural eval_core_simps =
  3.1135 +  let
  3.1136 +    val YpreT = HOLogic.mk_prodT (Y, preT);
  3.1137 +    val ssig_ssig_T = Tsubst Y ssig_T ssig_T;
  3.1138 +    val Ypre_ssig_T = Tsubst Y YpreT ssig_T;
  3.1139 +    val Ypre_ssig_ssig_T = Tsubst Y YpreT ssig_ssig_T;
  3.1140 +    val ssig_YpreT = Tsubst Y ssig_T YpreT;
  3.1141 +
  3.1142 +    val dead_pre_map' = Term.subst_atomic_types [(Y, ssig_ssig_T), (Z, ssig_T)] dead_pre_map;
  3.1143 +    val dead_ssig_map' = Term.subst_atomic_types [(Y, Ypre_ssig_T), (Z, ssig_YpreT)] dead_ssig_map;
  3.1144 +    val dead_ssig_map'' = Term.subst_atomic_types [(Y, YpreT), (Z, Y)] dead_ssig_map;
  3.1145 +    val flat' = substT Y YpreT flat;
  3.1146 +    val eval_core' = substT Y ssig_T eval_core;
  3.1147 +    val x' = substT Y Ypre_ssig_ssig_T x;
  3.1148 +    val fst' = fst_const YpreT;
  3.1149 +
  3.1150 +    val goal = mk_Trueprop_eq (eval_core $ (flat' $ x'), dead_pre_map' $ flat
  3.1151 +      $ (eval_core' $ (dead_ssig_map' $ mk_convol (dead_ssig_map'' $ fst', eval_core) $ x')));
  3.1152 +
  3.1153 +    val ssig_induct' = infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt x')] ssig_induct;
  3.1154 +  in
  3.1155 +    Variable.add_free_names ctxt goal []
  3.1156 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1157 +      mk_eval_core_flat_tac ctxt ssig_induct' dead_pre_map_id dead_pre_map_comp0 dead_pre_map_comp
  3.1158 +        fp_map_id sig_map_comp sig_map_cong ssig_map_thms ssig_map_comp flat_simps
  3.1159 +        flat_pointful_natural flat_flat Lam_pointful_natural eval_core_simps))
  3.1160 +    |> Thm.close_derivation
  3.1161 +  end;
  3.1162 +
  3.1163 +fun derive_eval_thm ctxt dtor_inject dtor_unfold_thm eval_def =
  3.1164 +  (trans OF [iffD2 OF [dtor_inject, eval_def RS meta_eq_to_obj_eq RS fun_cong], dtor_unfold_thm])
  3.1165 +  |> unfold_thms ctxt [o_apply, eval_def RS Drule.symmetric_thm];
  3.1166 +
  3.1167 +fun derive_eval_flat ctxt Y Z fpT ssig_T dead_ssig_map flat eval x dead_pre_map_comp0
  3.1168 +    dtor_unfold_unique ssig_map_id ssig_map_comp flat_pointful_natural eval_core_pointful_natural
  3.1169 +    eval_core_flat eval_thm =
  3.1170 +  let
  3.1171 +    val fp_ssig_T = Tsubst Y fpT ssig_T;
  3.1172 +    val fp_ssig_ssig_T = Tsubst Y fp_ssig_T ssig_T;
  3.1173 +
  3.1174 +    val dead_ssig_map' = Term.subst_atomic_types [(Y, fp_ssig_T), (Z, fpT)] dead_ssig_map;
  3.1175 +    val flat' = substT Y fpT flat;
  3.1176 +    val x' = substT Y fp_ssig_ssig_T x;
  3.1177 +
  3.1178 +    val goal = mk_Trueprop_eq (eval $ (flat' $ x'), eval $ (dead_ssig_map' $ eval $ x'));
  3.1179 +
  3.1180 +    val cond_eval_o_flat =
  3.1181 +      infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt (HOLogic.mk_comp (eval, flat')))]
  3.1182 +        (trans OF [dtor_unfold_unique, dtor_unfold_unique RS sym] RS fun_cong)
  3.1183 +      OF [ext, ext];
  3.1184 +  in
  3.1185 +    Variable.add_free_names ctxt goal []
  3.1186 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1187 +      mk_eval_flat_tac ctxt dead_pre_map_comp0 ssig_map_id ssig_map_comp flat_pointful_natural
  3.1188 +        eval_core_pointful_natural eval_core_flat eval_thm cond_eval_o_flat))
  3.1189 +    |> Thm.close_derivation
  3.1190 +  end;
  3.1191 +
  3.1192 +fun derive_eval_Oper ctxt live Y Z fpT sig_T ssig_T dead_sig_map Oper eval algLam x sig_map_ident
  3.1193 +    sig_map_comp0 sig_map_comp Oper_natural_pointful VLeaf_natural flat_simps eval_flat algLam_def =
  3.1194 +  let
  3.1195 +    val fp_ssig_T = Tsubst Y fpT ssig_T;
  3.1196 +    val fp_ssig_sig_T = Tsubst Y fp_ssig_T sig_T;
  3.1197 +
  3.1198 +    val dead_sig_map' = Term.subst_atomic_types [(Y, fp_ssig_T), (Z, fpT)] dead_sig_map;
  3.1199 +    val Oper' = substT Y fpT Oper;
  3.1200 +    val x' = substT Y fp_ssig_sig_T x;
  3.1201 +
  3.1202 +    val goal = mk_Trueprop_eq (eval $ (Oper' $ x'), algLam $ (dead_sig_map' $ eval $ x'));
  3.1203 +  in
  3.1204 +    Variable.add_free_names ctxt goal []
  3.1205 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1206 +      mk_eval_Oper_tac ctxt live sig_map_ident sig_map_comp0 sig_map_comp Oper_natural_pointful
  3.1207 +        VLeaf_natural flat_simps eval_flat algLam_def))
  3.1208 +    |> Thm.close_derivation
  3.1209 +  end;
  3.1210 +
  3.1211 +fun derive_eval_V_or_CLeaf ctxt Y fpT V_or_CLeaf eval x dead_pre_map_id dead_pre_map_comp fp_map_id
  3.1212 +    dtor_unfold_unique V_or_CLeaf_map_thm eval_core_simps eval_thm =
  3.1213 +  let
  3.1214 +    val V_or_CLeaf' = substT Y fpT V_or_CLeaf;
  3.1215 +    val x' = substT Y fpT x;
  3.1216 +
  3.1217 +    val goal = mk_Trueprop_eq (eval $ (V_or_CLeaf' $ x'), x');
  3.1218 +  in
  3.1219 +    Variable.add_free_names ctxt goal []
  3.1220 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1221 +      mk_eval_V_or_CLeaf_tac ctxt dead_pre_map_id dead_pre_map_comp fp_map_id dtor_unfold_unique
  3.1222 +        V_or_CLeaf_map_thm eval_core_simps eval_thm))
  3.1223 +    |> Thm.close_derivation
  3.1224 +  end;
  3.1225 +
  3.1226 +fun derive_extdd_mor ctxt Y Z preT fpT ssig_T dead_pre_map dtor extdd cutSsig f g dead_pre_map_comp0
  3.1227 +    dead_pre_map_comp VLeaf_map_thm ssig_map_comp flat_pointful_natural eval_core_pointful_natural
  3.1228 +    eval_thm eval_flat eval_VLeaf cutSsig_def =
  3.1229 +  let
  3.1230 +    val ssig_preT = Tsubst Y ssig_T preT;
  3.1231 +
  3.1232 +    val dead_pre_map' = Term.subst_atomic_types [(Y, ssig_T), (Z, fpT)] dead_pre_map;
  3.1233 +    val f' = substT Z fpT f;
  3.1234 +    val g' = substT Z ssig_preT g;
  3.1235 +    val extdd_f = extdd $ f';
  3.1236 +
  3.1237 +    val prem = mk_Trueprop_eq (HOLogic.mk_comp (dead_pre_map' $ extdd_f, g'),
  3.1238 +      HOLogic.mk_comp (dtor, f'));
  3.1239 +    val goal = mk_Trueprop_eq (HOLogic.mk_comp (dead_pre_map' $ extdd_f, cutSsig $ g'),
  3.1240 +      HOLogic.mk_comp (dtor, extdd_f));
  3.1241 +  in
  3.1242 +    fold (Variable.add_free_names ctxt) [prem, goal] []
  3.1243 +    |> (fn vars => Goal.prove_sorry ctxt vars [prem] goal (fn {context = ctxt, prems = [prem]} =>
  3.1244 +      mk_extdd_mor_tac ctxt dead_pre_map_comp0 dead_pre_map_comp VLeaf_map_thm ssig_map_comp
  3.1245 +        flat_pointful_natural eval_core_pointful_natural eval_thm eval_flat eval_VLeaf cutSsig_def
  3.1246 +        prem))
  3.1247 +    |> Thm.close_derivation
  3.1248 +  end;
  3.1249 +
  3.1250 +fun derive_mor_cutSsig_flat ctxt Y Z preT fpT ssig_T dead_pre_map dead_ssig_map dtor flat eval_core
  3.1251 +    eval cutSsig f g dead_pre_map_comp0 dead_pre_map_comp dead_pre_map_cong dtor_unfold_unique
  3.1252 +    dead_ssig_map_comp0 ssig_map_comp flat_simps flat_pointful_natural eval_core_pointful_natural
  3.1253 +    flat_flat flat_VLeaf eval_core_flat cutSsig_def cutSsig_def_pointful_natural eval_thm =
  3.1254 +  let
  3.1255 +    val ssig_preT = Tsubst Y ssig_T preT;
  3.1256 +
  3.1257 +    val substYZ = Term.subst_atomic_types [(Y, ssig_T), (Z, fpT)];
  3.1258 +
  3.1259 +    val dead_pre_map' = substYZ dead_pre_map;
  3.1260 +    val dead_ssig_map' = substYZ dead_ssig_map;
  3.1261 +    val f' = substYZ f;
  3.1262 +    val g' = substT Z ssig_preT g;
  3.1263 +    val cutSsig_g = cutSsig $ g';
  3.1264 +
  3.1265 +    val id' = HOLogic.id_const ssig_T;
  3.1266 +    val convol' = mk_convol (id', cutSsig_g);
  3.1267 +    val dead_ssig_map'' =
  3.1268 +      Term.subst_atomic_types [(Y, ssig_T), (Z, range_type (fastype_of convol'))] dead_ssig_map;
  3.1269 +    val eval_core' = substT Y ssig_T eval_core;
  3.1270 +    val eval_core_o_map = HOLogic.mk_comp (eval_core', dead_ssig_map'' $ convol');
  3.1271 +
  3.1272 +    val prem = mk_Trueprop_eq (HOLogic.mk_comp (dead_pre_map' $ f', cutSsig_g),
  3.1273 +      HOLogic.mk_comp (dtor, f'));
  3.1274 +    val goal = mk_Trueprop_eq (HOLogic.mk_comp (eval, dead_ssig_map' $ f'),
  3.1275 +      HOLogic.mk_comp (f', flat));
  3.1276 +  in
  3.1277 +    fold (Variable.add_free_names ctxt) [prem, goal] []
  3.1278 +    |> (fn vars => Goal.prove_sorry ctxt vars [prem] goal (fn {context = ctxt, prems = [prem]} =>
  3.1279 +      mk_mor_cutSsig_flat_tac ctxt eval_core_o_map dead_pre_map_comp0 dead_pre_map_comp
  3.1280 +        dead_pre_map_cong dtor_unfold_unique dead_ssig_map_comp0 ssig_map_comp flat_simps
  3.1281 +        flat_pointful_natural eval_core_pointful_natural flat_flat flat_VLeaf eval_core_flat
  3.1282 +        cutSsig_def cutSsig_def_pointful_natural eval_thm prem))
  3.1283 +    |> Thm.close_derivation
  3.1284 +  end;
  3.1285 +
  3.1286 +fun derive_extdd_o_VLeaf ctxt Y Z preT fpT ssig_T dead_pre_map dtor VLeaf extdd f g
  3.1287 +    dead_pre_map_comp0 dead_pre_map_comp dtor_inject ssig_map_thms eval_core_simps eval_thm
  3.1288 +    eval_VLeaf =
  3.1289 +  let
  3.1290 +    val ssig_preT = Tsubst Y ssig_T preT;
  3.1291 +
  3.1292 +    val substYZ = Term.subst_atomic_types [(Y, ssig_T), (Z, fpT)];
  3.1293 +
  3.1294 +    val dead_pre_map' = substYZ dead_pre_map;
  3.1295 +    val f' = substT Z fpT f;
  3.1296 +    val g' = substT Z ssig_preT g;
  3.1297 +    val extdd_f = extdd $ f';
  3.1298 +
  3.1299 +    val prem = mk_Trueprop_eq (HOLogic.mk_comp (dead_pre_map' $ extdd_f, g'),
  3.1300 +      HOLogic.mk_comp (dtor, f'));
  3.1301 +    val goal = mk_Trueprop_eq (HOLogic.mk_comp (extdd_f, VLeaf), f');
  3.1302 +  in
  3.1303 +    fold (Variable.add_free_names ctxt) [prem, goal] []
  3.1304 +    |> (fn vars => Goal.prove_sorry ctxt vars [prem] goal (fn {context = ctxt, prems = [prem]} =>
  3.1305 +      mk_extdd_o_VLeaf_tac ctxt dead_pre_map_comp0 dead_pre_map_comp dtor_inject ssig_map_thms
  3.1306 +        eval_core_simps eval_thm eval_VLeaf prem))
  3.1307 +    |> Thm.close_derivation
  3.1308 +  end;
  3.1309 +
  3.1310 +fun derive_corecU_pointfree ctxt Y Z preT fpT ssig_T dead_pre_map dtor extdd corecU g
  3.1311 +    dead_pre_map_comp dtor_unfold_thm ssig_map_thms dead_ssig_map_comp0 flat_simps flat_VLeaf
  3.1312 +    eval_core_simps cutSsig_def mor_cutSsig_flat corecU_def =
  3.1313 +  let
  3.1314 +    val ssig_preT = Tsubst Y ssig_T preT;
  3.1315 +
  3.1316 +    val substYZ = Term.subst_atomic_types [(Y, ssig_T), (Z, fpT)];
  3.1317 +
  3.1318 +    val dead_pre_map' = substYZ dead_pre_map;
  3.1319 +    val g' = substT Z ssig_preT g;
  3.1320 +    val corecU_g = corecU $ g';
  3.1321 +
  3.1322 +    val goal = mk_Trueprop_eq (HOLogic.mk_comp (dead_pre_map' $ (extdd $ corecU_g), g'),
  3.1323 +      HOLogic.mk_comp (dtor, corecU_g));
  3.1324 +  in
  3.1325 +    Variable.add_free_names ctxt goal []
  3.1326 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1327 +      mk_corecU_pointfree_tac ctxt dead_pre_map_comp dtor_unfold_thm ssig_map_thms
  3.1328 +      dead_ssig_map_comp0 flat_simps flat_VLeaf eval_core_simps cutSsig_def mor_cutSsig_flat
  3.1329 +      corecU_def))
  3.1330 +    |> Thm.close_derivation
  3.1331 +  end;
  3.1332 +
  3.1333 +fun derive_corecU_ctor_unique ctxt Y Z preT fpT ssig_T dead_pre_map ctor dtor VLeaf extdd corecU f g
  3.1334 +    dead_pre_map_comp ctor_dtor dtor_unfold_thm dtor_unfold_unique ssig_map_thms dead_ssig_map_comp0
  3.1335 +    flat_simps flat_VLeaf eval_core_simps extdd_mor extdd_o_VLeaf cutSsig_def mor_cutSsig_flat
  3.1336 +    corecU_def =
  3.1337 +  let
  3.1338 +    val corecU_pointfree = derive_corecU_pointfree ctxt Y Z preT fpT ssig_T dead_pre_map dtor extdd
  3.1339 +      corecU g dead_pre_map_comp dtor_unfold_thm ssig_map_thms dead_ssig_map_comp0 flat_simps
  3.1340 +      flat_VLeaf eval_core_simps cutSsig_def mor_cutSsig_flat corecU_def;
  3.1341 +
  3.1342 +    val corecU_thm = corecU_pointfree RS @{thm comp_eq_dest};
  3.1343 +
  3.1344 +    val corecU_ctor =
  3.1345 +      let
  3.1346 +        val arg_cong' =
  3.1347 +          infer_instantiate' ctxt [NONE, NONE, SOME (Thm.cterm_of ctxt ctor)] arg_cong;
  3.1348 +      in
  3.1349 +        unfold_thms ctxt [ctor_dtor] (corecU_thm RS arg_cong')
  3.1350 +      end;
  3.1351 +
  3.1352 +    val corecU_unique =
  3.1353 +      let
  3.1354 +        val substYZ = Term.subst_atomic_types [(Y, ssig_T), (Z, fpT)];
  3.1355 +
  3.1356 +        val f' = substYZ f;
  3.1357 +        val abs_f_o_VLeaf = Term.lambda f' (HOLogic.mk_comp (f', VLeaf));
  3.1358 +
  3.1359 +        val inject_refine' = infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt abs_f_o_VLeaf),
  3.1360 +          SOME (Thm.cterm_of ctxt extdd)] @{thm inject_refine};
  3.1361 +      in
  3.1362 +        unfold_thms ctxt @{thms atomize_imp}
  3.1363 +          (((inject_refine' OF [extdd_o_VLeaf, extdd_o_VLeaf] RS iffD1)
  3.1364 +            OF [Drule.asm_rl, corecU_pointfree])
  3.1365 +           OF [Drule.asm_rl, trans OF [dtor_unfold_unique, dtor_unfold_unique RS sym]
  3.1366 +             OF [extdd_mor, corecU_pointfree RS extdd_mor]])
  3.1367 +        RS @{thm obj_distinct_prems}
  3.1368 +      end;
  3.1369 +  in
  3.1370 +    (corecU_ctor, corecU_unique)
  3.1371 +  end;
  3.1372 +
  3.1373 +fun derive_dtor_algLam ctxt Y Z preT fpT sig_T ssig_T dead_pre_map dtor dead_sig_map Lam eval algLam
  3.1374 +    x pre_map_comp dead_pre_map_id dead_pre_map_comp0 dead_pre_map_comp sig_map_comp
  3.1375 +    Oper_pointful_natural ssig_map_thms dead_ssig_map_comp0 Lam_pointful_natural eval_core_simps
  3.1376 +    eval_thm eval_flat eval_VLeaf algLam_def =
  3.1377 +  let
  3.1378 +    val fp_preT = Tsubst Y fpT preT;
  3.1379 +    val fppreT = HOLogic.mk_prodT (fpT, fp_preT);
  3.1380 +    val fp_sig_T = Tsubst Y fpT sig_T;
  3.1381 +    val fp_ssig_T = Tsubst Y fpT ssig_T;
  3.1382 +
  3.1383 +    val id' = HOLogic.id_const fpT;
  3.1384 +    val convol' = mk_convol (id', dtor);
  3.1385 +    val dead_pre_map' = Term.subst_atomic_types [(Y, fp_ssig_T), (Z, fpT)] dead_pre_map;
  3.1386 +    val dead_sig_map' = Term.subst_atomic_types [(Y, fpT), (Z, fppreT)] dead_sig_map;
  3.1387 +    val Lam' = substT Y fpT Lam;
  3.1388 +    val x' = substT Y fp_sig_T x;
  3.1389 +
  3.1390 +    val goal = mk_Trueprop_eq (dtor $ (algLam $ x'),
  3.1391 +      dead_pre_map' $ eval $ (Lam' $ (dead_sig_map' $ convol' $ x')));
  3.1392 +  in
  3.1393 +    Variable.add_free_names ctxt goal []
  3.1394 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1395 +      mk_dtor_algLam_tac ctxt pre_map_comp dead_pre_map_id dead_pre_map_comp0 dead_pre_map_comp
  3.1396 +        sig_map_comp Oper_pointful_natural ssig_map_thms dead_ssig_map_comp0 Lam_pointful_natural
  3.1397 +        eval_core_simps eval_thm eval_flat eval_VLeaf algLam_def))
  3.1398 +    |> Thm.close_derivation
  3.1399 +  end;
  3.1400 +
  3.1401 +fun derive_algLam_base ctxt Y Z preT fpT dead_pre_map ctor dtor algLam proto_sctr dead_pre_map_id
  3.1402 +    dead_pre_map_comp ctor_dtor dtor_ctor dtor_unfold_unique unsig_thm Sig_pointful_natural
  3.1403 +    ssig_map_thms Lam_def flat_simps eval_core_simps eval_thm algLam_def =
  3.1404 +  let
  3.1405 +    val fp_preT = Tsubst Y fpT preT;
  3.1406 +
  3.1407 +    val proto_sctr' = substT Y fpT proto_sctr;
  3.1408 +
  3.1409 +    val dead_pre_map' = Term.subst_atomic_types [(Y, fpT), (Z, fp_preT)] dead_pre_map;
  3.1410 +    val dead_pre_map_dtor = dead_pre_map' $ dtor;
  3.1411 +
  3.1412 +    val goal = mk_Trueprop_eq (HOLogic.mk_comp (algLam, proto_sctr'), ctor);
  3.1413 +  in
  3.1414 +    Variable.add_free_names ctxt goal []
  3.1415 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1416 +      mk_algLam_base_tac ctxt dead_pre_map_dtor dead_pre_map_id dead_pre_map_comp ctor_dtor
  3.1417 +        dtor_ctor dtor_unfold_unique unsig_thm Sig_pointful_natural ssig_map_thms Lam_def flat_simps
  3.1418 +        eval_core_simps eval_thm algLam_def))
  3.1419 +    |> Thm.close_derivation
  3.1420 +  end;
  3.1421 +
  3.1422 +fun derive_flat_embL ctxt Y Z old_ssig_T ssig_T dead_old_ssig_map embL old_flat flat x
  3.1423 +    old_ssig_induct fp_map_id Sig_pointful_natural old_sig_map_comp old_sig_map_cong
  3.1424 +    old_ssig_map_thms old_flat_simps flat_simps embL_simps =
  3.1425 +  let
  3.1426 +    val old_ssig_old_ssig_T = Tsubst Y old_ssig_T old_ssig_T;
  3.1427 +
  3.1428 +    val dead_old_ssig_map' =
  3.1429 +      Term.subst_atomic_types [(Y, old_ssig_T), (Z, ssig_T)] dead_old_ssig_map;
  3.1430 +    val embL' = substT Y ssig_T embL;
  3.1431 +    val x' = substT Y old_ssig_old_ssig_T x;
  3.1432 +
  3.1433 +    val goal = mk_Trueprop_eq (flat $ (embL' $ (dead_old_ssig_map' $ embL $ x')),
  3.1434 +      embL $ (old_flat $ x'));
  3.1435 +
  3.1436 +    val old_ssig_induct' =
  3.1437 +      infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt x')] old_ssig_induct;
  3.1438 +  in
  3.1439 +    Variable.add_free_names ctxt goal []
  3.1440 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1441 +      mk_flat_embL_tac ctxt old_ssig_induct' fp_map_id Sig_pointful_natural old_sig_map_comp
  3.1442 +        old_sig_map_cong old_ssig_map_thms old_flat_simps flat_simps embL_simps))
  3.1443 +    |> Thm.close_derivation
  3.1444 +  end;
  3.1445 +
  3.1446 +fun derive_eval_core_embL ctxt Y Z preT old_ssig_T ssig_T dead_pre_map embL old_eval_core eval_core
  3.1447 +    x old_ssig_induct dead_pre_map_comp0 dead_pre_map_comp Sig_pointful_natural unsig_thm
  3.1448 +    old_sig_map_comp old_sig_map_cong old_Lam_pointful_natural Lam_def flat_embL embL_simps
  3.1449 +    embL_pointful_natural old_eval_core_simps eval_core_simps =
  3.1450 +  let
  3.1451 +    val YpreT = HOLogic.mk_prodT (Y, preT);
  3.1452 +    val Ypre_old_ssig_T = Tsubst Y YpreT old_ssig_T;
  3.1453 +
  3.1454 +    val dead_pre_map' = Term.subst_atomic_types [(Y, old_ssig_T), (Z, ssig_T)] dead_pre_map;
  3.1455 +    val embL' = substT Y YpreT embL;
  3.1456 +    val x' = substT Y Ypre_old_ssig_T x;
  3.1457 +
  3.1458 +    val goal =
  3.1459 +      mk_Trueprop_eq (eval_core $ (embL' $ x'), dead_pre_map' $ embL $ (old_eval_core $ x'));
  3.1460 +
  3.1461 +    val old_ssig_induct' =
  3.1462 +      infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt x')] old_ssig_induct;
  3.1463 +  in
  3.1464 +    Variable.add_free_names ctxt goal []
  3.1465 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1466 +      mk_eval_core_embL_tac ctxt old_ssig_induct' dead_pre_map_comp0 dead_pre_map_comp
  3.1467 +        Sig_pointful_natural unsig_thm old_sig_map_comp old_sig_map_cong old_Lam_pointful_natural
  3.1468 +        Lam_def flat_embL old_eval_core_simps eval_core_simps embL_simps embL_pointful_natural))
  3.1469 +    |> Thm.close_derivation
  3.1470 +  end;
  3.1471 +
  3.1472 +fun derive_eval_embL ctxt Y fpT embL old_eval eval dead_pre_map_comp0 dtor_unfold_unique
  3.1473 +    embL_pointful_natural eval_core_embL old_eval_thm eval_thm =
  3.1474 +  let
  3.1475 +    val embL' = substT Y fpT embL;
  3.1476 +    val goal = mk_Trueprop_eq (HOLogic.mk_comp (eval, embL'), old_eval);
  3.1477 +  in
  3.1478 +    Variable.add_free_names ctxt goal []
  3.1479 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1480 +      mk_eval_embL_tac ctxt dead_pre_map_comp0 dtor_unfold_unique embL_pointful_natural
  3.1481 +        eval_core_embL old_eval_thm eval_thm))
  3.1482 +    |> Thm.close_derivation
  3.1483 +  end;
  3.1484 +
  3.1485 +fun derive_algLam_algLam ctxt Inx_const Y fpT Sig old_algLam algLam dead_pre_map_comp dtor_inject
  3.1486 +    unsig_thm sig_map_thm Lam_def eval_embL old_dtor_algLam dtor_algLam =
  3.1487 +  let
  3.1488 +    val Sig' = substT Y fpT Sig;
  3.1489 +    val (left_T, right_T) = dest_sumT (domain_type (fastype_of Sig'));
  3.1490 +    val inx' = Inx_const left_T right_T;
  3.1491 +
  3.1492 +    val goal = mk_Trueprop_eq (Library.foldl1 HOLogic.mk_comp [algLam, Sig', inx'], old_algLam);
  3.1493 +  in
  3.1494 +    Variable.add_free_names ctxt goal []
  3.1495 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1496 +      mk_algLam_algLam_tac ctxt dead_pre_map_comp dtor_inject unsig_thm sig_map_thm Lam_def
  3.1497 +        eval_embL old_dtor_algLam dtor_algLam))
  3.1498 +    |> Thm.close_derivation
  3.1499 +  end;
  3.1500 +
  3.1501 +fun derive_eval_core_k_as_ssig ctxt Y preT k_T rho eval_core k_as_ssig x pre_map_comp
  3.1502 +    dead_pre_map_id sig_map_comp ssig_map_thms Lam_natural_pointful Lam_Inr flat_VLeaf
  3.1503 +    eval_core_simps =
  3.1504 +  let
  3.1505 +    val YpreT = HOLogic.mk_prodT (Y, preT);
  3.1506 +    val Ypre_k_T = Tsubst Y YpreT k_T;
  3.1507 +
  3.1508 +    val k_as_ssig' = substT Y YpreT k_as_ssig;
  3.1509 +    val x' = substT Y Ypre_k_T x;
  3.1510 +
  3.1511 +    val goal = mk_Trueprop_eq (eval_core $ (k_as_ssig' $ x'), rho $ x');
  3.1512 +  in
  3.1513 +    Variable.add_free_names ctxt goal []
  3.1514 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1515 +      mk_eval_core_k_as_ssig_tac ctxt pre_map_comp dead_pre_map_id sig_map_comp ssig_map_thms
  3.1516 +        Lam_natural_pointful Lam_Inr flat_VLeaf eval_core_simps))
  3.1517 +    |> Thm.close_derivation
  3.1518 +  end;
  3.1519 +
  3.1520 +fun derive_algLam_algrho ctxt Y fpT Sig algLam algrho algLam_def algrho_def =
  3.1521 +  let
  3.1522 +    val Sig' = substT Y fpT Sig;
  3.1523 +    val (left_T, right_T) = dest_sumT (domain_type (fastype_of Sig'));
  3.1524 +    val inr' = Inr_const left_T right_T;
  3.1525 +
  3.1526 +    val goal = mk_Trueprop_eq (Library.foldl1 HOLogic.mk_comp [algLam, Sig', inr'], algrho);
  3.1527 +  in
  3.1528 +    Variable.add_free_names ctxt goal []
  3.1529 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1530 +      mk_algLam_algrho_tac ctxt algLam_def algrho_def))
  3.1531 +    |> Thm.close_derivation
  3.1532 +  end;
  3.1533 +
  3.1534 +fun derive_dtor_algrho ctxt Y Z preT fpT k_T ssig_T dead_pre_map dead_k_map dtor rho eval algrho x
  3.1535 +    eval_thm k_as_ssig_natural_pointful eval_core_k_as_ssig algrho_def =
  3.1536 +  let
  3.1537 +    val YpreT = HOLogic.mk_prodT (Y, preT);
  3.1538 +    val fppreT = Tsubst Y fpT YpreT;
  3.1539 +    val fp_k_T = Tsubst Y fpT k_T;
  3.1540 +    val fp_ssig_T = Tsubst Y fpT ssig_T;
  3.1541 +
  3.1542 +    val id' = HOLogic.id_const fpT;
  3.1543 +    val convol' = mk_convol (id', dtor);
  3.1544 +    val dead_pre_map' = Term.subst_atomic_types [(Y, fp_ssig_T), (Z, fpT)] dead_pre_map;
  3.1545 +    val dead_k_map' = Term.subst_atomic_types [(Y, fpT), (Z, fppreT)] dead_k_map;
  3.1546 +    val rho' = substT Y fpT rho;
  3.1547 +    val x' = substT Y fp_k_T x;
  3.1548 +
  3.1549 +    val goal = mk_Trueprop_eq (dtor $ (algrho $ x'),
  3.1550 +      dead_pre_map' $ eval $ (rho' $ (dead_k_map' $ convol' $ x')));
  3.1551 +  in
  3.1552 +    Variable.add_free_names ctxt goal []
  3.1553 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1554 +      mk_dtor_algrho_tac ctxt eval_thm k_as_ssig_natural_pointful eval_core_k_as_ssig algrho_def))
  3.1555 +    |> Thm.close_derivation
  3.1556 +  end;
  3.1557 +
  3.1558 +fun derive_algLam_step_or_merge ctxt Y fpT ctor proto_sctr algLam proto_sctr_def old_algLam_pointful
  3.1559 +    algLam_algLam =
  3.1560 +  let
  3.1561 +    val proto_sctr' = substT Y fpT proto_sctr;
  3.1562 +    val goal = mk_Trueprop_eq (HOLogic.mk_comp (algLam, proto_sctr'), ctor);
  3.1563 +
  3.1564 +    val algLam_algLam_pointful = mk_pointful ctxt algLam_algLam;
  3.1565 +  in
  3.1566 +    Variable.add_free_names ctxt goal []
  3.1567 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1568 +      mk_algLam_step_tac ctxt proto_sctr_def old_algLam_pointful algLam_algLam_pointful))
  3.1569 +    |> Thm.close_derivation
  3.1570 +  end;
  3.1571 +
  3.1572 +fun derive_eval_sctr ctxt Y Z fpT ssig_T dead_pre_map ctor eval sctr proto_sctr_pointful_natural
  3.1573 +    eval_Oper algLam_thm sctr_def =
  3.1574 +  let
  3.1575 +    val fp_ssig_T = Tsubst Y fpT ssig_T;
  3.1576 +
  3.1577 +    val dead_pre_map' = Term.subst_atomic_types [(Y, fp_ssig_T), (Z, fpT)] dead_pre_map;
  3.1578 +    val sctr' = substT Y fpT sctr;
  3.1579 +
  3.1580 +    val goal = mk_Trueprop_eq (HOLogic.mk_comp (eval, sctr'),
  3.1581 +      HOLogic.mk_comp (ctor, dead_pre_map' $ eval));
  3.1582 +  in
  3.1583 +    Variable.add_free_names ctxt goal []
  3.1584 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1585 +      mk_eval_sctr_tac ctxt proto_sctr_pointful_natural eval_Oper algLam_thm sctr_def))
  3.1586 +    |> Thm.close_derivation
  3.1587 +  end;
  3.1588 +
  3.1589 +fun derive_corecUU_pointfree_unique ctxt Y Z preT fpT ssig_T dead_pre_map ctor dead_ssig_map eval
  3.1590 +    corecUU f g dead_pre_map_comp0 dead_pre_map_comp dtor_ctor dtor_inject ssig_map_comp
  3.1591 +    flat_pointful_natural eval_core_pointful_natural eval_thm eval_flat corecU_ctor corecU_unique
  3.1592 +    sctr_pointful_natural eval_sctr_pointful corecUU_def =
  3.1593 +  let
  3.1594 +    val ssig_preT = Tsubst Y ssig_T preT;
  3.1595 +    val ssig_pre_ssig_T = Tsubst Y ssig_preT ssig_T;
  3.1596 +    val fp_ssig_T = Tsubst Y fpT ssig_T;
  3.1597 +
  3.1598 +    val dead_pre_map' = Term.subst_atomic_types [(Y, fp_ssig_T), (Z, fpT)] dead_pre_map;
  3.1599 +    val dead_pre_map'' = Term.subst_atomic_types [(Y, ssig_T), (Z, fp_ssig_T)] dead_pre_map;
  3.1600 +    val dead_ssig_map' = Term.subst_atomic_types [(Y, ssig_preT), (Z, fpT)] dead_ssig_map;
  3.1601 +    val dead_ssig_map'' = substT Z fpT dead_ssig_map;
  3.1602 +    val f' = substT Z ssig_pre_ssig_T f;
  3.1603 +    val g' = substT Z fpT g;
  3.1604 +    val corecUU_f = corecUU $ f';
  3.1605 +
  3.1606 +    fun mk_eq fpf =
  3.1607 +      mk_Trueprop_eq (fpf, Library.foldl1 HOLogic.mk_comp [eval, dead_ssig_map' $
  3.1608 +          Library.foldl1 HOLogic.mk_comp [ctor, dead_pre_map' $ eval, dead_pre_map''
  3.1609 +            $ (dead_ssig_map'' $ fpf)],
  3.1610 +        f']);
  3.1611 +
  3.1612 +    val corecUU_pointfree =
  3.1613 +      let
  3.1614 +        val goal = mk_eq corecUU_f;
  3.1615 +      in
  3.1616 +        Variable.add_free_names ctxt goal []
  3.1617 +        |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1618 +          mk_corecUU_pointfree_tac ctxt dead_pre_map_comp0 dead_pre_map_comp dtor_ctor dtor_inject
  3.1619 +            ssig_map_comp flat_pointful_natural eval_core_pointful_natural eval_thm eval_flat
  3.1620 +            corecU_ctor sctr_pointful_natural eval_sctr_pointful corecUU_def))
  3.1621 +        |> Thm.close_derivation
  3.1622 +      end;
  3.1623 +
  3.1624 +    val corecUU_unique =
  3.1625 +      let
  3.1626 +        val prem = mk_eq g';
  3.1627 +        val goal = mk_Trueprop_eq (g', corecUU_f);
  3.1628 +      in
  3.1629 +        fold (Variable.add_free_names ctxt) [prem, goal] []
  3.1630 +        |> (fn vars => Goal.prove_sorry ctxt vars [prem] goal
  3.1631 +              (fn {context = ctxt, prems = [prem]} =>
  3.1632 +                mk_corecUU_unique_tac ctxt dead_pre_map_comp0 dead_pre_map_comp dtor_ctor
  3.1633 +                  ssig_map_comp flat_pointful_natural eval_core_pointful_natural eval_thm eval_flat
  3.1634 +                  corecU_unique sctr_pointful_natural eval_sctr_pointful corecUU_def prem))
  3.1635 +        |> Thm.close_derivation
  3.1636 +      end;
  3.1637 +  in
  3.1638 +    (corecUU_pointfree, corecUU_unique)
  3.1639 +  end;
  3.1640 +
  3.1641 +fun define_flat_etc fp_b version live_AsBs Y Z preT fpT sig_T ssig_T Oper VLeaf CLeaf pre_rel
  3.1642 +    dead_pre_map dtor dtor_unfold dead_sig_map ssig_rel dead_ssig_map Lam Rs R pre_map_transfer
  3.1643 +    fp_k_T_rel_eqs sig_map_transfer ssig_map_transfer Lam_transfer dtor_transfer lthy =
  3.1644 +  let
  3.1645 +    val (flat_data as (flat, flat_def, _), lthy) = lthy
  3.1646 +      |> define_flat fp_b version Y Z fpT sig_T ssig_T Oper VLeaf CLeaf dead_sig_map;
  3.1647 +
  3.1648 +    val (eval_core_data as (eval_core, eval_core_def, _), lthy) = lthy
  3.1649 +      |> define_eval_core fp_b version Y Z preT fpT sig_T ssig_T dtor Oper VLeaf CLeaf dead_pre_map
  3.1650 +        dead_sig_map dead_ssig_map flat Lam;
  3.1651 +
  3.1652 +    val ((eval_data as (eval, _), cutSsig_data as (cutSsig, _)), lthy) = lthy
  3.1653 +      |> define_eval fp_b version Y Z preT fpT ssig_T dtor dtor_unfold dead_ssig_map eval_core
  3.1654 +      ||>> define_cutSsig fp_b version Y Z preT ssig_T dead_pre_map VLeaf dead_ssig_map flat
  3.1655 +        eval_core;
  3.1656 +
  3.1657 +    val ((algLam_data, unfold_data), lthy) = lthy
  3.1658 +      |> define_algLam fp_b version Y Z fpT ssig_T Oper VLeaf dead_sig_map eval
  3.1659 +      ||>> define_corecU fp_b version Y Z preT ssig_T dtor_unfold VLeaf cutSsig;
  3.1660 +
  3.1661 +    val flat_transfer = derive_transfer_by_transfer_prover lthy live_AsBs Rs R flat [flat_def] []
  3.1662 +      [sig_map_transfer];
  3.1663 +    val eval_core_transfer = derive_Lam_or_eval_core_transfer lthy live_AsBs Y Z preT ssig_T Rs R
  3.1664 +      pre_rel ssig_rel ssig_rel eval_core eval_core_def fp_k_T_rel_eqs
  3.1665 +      [pre_map_transfer, sig_map_transfer, ssig_map_transfer, flat_transfer, Lam_transfer,
  3.1666 +       dtor_transfer];
  3.1667 +  in
  3.1668 +    (((((((flat_data, flat_transfer), (eval_core_data, eval_core_transfer)), eval_data),
  3.1669 +      cutSsig_data), algLam_data), unfold_data), lthy)
  3.1670 +  end;
  3.1671 +
  3.1672 +fun derive_Sig_natural_etc ctxt live live_AsBs Y Z preT fpT k_or_fpT sig_T ssig_T pre_map
  3.1673 +    dead_pre_map ctor dtor Sig dead_sig_map Oper VLeaf CLeaf ssig_map dead_ssig_map Lam flat
  3.1674 +    eval_core eval cutSsig algLam corecU x fs f g ctor_dtor dtor_inject dtor_unfold_thm
  3.1675 +    dtor_unfold_unique sig_map_thm ssig_induct ssig_map_thms Oper_map_thm VLeaf_map_thm
  3.1676 +    CLeaf_map_thm Lam_transfer flat_simps flat_transfer eval_core_simps eval_core_transfer eval_def
  3.1677 +    cutSsig_def algLam_def corecU_def live_pre_bnf pre_bnf dead_pre_bnf fp_bnf sig_bnf ssig_bnf
  3.1678 +    dead_ssig_bnf =
  3.1679 +  let
  3.1680 +    val SOME prod_fp_sugar = fp_sugar_of ctxt @{type_name prod};
  3.1681 +    val prod_bnf = #fp_bnf prod_fp_sugar;
  3.1682 +
  3.1683 +    val f' = substT Z fpT f;
  3.1684 +    val dead_ssig_map' = substT Z fpT dead_ssig_map;
  3.1685 +    val extdd = Term.lambda f' (HOLogic.mk_comp (eval, dead_ssig_map' $ f'));
  3.1686 +
  3.1687 +    val live_pre_map_def = map_def_of_bnf live_pre_bnf;
  3.1688 +    val pre_map_comp = map_comp_of_bnf pre_bnf;
  3.1689 +    val dead_pre_map_id = map_id_of_bnf dead_pre_bnf;
  3.1690 +    val dead_pre_map_comp0 = map_comp0_of_bnf dead_pre_bnf;
  3.1691 +    val dead_pre_map_comp = map_comp_of_bnf dead_pre_bnf;
  3.1692 +    val dead_pre_map_cong = map_cong_of_bnf dead_pre_bnf;
  3.1693 +    val fp_map_id = map_id_of_bnf fp_bnf;
  3.1694 +    val sig_map_ident = map_ident_of_bnf sig_bnf;
  3.1695 +    val sig_map_comp0 = map_comp0_of_bnf sig_bnf;
  3.1696 +    val sig_map_comp = map_comp_of_bnf sig_bnf;
  3.1697 +    val sig_map_cong = map_cong_of_bnf sig_bnf;
  3.1698 +    val ssig_map_id = map_id_of_bnf ssig_bnf;
  3.1699 +    val ssig_map_comp = map_comp_of_bnf ssig_bnf;
  3.1700 +    val dead_ssig_map_comp0 = map_comp0_of_bnf dead_ssig_bnf;
  3.1701 +
  3.1702 +    val k_preT_map_id0s =
  3.1703 +      map map_id0_of_bnf (map_filter (bnf_of ctxt) (fold add_type_namesT [preT, k_or_fpT] []));
  3.1704 +
  3.1705 +    val Sig_natural = derive_natural_by_unfolding ctxt live_AsBs preT pre_map fs f Sig
  3.1706 +      ([sig_map_thm, live_pre_map_def, @{thm BNF_Composition.id_bnf_def}] @ k_preT_map_id0s);
  3.1707 +    val Oper_natural =
  3.1708 +      derive_natural_by_unfolding ctxt live_AsBs preT pre_map fs f Oper [Oper_map_thm];
  3.1709 +    val VLeaf_natural =
  3.1710 +      derive_natural_by_unfolding ctxt live_AsBs preT pre_map fs f VLeaf [VLeaf_map_thm];
  3.1711 +    val Lam_natural = derive_natural_from_transfer_with_pre_type ctxt live_AsBs Y Z preT ssig_T
  3.1712 +      pre_map ssig_map fs f Lam Lam_transfer [prod_bnf, pre_bnf, sig_bnf, ssig_bnf] [];
  3.1713 +    val flat_natural = derive_natural_from_transfer ctxt live_AsBs [] fs f flat flat_transfer
  3.1714 +      [ssig_bnf] [];
  3.1715 +    val eval_core_natural = derive_natural_from_transfer_with_pre_type ctxt live_AsBs Y Z preT
  3.1716 +      ssig_T pre_map ssig_map fs f eval_core eval_core_transfer [prod_bnf, pre_bnf, ssig_bnf] [];
  3.1717 +
  3.1718 +    val Sig_pointful_natural = mk_pointful ctxt Sig_natural RS sym;
  3.1719 +    val Oper_natural_pointful = mk_pointful ctxt Oper_natural;
  3.1720 +    val Oper_pointful_natural = Oper_natural_pointful RS sym;
  3.1721 +    val flat_pointful_natural = mk_pointful ctxt flat_natural RS sym;
  3.1722 +    val Lam_natural_pointful = mk_pointful ctxt Lam_natural;
  3.1723 +    val Lam_pointful_natural = Lam_natural_pointful RS sym;
  3.1724 +    val eval_core_pointful_natural = mk_pointful ctxt eval_core_natural RS sym;
  3.1725 +    val cutSsig_def_pointful_natural = mk_pointful ctxt (cutSsig_def RS meta_eq_to_obj_eq) RS sym;
  3.1726 +
  3.1727 +    val flat_VLeaf = derive_flat_VLeaf ctxt Y Z ssig_T x VLeaf dead_ssig_map flat ssig_induct
  3.1728 +      fp_map_id sig_map_cong sig_map_ident sig_map_comp ssig_map_thms flat_simps;
  3.1729 +    val flat_flat = derive_flat_flat ctxt Y Z ssig_T x dead_ssig_map flat ssig_induct fp_map_id
  3.1730 +      sig_map_cong sig_map_comp ssig_map_thms flat_simps;
  3.1731 +
  3.1732 +    val eval_core_flat = derive_eval_core_flat ctxt Y Z preT ssig_T dead_pre_map dead_ssig_map flat
  3.1733 +      eval_core x ssig_induct dead_pre_map_id dead_pre_map_comp0 dead_pre_map_comp fp_map_id
  3.1734 +      sig_map_comp sig_map_cong ssig_map_thms ssig_map_comp flat_simps flat_pointful_natural
  3.1735 +      flat_flat Lam_pointful_natural eval_core_simps;
  3.1736 +
  3.1737 +    val eval_thm = derive_eval_thm ctxt dtor_inject dtor_unfold_thm eval_def;
  3.1738 +    val eval_flat = derive_eval_flat ctxt Y Z fpT ssig_T dead_ssig_map flat eval x
  3.1739 +      dead_pre_map_comp0 dtor_unfold_unique ssig_map_id ssig_map_comp flat_pointful_natural
  3.1740 +      eval_core_pointful_natural eval_core_flat eval_thm;
  3.1741 +    val eval_Oper = derive_eval_Oper ctxt live Y Z fpT sig_T ssig_T dead_sig_map Oper eval algLam x
  3.1742 +      sig_map_ident sig_map_comp0 sig_map_comp Oper_natural_pointful VLeaf_natural flat_simps
  3.1743 +      eval_flat algLam_def;
  3.1744 +    val eval_VLeaf = derive_eval_V_or_CLeaf ctxt Y fpT VLeaf eval x dead_pre_map_id
  3.1745 +      dead_pre_map_comp fp_map_id dtor_unfold_unique VLeaf_map_thm eval_core_simps eval_thm;
  3.1746 +    val eval_CLeaf = derive_eval_V_or_CLeaf ctxt Y fpT CLeaf eval x dead_pre_map_id
  3.1747 +      dead_pre_map_comp fp_map_id dtor_unfold_unique CLeaf_map_thm eval_core_simps eval_thm;
  3.1748 +
  3.1749 +    val extdd_mor = derive_extdd_mor ctxt Y Z preT fpT ssig_T dead_pre_map dtor extdd cutSsig f g
  3.1750 +      dead_pre_map_comp0 dead_pre_map_comp VLeaf_map_thm ssig_map_comp flat_pointful_natural
  3.1751 +      eval_core_pointful_natural eval_thm eval_flat eval_VLeaf cutSsig_def;
  3.1752 +    val mor_cutSsig_flat = derive_mor_cutSsig_flat ctxt Y Z preT fpT ssig_T dead_pre_map
  3.1753 +      dead_ssig_map dtor flat eval_core eval cutSsig f g dead_pre_map_comp0 dead_pre_map_comp
  3.1754 +      dead_pre_map_cong dtor_unfold_unique dead_ssig_map_comp0 ssig_map_comp flat_simps
  3.1755 +      flat_pointful_natural eval_core_pointful_natural flat_flat flat_VLeaf eval_core_flat
  3.1756 +      cutSsig_def cutSsig_def_pointful_natural eval_thm;
  3.1757 +    val extdd_o_VLeaf = derive_extdd_o_VLeaf ctxt Y Z preT fpT ssig_T dead_pre_map dtor VLeaf extdd
  3.1758 +      f g dead_pre_map_comp0 dead_pre_map_comp dtor_inject ssig_map_thms eval_core_simps eval_thm
  3.1759 +      eval_VLeaf;
  3.1760 +
  3.1761 +    val (corecU_ctor, corecU_unique) = derive_corecU_ctor_unique ctxt Y Z preT fpT ssig_T
  3.1762 +      dead_pre_map ctor dtor VLeaf extdd corecU f g dead_pre_map_comp ctor_dtor dtor_unfold_thm
  3.1763 +      dtor_unfold_unique ssig_map_thms dead_ssig_map_comp0 flat_simps flat_VLeaf eval_core_simps
  3.1764 +      extdd_mor extdd_o_VLeaf cutSsig_def mor_cutSsig_flat corecU_def;
  3.1765 +
  3.1766 +    val dtor_algLam = derive_dtor_algLam ctxt Y Z preT fpT sig_T ssig_T dead_pre_map dtor
  3.1767 +      dead_sig_map Lam eval algLam x pre_map_comp dead_pre_map_id dead_pre_map_comp0
  3.1768 +      dead_pre_map_comp sig_map_comp Oper_pointful_natural ssig_map_thms dead_ssig_map_comp0
  3.1769 +      Lam_pointful_natural eval_core_simps eval_thm eval_flat eval_VLeaf algLam_def;
  3.1770 +  in
  3.1771 +    (Sig_pointful_natural, flat_pointful_natural, Lam_natural_pointful, Lam_pointful_natural,
  3.1772 +     flat_VLeaf, eval_core_pointful_natural, eval_thm, eval_flat,
  3.1773 +     [eval_Oper, eval_VLeaf, eval_CLeaf], corecU_ctor, corecU_unique, dtor_algLam)
  3.1774 +  end;
  3.1775 +
  3.1776 +fun derive_embL_natural_etc ctxt Inx_const old_ssig_bnf ssig_bnf Y Z preT fpT old_ssig_T ssig_T
  3.1777 +    dead_pre_map Sig dead_old_ssig_map embL old_algLam algLam old_flat flat old_eval_core eval_core
  3.1778 +    old_eval eval x f old_ssig_induct dead_pre_map_comp0 dead_pre_map_comp fp_map_id dtor_inject
  3.1779 +    dtor_unfold_unique Sig_pointful_natural unsig_thm sig_map_thm old_sig_map_comp old_sig_map_cong
  3.1780 +    old_ssig_map_thms old_Lam_pointful_natural Lam_def old_flat_simps flat_simps embL_simps
  3.1781 +    embL_transfer old_eval_core_simps eval_core_simps old_eval_thm eval_thm old_dtor_algLam
  3.1782 +    dtor_algLam old_algLam_thm =
  3.1783 +  let
  3.1784 +    val embL_natural = derive_natural_from_transfer ctxt [(Y, Z)] [] [] f embL embL_transfer
  3.1785 +      [old_ssig_bnf, ssig_bnf] [];
  3.1786 +
  3.1787 +    val embL_pointful_natural = mk_pointful ctxt embL_natural RS sym;
  3.1788 +    val old_algLam_pointful = mk_pointful ctxt old_algLam_thm;
  3.1789 +
  3.1790 +    val flat_embL = derive_flat_embL ctxt Y Z old_ssig_T ssig_T dead_old_ssig_map embL old_flat flat
  3.1791 +      x old_ssig_induct fp_map_id Sig_pointful_natural old_sig_map_comp old_sig_map_cong
  3.1792 +      old_ssig_map_thms old_flat_simps flat_simps embL_simps;
  3.1793 +    val eval_core_embL = derive_eval_core_embL ctxt Y Z preT old_ssig_T ssig_T dead_pre_map embL
  3.1794 +      old_eval_core eval_core x old_ssig_induct dead_pre_map_comp0 dead_pre_map_comp
  3.1795 +      Sig_pointful_natural unsig_thm old_sig_map_comp old_sig_map_cong old_Lam_pointful_natural
  3.1796 +      Lam_def flat_embL embL_simps embL_pointful_natural old_eval_core_simps eval_core_simps;
  3.1797 +    val eval_embL = derive_eval_embL ctxt Y fpT embL old_eval eval dead_pre_map_comp0
  3.1798 +      dtor_unfold_unique embL_pointful_natural eval_core_embL old_eval_thm eval_thm;
  3.1799 +
  3.1800 +    val algLam_algLam = derive_algLam_algLam ctxt Inx_const Y fpT Sig old_algLam algLam
  3.1801 +      dead_pre_map_comp dtor_inject unsig_thm sig_map_thm Lam_def eval_embL old_dtor_algLam
  3.1802 +      dtor_algLam;
  3.1803 +  in
  3.1804 +    (embL_pointful_natural, old_algLam_pointful, eval_embL, algLam_algLam)
  3.1805 +  end;
  3.1806 +
  3.1807 +fun define_corecUU_etc fp_b version live_AsBs Y Z preT fpT ssig_T pre_map dead_pre_map pre_rel
  3.1808 +    fp_rel ctor Oper ssig_map dead_ssig_map ssig_rel proto_sctr flat eval_core eval corecU fs f g Rs
  3.1809 +    R pre_map_transfer fp_k_T_rel_eqs dtor_unfold_transfer dtor_transfer ssig_map_transfer
  3.1810 +    proto_sctr_transfer proto_sctr_pointful_natural flat_transfer flat_pointful_natural
  3.1811 +    eval_core_transfer eval_core_pointful_natural eval_thm eval_flat eval_Oper algLam_thm
  3.1812 +    cutSsig_def corecU_def corecU_ctor corecU_unique pre_bnf dead_pre_bnf fp_res ssig_fp_sugar
  3.1813 +    lthy =
  3.1814 +  let
  3.1815 +    val ssig_bnf = #fp_bnf ssig_fp_sugar;
  3.1816 +
  3.1817 +    val dead_pre_map_comp0 = map_comp0_of_bnf dead_pre_bnf;
  3.1818 +    val dead_pre_map_comp = map_comp_of_bnf dead_pre_bnf;
  3.1819 +    val [dtor_ctor] = #dtor_ctors fp_res;
  3.1820 +    val [dtor_inject] = #dtor_injects fp_res;
  3.1821 +    val ssig_map_comp = map_comp_of_bnf ssig_bnf;
  3.1822 +
  3.1823 +    val sctr_rhs = HOLogic.mk_comp (Oper, substT Y ssig_T proto_sctr);
  3.1824 +    val ((sctr, sctr_def), lthy) = lthy
  3.1825 +      |> define_const true fp_b version sctrN sctr_rhs;
  3.1826 +
  3.1827 +    val (corecUU_data as (corecUU, corecUU_def), lthy) = lthy
  3.1828 +      |> define_corecUU fp_b version Y Z preT ssig_T dead_pre_map dead_ssig_map flat eval_core sctr
  3.1829 +        corecU;
  3.1830 +
  3.1831 +    val eval_sctr = derive_eval_sctr lthy Y Z fpT ssig_T dead_pre_map ctor eval sctr
  3.1832 +      proto_sctr_pointful_natural eval_Oper algLam_thm sctr_def;
  3.1833 +
  3.1834 +    val sctr_transfer = derive_sctr_transfer lthy live_AsBs Y Z ssig_T Rs R pre_rel ssig_rel sctr
  3.1835 +      sctr_def fp_k_T_rel_eqs [proto_sctr_transfer];
  3.1836 +
  3.1837 +    val sctr_natural = derive_natural_from_transfer_with_pre_type lthy live_AsBs Y Z preT ssig_T
  3.1838 +      pre_map ssig_map fs f sctr sctr_transfer [pre_bnf, ssig_bnf] [];
  3.1839 +
  3.1840 +    val sctr_pointful_natural = mk_pointful lthy sctr_natural RS sym;
  3.1841 +    val eval_sctr_pointful = mk_pointful lthy eval_sctr RS sym;
  3.1842 +
  3.1843 +    val (corecUU_pointfree, corecUU_unique) = derive_corecUU_pointfree_unique lthy Y Z preT fpT
  3.1844 +      ssig_T dead_pre_map ctor dead_ssig_map eval corecUU f g dead_pre_map_comp0 dead_pre_map_comp
  3.1845 +      dtor_ctor dtor_inject ssig_map_comp flat_pointful_natural eval_core_pointful_natural eval_thm
  3.1846 +      eval_flat corecU_ctor corecU_unique sctr_pointful_natural eval_sctr_pointful corecUU_def;
  3.1847 +
  3.1848 +    val corecUU_thm = mk_pointful lthy corecUU_pointfree;
  3.1849 +
  3.1850 +    val corecUU_transfer = derive_corecUU_transfer lthy live_AsBs Y Z Rs R preT ssig_T pre_rel
  3.1851 +      fp_rel ssig_rel corecUU cutSsig_def corecU_def corecUU_def fp_k_T_rel_eqs
  3.1852 +      [pre_map_transfer, dtor_unfold_transfer, dtor_transfer, ssig_map_transfer, flat_transfer,
  3.1853 +       eval_core_transfer, sctr_transfer, @{thm convol_transfer} (*FIXME: needed?*)];
  3.1854 +  in
  3.1855 +    ((corecUU_data, corecUU_thm, corecUU_unique, corecUU_transfer, eval_sctr, sctr_transfer,
  3.1856 +      sctr_pointful_natural), lthy)
  3.1857 +  end;
  3.1858 +
  3.1859 +fun mk_equivp T = Const (@{const_name equivp}, mk_predT [mk_pred2T T T]);
  3.1860 +
  3.1861 +fun derive_equivp_Retr ctxt fpT Retr R dead_pre_rel_refl_thm dead_pre_rel_flip_thm
  3.1862 +    dead_pre_rel_mono_thm dead_pre_rel_compp_thm =
  3.1863 +  let
  3.1864 +    val prem = HOLogic.mk_Trueprop (mk_equivp fpT $ R);
  3.1865 +    val goal = Logic.mk_implies (prem, HOLogic.mk_Trueprop (mk_equivp fpT $ (betapply (Retr, R))));
  3.1866 +  in
  3.1867 +    Variable.add_free_names ctxt goal []
  3.1868 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  3.1869 +      mk_equivp_Retr_tac ctxt dead_pre_rel_refl_thm dead_pre_rel_flip_thm dead_pre_rel_mono_thm
  3.1870 +        dead_pre_rel_compp_thm))
  3.1871 +    |> Thm.close_derivation
  3.1872 +  end;
  3.1873 +
  3.1874 +fun derive_Retr_coinduct ctxt fpT Retr R dtor_rel_coinduct_thm rel_eq_thm =
  3.1875 +  let
  3.1876 +    val goal = HOLogic.mk_Trueprop (list_all_free [R]
  3.1877 +      (HOLogic.mk_imp (mk_leq R (Retr $ R), mk_leq R (HOLogic.eq_const fpT))));
  3.1878 +  in
  3.1879 +    Goal.prove_sorry ctxt [] [] goal (fn {context = ctxt, prems = _} =>
  3.1880 +      mk_Retr_coinduct_tac ctxt dtor_rel_coinduct_thm rel_eq_thm)
  3.1881 +    |> Thm.close_derivation
  3.1882 +  end;
  3.1883 +
  3.1884 +fun derive_Retr fp_sugar fpT dead_pre_bnf ctor dtor names_lthy lthy =
  3.1885 +  let
  3.1886 +    val (R, _) = names_lthy
  3.1887 +      |> yield_singleton (mk_Frees "R") (mk_pred2T fpT fpT);
  3.1888 +    val pre_fpT = pre_type_of_ctor fpT ctor;
  3.1889 +    val fp_pre_rel = mk_rel1 lthy fpT fpT pre_fpT dead_pre_bnf;
  3.1890 +    val Retr = Abs ("R", fastype_of R, Abs ("a", fpT,
  3.1891 +      Abs ("b", fpT, list_comb (fp_pre_rel, [Bound 2, dtor $ Bound 1, dtor $ Bound 0]))));
  3.1892 +    val equivp_Retr = derive_equivp_Retr lthy fpT Retr R (rel_refl_of_bnf dead_pre_bnf)
  3.1893 +      (rel_flip_of_bnf dead_pre_bnf) (rel_mono_of_bnf dead_pre_bnf) (rel_OO_of_bnf dead_pre_bnf);
  3.1894 +
  3.1895 +    val Retr_coinduct = derive_Retr_coinduct lthy fpT Retr R
  3.1896 +      (fp_sugar |> #fp_res |> #xtor_rel_co_induct) (fp_sugar |> #fp_bnf |> rel_eq_of_bnf);
  3.1897 +  in
  3.1898 +    (Retr, equivp_Retr, Retr_coinduct)
  3.1899 +  end;
  3.1900 +
  3.1901 +fun mk_gen_cong fpT eval_domT =
  3.1902 +  let val fp_relT = mk_pred2T fpT fpT in
  3.1903 +    Const (@{const_name "cong.gen_cong"},
  3.1904 +      [mk_predT [fp_relT, eval_domT, eval_domT], eval_domT --> fpT, fp_relT] ---> fp_relT)
  3.1905 +  end;
  3.1906 +
  3.1907 +fun mk_cong_locale rel eval Retr =
  3.1908 +  Const (@{const_name cong}, mk_predT (map fastype_of [rel, eval, Retr]));
  3.1909 +
  3.1910 +fun derive_cong_locale ctxt rel eval Retr0 tac =
  3.1911 +  let
  3.1912 +    val Retr = enforce_type ctxt domain_type (domain_type (fastype_of rel)) Retr0;
  3.1913 +    val goal = HOLogic.mk_Trueprop (list_comb (mk_cong_locale rel eval Retr, [rel, eval, Retr]));
  3.1914 +  in
  3.1915 +    Variable.add_free_names ctxt goal []
  3.1916 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} => tac ctxt))
  3.1917 +    |> Thm.close_derivation
  3.1918 +  end;
  3.1919 +
  3.1920 +fun derive_cong_general fp_b version fpT dead_ssig_bnf dead_pre_bnf eval Retr equivp_Retr
  3.1921 +    Retr_coinduct eval_thm eval_core_transfer lthy =
  3.1922 +  let
  3.1923 +    val eval_domT = domain_type (fastype_of eval);
  3.1924 +
  3.1925 +    fun cong_locale_tac ctxt =
  3.1926 +      mk_cong_locale_tac ctxt (rel_mono_of_bnf dead_pre_bnf) (rel_map_of_bnf dead_pre_bnf)
  3.1927 +        equivp_Retr (rel_mono_of_bnf dead_ssig_bnf) (rel_map_of_bnf dead_ssig_bnf) eval_thm
  3.1928 +        eval_core_transfer;
  3.1929 +
  3.1930 +    val rel = mk_rel1 lthy fpT fpT eval_domT dead_ssig_bnf;
  3.1931 +    val cong_rhs = list_comb (mk_gen_cong fpT eval_domT, [rel, eval]);
  3.1932 +    val ((_, cong_def), lthy) = lthy
  3.1933 +      |> define_const false fp_b version congN cong_rhs;
  3.1934 +
  3.1935 +    val cong_locale = derive_cong_locale lthy rel eval Retr cong_locale_tac;
  3.1936 +
  3.1937 +    val fold_cong_def = fold_thms lthy [cong_def];
  3.1938 +
  3.1939 +    fun instance_of_gen thm = fold_cong_def (thm OF [cong_locale]);
  3.1940 +
  3.1941 +    val cong_base = instance_of_gen @{thm cong.imp_gen_cong};
  3.1942 +    val cong_refl = instance_of_gen @{thm cong.gen_cong_reflp};
  3.1943 +    val cong_sym = instance_of_gen @{thm cong.gen_cong_symp};
  3.1944 +    val cong_trans = instance_of_gen @{thm cong.gen_cong_transp};
  3.1945 +
  3.1946 +    fun mk_cong_rho thm = thm RS instance_of_gen @{thm cong.gen_cong_rho};
  3.1947 +
  3.1948 +    val dtor_coinduct = @{thm predicate2I_obj} RS
  3.1949 +      (Retr_coinduct RS instance_of_gen @{thm cong.coinduction} RS @{thm predicate2D_obj});
  3.1950 +  in
  3.1951 +    (cong_def, cong_locale, cong_base, cong_refl, cong_sym, cong_trans, dtor_coinduct, mk_cong_rho,
  3.1952 +     lthy)
  3.1953 +  end;
  3.1954 +
  3.1955 +fun derive_cong_base fp_b version fpT dead_ssig_bnf ssig_fp_bnf_sugar dead_pre_bnf eval eval_thm
  3.1956 +    eval_core_transfer eval_VLeaf eval_sctr sctr_transfer Retr equivp_Retr Retr_coinduct lthy =
  3.1957 +  let
  3.1958 +    val (cong_def, cong_locale, cong_base, cong_refl, cong_sym, cong_trans, dtor_coinduct,
  3.1959 +         mk_cong_rho, lthy) =
  3.1960 +      derive_cong_general fp_b version fpT dead_ssig_bnf dead_pre_bnf eval Retr equivp_Retr
  3.1961 +        Retr_coinduct eval_thm eval_core_transfer lthy;
  3.1962 +
  3.1963 +    val dead_pre_map_id0 = map_id0_of_bnf dead_pre_bnf;
  3.1964 +    val dead_pre_map_comp0 = map_comp0_of_bnf dead_pre_bnf;
  3.1965 +    val dead_pre_map_cong0 = map_cong0_of_bnf dead_pre_bnf;
  3.1966 +    val dead_pre_map_cong0' =
  3.1967 +      @{thm box_equals[OF _ o_apply[symmetric] id_apply[symmetric]]} RS dead_pre_map_cong0 RS ext;
  3.1968 +    val dead_pre_rel_map = rel_map_of_bnf dead_pre_bnf;
  3.1969 +
  3.1970 +    val ctor_alt_thm = eval_VLeaf RS (@{thm eq_comp_compI} OF [eval_sctr,
  3.1971 +      trans OF [dead_pre_map_comp0 RS sym, trans OF [dead_pre_map_cong0', dead_pre_map_id0]]]);
  3.1972 +
  3.1973 +    val cong_ctor_intro = mk_cong_rho ctor_alt_thm
  3.1974 +      |> unfold_thms lthy [o_apply]
  3.1975 +      |> (fn thm => sctr_transfer RS rel_funD RS thm)
  3.1976 +      |> unfold_thms lthy (id_apply :: dead_pre_rel_map @ #rel_injects ssig_fp_bnf_sugar);
  3.1977 +  in
  3.1978 +    ({cong_def = cong_def, cong_locale = cong_locale, cong_base = cong_base, cong_refl = cong_refl,
  3.1979 +      cong_sym = cong_sym, cong_trans = cong_trans, dtor_coinduct = dtor_coinduct,
  3.1980 +      cong_alg_intros = [cong_ctor_intro]}, lthy)
  3.1981 +  end;
  3.1982 +
  3.1983 +fun update_cong_alg_intros ctxt cong_def cong_locale old_cong_def old_cong_locale emb =
  3.1984 +  let
  3.1985 +    fun instance_of_gen thm = fold_thms ctxt [cong_def] (thm OF [cong_locale]);
  3.1986 +    fun instance_of_old_gen thm = fold_thms ctxt [old_cong_def] (thm OF [old_cong_locale]);
  3.1987 +
  3.1988 +    val emb_idem = @{thm ord_le_eq_trans} OF [emb, instance_of_gen @{thm cong.gen_cong_idem}];
  3.1989 +    fun mk_rel_mono bnf = instance_of_old_gen @{thm cong.leq_gen_cong} RS rel_mono_of_bnf bnf RS
  3.1990 +      @{thm predicate2D};
  3.1991 +    fun mk_intro bnf thm = mk_rel_mono bnf RS (@{thm predicate2D} OF [emb_idem, thm]);
  3.1992 +  in
  3.1993 +    map2 mk_intro
  3.1994 +  end
  3.1995 +
  3.1996 +fun derive_cong_step fp_b version fpT dead_ssig_bnf dead_pre_bnf eval eval_thm eval_core_transfer
  3.1997 +    old_dtor_coinduct_info algrho_def k_as_ssig_transfer Retr equivp_Retr Retr_coinduct
  3.1998 +    eval_embL embL_transfer old_all_dead_k_bnfs lthy =
  3.1999 +  let
  3.2000 +    val old_cong_def = #cong_def old_dtor_coinduct_info;
  3.2001 +    val old_cong_locale = #cong_locale old_dtor_coinduct_info;
  3.2002 +    val old_cong_alg_intros = #cong_alg_intros old_dtor_coinduct_info;
  3.2003 +
  3.2004 +    val (cong_def, cong_locale, cong_base, cong_refl, cong_sym, cong_trans, dtor_coinduct,
  3.2005 +         mk_cong_rho, lthy) =
  3.2006 +      derive_cong_general fp_b version fpT dead_ssig_bnf dead_pre_bnf eval Retr equivp_Retr
  3.2007 +        Retr_coinduct eval_thm eval_core_transfer lthy;
  3.2008 +
  3.2009 +    val cong_alg_intro =
  3.2010 +      k_as_ssig_transfer RS rel_funD RS mk_cong_rho (algrho_def RS meta_eq_to_obj_eq);
  3.2011 +
  3.2012 +    val gen_cong_emb =
  3.2013 +      (@{thm gen_cong_emb} OF [old_cong_locale, cong_locale, eval_embL, embL_transfer])
  3.2014 +      |> fold_thms lthy [old_cong_def, cong_def];
  3.2015 +
  3.2016 +    val cong_alg_intros = update_cong_alg_intros lthy cong_def cong_locale old_cong_def
  3.2017 +      old_cong_locale gen_cong_emb old_all_dead_k_bnfs old_cong_alg_intros;
  3.2018 +  in
  3.2019 +    ({cong_def = cong_def, cong_locale = cong_locale, cong_base = cong_base, cong_refl = cong_refl,
  3.2020 +      cong_sym = cong_sym, cong_trans = cong_trans, dtor_coinduct = dtor_coinduct,
  3.2021 +      cong_alg_intros = cong_alg_intro :: cong_alg_intros}, lthy)
  3.2022 +  end;
  3.2023 +
  3.2024 +fun derive_cong_merge fp_b version fpT old1_friend_names old2_friend_names dead_ssig_bnf
  3.2025 +    dead_pre_bnf eval eval_thm eval_core_transfer old1_dtor_coinduct_info old2_dtor_coinduct_info
  3.2026 +    Retr equivp_Retr Retr_coinduct eval_embLL embLL_transfer eval_embLR embLR_transfer
  3.2027 +    old1_all_dead_k_bnfs old2_all_dead_k_bnfs lthy =
  3.2028 +  let
  3.2029 +    val old1_cong_def = #cong_def old1_dtor_coinduct_info;
  3.2030 +    val old1_cong_locale = #cong_locale old1_dtor_coinduct_info;
  3.2031 +    val old1_cong_alg_intros = #cong_alg_intros old1_dtor_coinduct_info;
  3.2032 +    val old2_cong_def = #cong_def old2_dtor_coinduct_info;
  3.2033 +    val old2_cong_locale = #cong_locale old2_dtor_coinduct_info;
  3.2034 +    val old2_cong_alg_intros = #cong_alg_intros old2_dtor_coinduct_info;
  3.2035 +
  3.2036 +    val (cong_def, cong_locale, cong_base, cong_refl, cong_sym, cong_trans, dtor_coinduct, _,
  3.2037 +         lthy) =
  3.2038 +      derive_cong_general fp_b version fpT dead_ssig_bnf dead_pre_bnf eval Retr equivp_Retr
  3.2039 +        Retr_coinduct eval_thm eval_core_transfer lthy;
  3.2040 +
  3.2041 +    val emb1 = (@{thm gen_cong_emb} OF [old1_cong_locale, cong_locale, eval_embLL, embLL_transfer])
  3.2042 +      |> fold_thms lthy [old1_cong_def, cong_def];
  3.2043 +    val emb2 = (@{thm gen_cong_emb} OF [old2_cong_locale, cong_locale, eval_embLR, embLR_transfer])
  3.2044 +      |> fold_thms lthy [old2_cong_def, cong_def];
  3.2045 +
  3.2046 +    val cong_alg_intros1 = update_cong_alg_intros lthy cong_def cong_locale old1_cong_def
  3.2047 +      old1_cong_locale emb1 old1_all_dead_k_bnfs old1_cong_alg_intros;
  3.2048 +    val cong_alg_intros2 = update_cong_alg_intros lthy cong_def cong_locale old2_cong_def
  3.2049 +      old2_cong_locale emb2 old2_all_dead_k_bnfs old2_cong_alg_intros;
  3.2050 +
  3.2051 +    val (cong_algrho_intros1, cong_ctor_intro1) = split_last cong_alg_intros1;
  3.2052 +    val (cong_algrho_intros2, _) = split_last cong_alg_intros2;
  3.2053 +    val (old1_all_rho_k_bnfs, old1_Sig_bnf) = split_last old1_all_dead_k_bnfs;
  3.2054 +    val (old2_all_rho_k_bnfs, _) = split_last old2_all_dead_k_bnfs;
  3.2055 +
  3.2056 +    val (friend_names, (cong_algrho_intros, all_rho_k_bnfs)) =
  3.2057 +      merge_lists (op = o apply2 fst)
  3.2058 +        (old1_friend_names ~~ (cong_algrho_intros1 ~~ old1_all_rho_k_bnfs))
  3.2059 +        (old2_friend_names ~~ (cong_algrho_intros2 ~~ old2_all_rho_k_bnfs))
  3.2060 +      |> split_list ||> split_list;
  3.2061 +  in
  3.2062 +    (({cong_def = cong_def, cong_locale = cong_locale, cong_base = cong_base, cong_refl = cong_refl,
  3.2063 +       cong_sym = cong_sym, cong_trans = cong_trans, dtor_coinduct = dtor_coinduct,
  3.2064 +       cong_alg_intros = cong_algrho_intros @ [cong_ctor_intro1]}, all_rho_k_bnfs @ [old1_Sig_bnf],
  3.2065 +       friend_names), lthy)
  3.2066 +  end;
  3.2067 +
  3.2068 +fun derive_corecUU_base fpT_name lthy =
  3.2069 +  let
  3.2070 +    val fp_sugar as {T = Type (_, fpT_args0), pre_bnf, fp_bnf, fp_res, ...} =
  3.2071 +      checked_fp_sugar_of lthy fpT_name;
  3.2072 +    val num_fp_tyargs = length fpT_args0;
  3.2073 +    val fp_alives = liveness_of_fp_bnf num_fp_tyargs fp_bnf;
  3.2074 +
  3.2075 +    val (((Es, Fs0), [Y, Z]), names_lthy) = lthy
  3.2076 +      |> mk_TFrees num_fp_tyargs
  3.2077 +      ||>> mk_TFrees num_fp_tyargs
  3.2078 +      ||>> mk_TFrees 2;
  3.2079 +    val Fs = @{map 3} (fn alive => fn E => fn F => if alive then F else E) fp_alives Es Fs0;
  3.2080 +
  3.2081 +    val As = Es @ [Y];
  3.2082 +    val Bs = Es @ [Z];
  3.2083 +
  3.2084 +    val live_EsFs = filter (op <>) (Es ~~ Fs);
  3.2085 +    val live_AsBs = live_EsFs @ [(Y, Z)];
  3.2086 +    val fTs = map (op -->) live_EsFs;
  3.2087 +    val RTs = map (uncurry mk_pred2T) live_EsFs;
  3.2088 +    val live = length live_EsFs;
  3.2089 +
  3.2090 +    val ((((((x, fs), f), g), Rs), R), names_lthy) = names_lthy
  3.2091 +      |> yield_singleton (mk_Frees "x") Y
  3.2092 +      ||>> mk_Frees "f" fTs
  3.2093 +      ||>> yield_singleton (mk_Frees "f") (Y --> Z)
  3.2094 +      ||>> yield_singleton (mk_Frees "g") (Y --> Z)
  3.2095 +      ||>> mk_Frees "R" RTs
  3.2096 +      ||>> yield_singleton (mk_Frees "R") (mk_pred2T Y Z);
  3.2097 +
  3.2098 +    val ctor = mk_ctor Es (the_single (#ctors fp_res));
  3.2099 +    val dtor = mk_dtor Es (the_single (#dtors fp_res));
  3.2100 +
  3.2101 +    val fpT = Type (fpT_name, Es);
  3.2102 +    val preT = pre_type_of_ctor Y ctor;
  3.2103 +
  3.2104 +    val ((fp_b, version), lthy) = lthy |> get_name_next_version_of fpT_name;
  3.2105 +
  3.2106 +    val ((sig_fp_sugar, ssig_fp_sugar), lthy) = lthy
  3.2107 +      |> define_sig_type fp_b version fp_alives Es Y preT
  3.2108 +      ||>> define_ssig_type fp_b version fp_alives Es Y fpT;
  3.2109 +
  3.2110 +    val sig_bnf = #fp_bnf sig_fp_sugar;
  3.2111 +    val ssig_bnf = #fp_bnf ssig_fp_sugar;
  3.2112 +
  3.2113 +    val (((dead_pre_bnf, dead_sig_bnf), dead_ssig_bnf), lthy) = lthy
  3.2114 +      |> bnf_kill_all_but 1 pre_bnf
  3.2115 +      ||>> bnf_kill_all_but 1 sig_bnf
  3.2116 +      ||>> bnf_kill_all_but 1 ssig_bnf;
  3.2117 +
  3.2118 +    val sig_fp_ctr_sugar = #fp_ctr_sugar sig_fp_sugar;
  3.2119 +    val ssig_fp_ctr_sugar = #fp_ctr_sugar ssig_fp_sugar;
  3.2120 +
  3.2121 +    val sig_fp_bnf_sugar = #fp_bnf_sugar sig_fp_sugar;
  3.2122 +    val ssig_fp_bnf_sugar = #fp_bnf_sugar ssig_fp_sugar;
  3.2123 +    val ssig_fp_induct_sugar = #fp_co_induct_sugar ssig_fp_sugar;
  3.2124 +
  3.2125 +    val sig_ctr_sugar = #ctr_sugar sig_fp_ctr_sugar;
  3.2126 +    val ssig_ctr_sugar = #ctr_sugar ssig_fp_ctr_sugar;
  3.2127 +
  3.2128 +    val sig_T_name = fst (dest_Type (#T sig_fp_sugar));
  3.2129 +    val ssig_T_name = fst (dest_Type (#T ssig_fp_sugar));
  3.2130 +
  3.2131 +    val sig_T = Type (sig_T_name, As);
  3.2132 +    val ssig_T = Type (ssig_T_name, As);
  3.2133 +
  3.2134 +    val pre_map = mk_mapN lthy live_AsBs preT pre_bnf;
  3.2135 +    val pre_rel = mk_relN lthy live_AsBs preT pre_bnf;
  3.2136 +    val dead_pre_map = mk_map1 lthy Y Z preT dead_pre_bnf;
  3.2137 +    val fp_rel = mk_relN lthy live_EsFs fpT fp_bnf;
  3.2138 +    val dtor_unfold = mk_co_rec (Proof_Context.theory_of lthy) Greatest_FP [Z] fpT
  3.2139 +      (the_single (#xtor_un_folds fp_res));
  3.2140 +    val Sig = mk_ctr As (the_single (#ctrs sig_ctr_sugar));
  3.2141 +    val unsig = mk_disc_or_sel As (the_single (the_single (#selss sig_ctr_sugar)));
  3.2142 +    val sig_rel = mk_relN lthy live_AsBs sig_T sig_bnf;
  3.2143 +    val dead_sig_map = mk_map 1 As Bs (map_of_bnf dead_sig_bnf);
  3.2144 +    val [Oper, VLeaf, CLeaf] = map (mk_ctr As) (#ctrs ssig_ctr_sugar);
  3.2145 +    val ssig_map = mk_mapN lthy live_AsBs ssig_T ssig_bnf;
  3.2146 +    val ssig_rel = mk_relN lthy live_AsBs ssig_T ssig_bnf;
  3.2147 +    val dead_ssig_map = mk_map 1 As Bs (map_of_bnf dead_ssig_bnf);
  3.2148 +    val dead_ssig_rel = mk_rel 1 As Bs (rel_of_bnf dead_ssig_bnf);
  3.2149 +
  3.2150 +    val ((Lam, Lam_def), lthy) = lthy
  3.2151 +      |> define_Lam_base fp_b version Y Z preT ssig_T dead_pre_map Sig unsig dead_sig_map Oper
  3.2152 +        VLeaf;
  3.2153 +
  3.2154 +    val proto_sctr = Sig;
  3.2155 +
  3.2156 +    val pre_map_transfer = map_transfer_of_bnf pre_bnf;
  3.2157 +    val pre_rel_def = rel_def_of_bnf pre_bnf;
  3.2158 +    val dead_pre_map_id = map_id_of_bnf dead_pre_bnf;
  3.2159 +    val dead_pre_map_comp = map_comp_of_bnf dead_pre_bnf;
  3.2160 +    val fp_rel_eq = rel_eq_of_bnf fp_bnf;
  3.2161 +    val [ctor_dtor] = #ctor_dtors fp_res;
  3.2162 +    val [dtor_ctor] = #dtor_ctors fp_res;
  3.2163 +    val [dtor_inject] = #dtor_injects fp_res;
  3.2164 +    val [dtor_unfold_thm] = #xtor_un_fold_thms fp_res;
  3.2165 +    val [dtor_unfold_unique] = #xtor_un_fold_uniques fp_res;
  3.2166 +    val [dtor_unfold_transfer] = #xtor_un_fold_transfers fp_res;
  3.2167 +    val [dtor_rel_thm] = #xtor_rels fp_res;
  3.2168 +    val unsig_thm = the_single (the_single (#sel_thmss sig_ctr_sugar));
  3.2169 +    val [sig_map_thm] = #map_thms sig_fp_bnf_sugar;
  3.2170 +    val [Oper_map_thm, VLeaf_map_thm, CLeaf_map_thm] = #map_thms ssig_fp_bnf_sugar;
  3.2171 +    val sig_map_transfer = map_transfer_of_bnf sig_bnf;
  3.2172 +    val ssig_map_thms = #map_thms ssig_fp_bnf_sugar;
  3.2173 +    val ssig_map_transfer = map_transfer_of_bnf ssig_bnf;
  3.2174 +    val ssig_induct = the_single (#co_inducts ssig_fp_induct_sugar);
  3.2175 +
  3.2176 +    val dtor_transfer = derive_dtor_transfer lthy live_EsFs Y Z pre_rel fp_rel Rs dtor dtor_rel_thm;
  3.2177 +    val preT_rel_eqs = map rel_eq_of_bnf (map_filter (bnf_of lthy) (add_type_namesT preT []));
  3.2178 +
  3.2179 +    val Sig_transfer = derive_sig_transfer I lthy live_AsBs pre_rel sig_rel Rs R Sig pre_rel_def
  3.2180 +      preT_rel_eqs (the_single (#ctr_transfers sig_fp_ctr_sugar));
  3.2181 +    val proto_sctr_transfer = Sig_transfer;
  3.2182 +    val unsig_transfer = derive_sig_transfer swap lthy live_AsBs pre_rel sig_rel Rs R unsig
  3.2183 +      pre_rel_def preT_rel_eqs (the_single (#sel_transfers sig_fp_ctr_sugar));
  3.2184 +    val Lam_transfer = derive_Lam_or_eval_core_transfer lthy live_AsBs Y Z preT ssig_T Rs R pre_rel
  3.2185 +      sig_rel ssig_rel Lam Lam_def []
  3.2186 +      [pre_map_transfer, sig_map_transfer, Sig_transfer, unsig_transfer];
  3.2187 +
  3.2188 +    val ((((((((flat, _, flat_simps), flat_transfer),
  3.2189 +            ((eval_core, _, eval_core_simps), eval_core_transfer)), (eval, eval_def)),
  3.2190 +          (cutSsig, cutSsig_def)), (algLam, algLam_def)), (corecU, corecU_def)), lthy) = lthy
  3.2191 +      |> define_flat_etc fp_b version live_AsBs Y Z preT fpT sig_T ssig_T Oper VLeaf CLeaf pre_rel
  3.2192 +        dead_pre_map dtor dtor_unfold dead_sig_map ssig_rel dead_ssig_map Lam Rs R pre_map_transfer
  3.2193 +        [fp_rel_eq] sig_map_transfer ssig_map_transfer Lam_transfer dtor_transfer;
  3.2194 +
  3.2195 +    val (Sig_pointful_natural, flat_pointful_natural, _, Lam_pointful_natural, _,
  3.2196 +         eval_core_pointful_natural, eval_thm, eval_flat, eval_simps as [eval_Oper, eval_VLeaf, _],
  3.2197 +         corecU_ctor, corecU_unique, dtor_algLam) =
  3.2198 +      derive_Sig_natural_etc lthy live live_AsBs Y Z preT fpT fpT sig_T ssig_T pre_map dead_pre_map
  3.2199 +        ctor dtor Sig dead_sig_map Oper VLeaf CLeaf ssig_map dead_ssig_map Lam flat eval_core eval
  3.2200 +        cutSsig algLam corecU x fs f g ctor_dtor dtor_inject dtor_unfold_thm dtor_unfold_unique
  3.2201 +        sig_map_thm ssig_induct ssig_map_thms Oper_map_thm VLeaf_map_thm CLeaf_map_thm Lam_transfer
  3.2202 +        flat_simps flat_transfer eval_core_simps eval_core_transfer eval_def cutSsig_def algLam_def
  3.2203 +        corecU_def pre_bnf pre_bnf dead_pre_bnf fp_bnf sig_bnf ssig_bnf dead_ssig_bnf;
  3.2204 +
  3.2205 +    val proto_sctr_pointful_natural = Sig_pointful_natural;
  3.2206 +
  3.2207 +    val algLam_thm = derive_algLam_base lthy Y Z preT fpT dead_pre_map ctor dtor algLam proto_sctr
  3.2208 +      dead_pre_map_id dead_pre_map_comp ctor_dtor dtor_ctor dtor_unfold_unique unsig_thm
  3.2209 +      Sig_pointful_natural ssig_map_thms Lam_def flat_simps eval_core_simps eval_thm algLam_def;
  3.2210 +
  3.2211 +    val (((corecUU, _), corecUU_thm, corecUU_unique, corecUU_transfer, eval_sctr, sctr_transfer,
  3.2212 +          sctr_pointful_natural), lthy) = lthy
  3.2213 +      |> define_corecUU_etc fp_b version live_AsBs Y Z preT fpT ssig_T pre_map dead_pre_map pre_rel
  3.2214 +        fp_rel ctor Oper ssig_map dead_ssig_map ssig_rel proto_sctr flat eval_core eval corecU fs f
  3.2215 +        g Rs R pre_map_transfer [] dtor_unfold_transfer dtor_transfer ssig_map_transfer
  3.2216 +        proto_sctr_transfer proto_sctr_pointful_natural flat_transfer flat_pointful_natural
  3.2217 +        eval_core_transfer eval_core_pointful_natural eval_thm eval_flat eval_Oper algLam_thm
  3.2218 +        cutSsig_def corecU_def corecU_ctor corecU_unique pre_bnf dead_pre_bnf fp_res ssig_fp_sugar;
  3.2219 +
  3.2220 +    val (Retr, equivp_Retr, Retr_coinduct) = lthy
  3.2221 +      |> derive_Retr fp_sugar fpT dead_pre_bnf ctor dtor names_lthy;
  3.2222 +
  3.2223 +    val (dtor_coinduct_info, lthy) = lthy
  3.2224 +      |> derive_cong_base fp_b version fpT dead_ssig_bnf ssig_fp_bnf_sugar dead_pre_bnf eval
  3.2225 +      eval_thm eval_core_transfer eval_VLeaf eval_sctr sctr_transfer Retr equivp_Retr Retr_coinduct;
  3.2226 +
  3.2227 +    val buffer =
  3.2228 +      {Oper = Oper, VLeaf = VLeaf, CLeaf = CLeaf, ctr_wrapper = Sig, friends = Symtab.empty};
  3.2229 +
  3.2230 +    val notes =
  3.2231 +      [(corecUU_transferN, [corecUU_transfer])] @
  3.2232 +      (if Config.get lthy bnf_internals then
  3.2233 +         [(algLamN, [algLam_thm]),
  3.2234 +          (cong_alg_introsN, #cong_alg_intros dtor_coinduct_info),
  3.2235 +          (cong_localeN, [#cong_locale dtor_coinduct_info]),
  3.2236 +          (corecU_ctorN, [corecU_ctor]),
  3.2237 +          (corecU_uniqueN, [corecU_unique]),
  3.2238 +          (corecUUN, [corecUU_thm]),
  3.2239 +          (corecUU_uniqueN, [corecUU_unique]),
  3.2240 +          (dtor_algLamN, [dtor_algLam]),
  3.2241 +          (dtor_coinductN, [#dtor_coinduct dtor_coinduct_info]),
  3.2242 +          (dtor_transferN, [dtor_transfer]),
  3.2243 +          (equivp_RetrN, [equivp_Retr]),
  3.2244 +          (evalN, [eval_thm]),
  3.2245 +          (eval_core_pointful_naturalN, [eval_core_pointful_natural]),
  3.2246 +          (eval_core_transferN, [eval_core_transfer]),
  3.2247 +          (eval_flatN, [eval_flat]),
  3.2248 +          (eval_simpsN, eval_simps),
  3.2249 +          (flat_pointful_naturalN, [flat_pointful_natural]),
  3.2250 +          (flat_transferN, [flat_transfer]),
  3.2251 +          (Lam_pointful_naturalN, [Lam_pointful_natural]),
  3.2252 +          (Lam_transferN, [Lam_transfer]),
  3.2253 +          (proto_sctr_pointful_naturalN, [proto_sctr_pointful_natural]),
  3.2254 +          (proto_sctr_transferN, [proto_sctr_transfer]),
  3.2255 +          (Retr_coinductN, [Retr_coinduct]),
  3.2256 +          (sctr_pointful_naturalN, [sctr_pointful_natural]),
  3.2257 +          (sctr_transferN, [sctr_transfer]),
  3.2258 +          (Sig_pointful_naturalN, [Sig_pointful_natural])]
  3.2259 +        else
  3.2260 +          [])
  3.2261 +      |> map (fn (thmN, thms) =>
  3.2262 +        ((mk_version_fp_binding true lthy version fp_b thmN, []), [(thms, [])]));
  3.2263 +  in
  3.2264 +    ({fp_b = fp_b, version = version, fpT = fpT, Y = Y, Z = Z, friend_names = [],
  3.2265 +      sig_fp_sugars = [sig_fp_sugar], ssig_fp_sugar = ssig_fp_sugar, Lam = Lam,
  3.2266 +      proto_sctr = proto_sctr, flat = flat, eval_core = eval_core, eval = eval, algLam = algLam,
  3.2267 +      corecUU = corecUU, dtor_transfer = dtor_transfer, Lam_transfer = Lam_transfer,
  3.2268 +      Lam_pointful_natural = Lam_pointful_natural, proto_sctr_transfer = proto_sctr_transfer,
  3.2269 +      flat_simps = flat_simps, eval_core_simps = eval_core_simps, eval_thm = eval_thm,
  3.2270 +      eval_simps = eval_simps, all_algLam_algs = [algLam_thm], algLam_thm = algLam_thm,
  3.2271 +      dtor_algLam = dtor_algLam, corecUU_thm = corecUU_thm, corecUU_unique = corecUU_unique,
  3.2272 +      corecUU_transfer = corecUU_transfer, buffer = buffer, all_dead_k_bnfs = [dead_pre_bnf],
  3.2273 +      Retr = Retr, equivp_Retr = equivp_Retr, Retr_coinduct = Retr_coinduct,
  3.2274 +      dtor_coinduct_info = dtor_coinduct_info}
  3.2275 +     |> morph_corec_info (Local_Theory.target_morphism lthy),
  3.2276 +     lthy |> Local_Theory.notes notes |> snd)
  3.2277 +  end;
  3.2278 +
  3.2279 +fun derive_corecUU_step (fpT as Type (fpT_name, res_Ds))
  3.2280 +    ({friend_names = old_friend_names, sig_fp_sugars = old_sig_fp_sugars as old_sig_fp_sugar :: _,
  3.2281 +      ssig_fp_sugar = old_ssig_fp_sugar, Lam = old_Lam0, proto_sctr = old_proto_sctr0,
  3.2282 +      flat = old_flat0, eval_core = old_eval_core0, eval = old_eval0, algLam = old_algLam0,
  3.2283 +      dtor_transfer, Lam_transfer = old_Lam_transfer,
  3.2284 +      Lam_pointful_natural = old_Lam_pointful_natural,
  3.2285 +      proto_sctr_transfer = old_proto_sctr_transfer, flat_simps = old_flat_simps,
  3.2286 +      eval_core_simps = old_eval_core_simps, eval_thm = old_eval_thm,
  3.2287 +      all_algLam_algs = old_all_algLam_algs, algLam_thm = old_algLam_thm,
  3.2288 +      dtor_algLam = old_dtor_algLam, buffer = old_buffer, all_dead_k_bnfs = old_all_dead_k_bnfs,
  3.2289 +      Retr = old_Retr0, equivp_Retr, Retr_coinduct, dtor_coinduct_info = old_dtor_coinduct_info,
  3.2290 +      ...} : corec_info)
  3.2291 +    friend_name friend_T fp_b version Y Z k_T dead_k_bnf sig_fp_sugar ssig_fp_sugar rho rho_transfer
  3.2292 +    lthy =
  3.2293 +  let
  3.2294 +    val {pre_bnf = live_pre_bnf, fp_bnf = live_fp_bnf, fp_res, ...} =
  3.2295 +      checked_fp_sugar_of lthy fpT_name;
  3.2296 +
  3.2297 +    val names_lthy = lthy
  3.2298 +      |> fold Variable.declare_typ [Y, Z];
  3.2299 +
  3.2300 +    (* FIXME *)
  3.2301 +    val live_EsFs = [];
  3.2302 +    val live_AsBs = live_EsFs @ [(Y, Z)];
  3.2303 +    val live = length live_EsFs;
  3.2304 +
  3.2305 +    val ((((x, f), g), R), _) = names_lthy
  3.2306 +      |> yield_singleton (mk_Frees "x") Y
  3.2307 +      ||>> yield_singleton (mk_Frees "f") (Y --> Z)
  3.2308 +      ||>> yield_singleton (mk_Frees "g") (Y --> Z)
  3.2309 +      ||>> yield_singleton (mk_Frees "R") (mk_pred2T Y Z);
  3.2310 +
  3.2311 +    (* FIXME *)
  3.2312 +    val fs = [];
  3.2313 +    val Rs = [];
  3.2314 +
  3.2315 +    val ctor = mk_ctor res_Ds (the_single (#ctors fp_res));
  3.2316 +    val dtor = mk_dtor res_Ds (the_single (#dtors fp_res));
  3.2317 +
  3.2318 +    val friend_names = friend_name :: old_friend_names;
  3.2319 +
  3.2320 +    val old_sig_bnf = #fp_bnf old_sig_fp_sugar;
  3.2321 +    val old_ssig_bnf = #fp_bnf old_ssig_fp_sugar;
  3.2322 +    val sig_bnf = #fp_bnf sig_fp_sugar;
  3.2323 +    val ssig_bnf = #fp_bnf ssig_fp_sugar;
  3.2324 +
  3.2325 +    val ((((((dead_pre_bnf, dead_fp_bnf), dead_old_sig_bnf), dead_old_ssig_bnf), dead_sig_bnf),
  3.2326 +          dead_ssig_bnf), lthy) = lthy
  3.2327 +      |> bnf_kill_all_but 1 live_pre_bnf
  3.2328 +      ||>> bnf_kill_all_but 0 live_fp_bnf
  3.2329 +      ||>> bnf_kill_all_but 1 old_sig_bnf
  3.2330 +      ||>> bnf_kill_all_but 1 old_ssig_bnf
  3.2331 +      ||>> bnf_kill_all_but 1 sig_bnf
  3.2332 +      ||>> bnf_kill_all_but 1 ssig_bnf;
  3.2333 +
  3.2334 +    (* FIXME *)
  3.2335 +    val pre_bnf = dead_pre_bnf;
  3.2336 +    val fp_bnf = dead_fp_bnf;
  3.2337 +
  3.2338 +    val old_ssig_fp_ctr_sugar = #fp_ctr_sugar old_ssig_fp_sugar;
  3.2339 +    val sig_fp_ctr_sugar = #fp_ctr_sugar sig_fp_sugar;
  3.2340 +    val ssig_fp_ctr_sugar = #fp_ctr_sugar ssig_fp_sugar;
  3.2341 +
  3.2342 +    val sig_fp_bnf_sugar = #fp_bnf_sugar sig_fp_sugar;
  3.2343 +    val old_ssig_fp_bnf_sugar = #fp_bnf_sugar old_ssig_fp_sugar;
  3.2344 +    val ssig_fp_bnf_sugar = #fp_bnf_sugar ssig_fp_sugar;
  3.2345 +    val old_ssig_fp_induct_sugar = #fp_co_induct_sugar old_ssig_fp_sugar;
  3.2346 +    val ssig_fp_induct_sugar = #fp_co_induct_sugar ssig_fp_sugar;
  3.2347 +
  3.2348 +    val old_ssig_ctr_sugar = #ctr_sugar old_ssig_fp_ctr_sugar;
  3.2349 +    val sig_ctr_sugar = #ctr_sugar sig_fp_ctr_sugar;
  3.2350 +    val ssig_ctr_sugar = #ctr_sugar ssig_fp_ctr_sugar;
  3.2351 +
  3.2352 +    val old_sig_T_name = fst (dest_Type (#T old_sig_fp_sugar));
  3.2353 +    val old_ssig_T_name = fst (dest_Type (#T old_ssig_fp_sugar));
  3.2354 +    val sig_T_name = fst (dest_Type (#T sig_fp_sugar));
  3.2355 +    val ssig_T_name = fst (dest_Type (#T ssig_fp_sugar));
  3.2356 +
  3.2357 +    val res_As = res_Ds @ [Y];
  3.2358 +    val res_Bs = res_Ds @ [Z];
  3.2359 +    val preT = pre_type_of_ctor Y ctor;
  3.2360 +    val YpreT = HOLogic.mk_prodT (Y, preT);
  3.2361 +    val old_sig_T = Type (old_sig_T_name, res_As);
  3.2362 +    val old_ssig_T = Type (old_ssig_T_name, res_As);
  3.2363 +    val sig_T = Type (sig_T_name, res_As);
  3.2364 +    val ssig_T = Type (ssig_T_name, res_As);
  3.2365 +    val old_Lam_domT = Tsubst Y YpreT old_sig_T;
  3.2366 +    val old_eval_core_domT = Tsubst Y YpreT old_ssig_T;
  3.2367 +
  3.2368 +    val pre_map = mk_mapN lthy live_AsBs preT pre_bnf;
  3.2369 +    val pre_rel = mk_relN lthy live_AsBs preT pre_bnf;
  3.2370 +    val dead_pre_map = mk_map1 lthy Y Z preT dead_pre_bnf;
  3.2371 +    val dead_pre_rel = mk_rel1 lthy Y Z preT dead_pre_bnf;
  3.2372 +    val fp_rel = mk_relN lthy live_EsFs fpT fp_bnf;
  3.2373 +    val dtor_unfold = mk_co_rec (Proof_Context.theory_of lthy) Greatest_FP [Z] fpT
  3.2374 +      (the_single (#xtor_un_folds fp_res));
  3.2375 +    val dead_k_map = mk_map1 lthy Y Z k_T dead_k_bnf;
  3.2376 +    val Sig = mk_ctr res_As (the_single (#ctrs sig_ctr_sugar));
  3.2377 +    val unsig = mk_disc_or_sel res_As (the_single (the_single (#selss sig_ctr_sugar)));
  3.2378 +    val sig_rel = mk_relN lthy live_AsBs sig_T sig_bnf;
  3.2379 +    val dead_old_sig_map = mk_map 1 res_As res_Bs (map_of_bnf dead_old_sig_bnf);
  3.2380 +    val dead_sig_map = mk_map 1 res_As res_Bs (map_of_bnf dead_sig_bnf);
  3.2381 +    val dead_sig_rel = mk_rel 1 res_As res_Bs (rel_of_bnf dead_sig_bnf);
  3.2382 +    val [old_Oper, old_VLeaf, old_CLeaf] = map (mk_ctr res_As) (#ctrs old_ssig_ctr_sugar);
  3.2383 +    val [Oper, VLeaf, CLeaf] = map (mk_ctr res_As) (#ctrs ssig_ctr_sugar);
  3.2384 +    val dead_old_ssig_map = mk_map 1 res_As res_Bs (map_of_bnf dead_old_ssig_bnf);
  3.2385 +    val ssig_map = mk_mapN lthy live_AsBs ssig_T ssig_bnf;
  3.2386 +    val ssig_rel = mk_relN lthy live_AsBs ssig_T ssig_bnf;
  3.2387 +    val dead_ssig_map = mk_map 1 res_As res_Bs (map_of_bnf dead_ssig_bnf);
  3.2388 +    val dead_ssig_rel = mk_rel 1 res_As res_Bs (rel_of_bnf dead_ssig_bnf);
  3.2389 +    val old_Lam = enforce_type lthy domain_type old_Lam_domT old_Lam0;
  3.2390 +    val old_proto_sctr = enforce_type lthy domain_type preT old_proto_sctr0;
  3.2391 +    val old_flat = enforce_type lthy range_type old_ssig_T old_flat0;
  3.2392 +    val old_eval_core = enforce_type lthy domain_type old_eval_core_domT old_eval_core0;
  3.2393 +    val old_eval = enforce_type lthy range_type fpT old_eval0;
  3.2394 +    val old_algLam = enforce_type lthy range_type fpT old_algLam0;
  3.2395 +
  3.2396 +    val ((embL, embL_def, embL_simps), lthy) = lthy
  3.2397 +      |> define_embL embLN fp_b version Y Z fpT old_sig_T old_ssig_T k_T ssig_T Inl_const
  3.2398 +        dead_old_sig_map Sig old_Oper old_VLeaf old_CLeaf Oper VLeaf CLeaf;
  3.2399 +
  3.2400 +    val ((Lam, Lam_def), lthy) = lthy
  3.2401 +      |> define_Lam_step fp_b version Y Z preT old_ssig_T ssig_T dead_pre_map unsig rho embL
  3.2402 +        old_Lam;
  3.2403 +
  3.2404 +    val ((proto_sctr, proto_sctr_def), lthy) = lthy
  3.2405 +      |> define_proto_sctr_step_or_merge fp_b version old_sig_T k_T Sig old_proto_sctr;
  3.2406 +
  3.2407 +    val pre_map_comp = map_comp_of_bnf pre_bnf;
  3.2408 +    val pre_map_transfer = map_transfer_of_bnf pre_bnf;
  3.2409 +    val dead_pre_map_id = map_id_of_bnf dead_pre_bnf;
  3.2410 +    val dead_pre_map_comp0 = map_comp0_of_bnf dead_pre_bnf;
  3.2411 +    val dead_pre_map_comp = map_comp_of_bnf dead_pre_bnf;
  3.2412 +    val fp_map_id = map_id_of_bnf fp_bnf;
  3.2413 +    val fp_rel_eq = rel_eq_of_bnf fp_bnf;
  3.2414 +    val [ctor_dtor] = #ctor_dtors fp_res;
  3.2415 +    val [dtor_inject] = #dtor_injects fp_res;
  3.2416 +    val [dtor_unfold_thm] = #xtor_un_fold_thms fp_res;
  3.2417 +    val [dtor_unfold_unique] = #xtor_un_fold_uniques fp_res;
  3.2418 +    val [dtor_unfold_transfer] = #xtor_un_fold_transfers fp_res;
  3.2419 +    val fp_k_T_rel_eqs =
  3.2420 +      map rel_eq_of_bnf (map_filter (bnf_of lthy) (fold add_type_namesT [fpT, k_T] []));
  3.2421 +    val unsig_thm = the_single (the_single (#sel_thmss sig_ctr_sugar));
  3.2422 +    val [sig_map_thm] = #map_thms sig_fp_bnf_sugar;
  3.2423 +    val old_sig_map_comp = map_comp_of_bnf old_sig_bnf;
  3.2424 +    val old_sig_map_cong = map_cong_of_bnf old_sig_bnf;
  3.2425 +    val old_ssig_map_thms = #map_thms old_ssig_fp_bnf_sugar;
  3.2426 +    val [Oper_map_thm, VLeaf_map_thm, CLeaf_map_thm] = #map_thms ssig_fp_bnf_sugar;
  3.2427 +    val old_sig_map_transfer = map_transfer_of_bnf old_sig_bnf;
  3.2428 +    val sig_map_comp = map_comp_of_bnf sig_bnf;
  3.2429 +    val sig_map_transfer = map_transfer_of_bnf sig_bnf;
  3.2430 +    val ssig_map_thms = #map_thms ssig_fp_bnf_sugar;
  3.2431 +    val ssig_map_transfer = map_transfer_of_bnf ssig_bnf;
  3.2432 +    val old_ssig_induct = the_single (#co_inducts old_ssig_fp_induct_sugar);
  3.2433 +    val ssig_induct = the_single (#co_inducts ssig_fp_induct_sugar);
  3.2434 +
  3.2435 +    val proto_sctr_transfer = derive_proto_sctr_transfer_step_or_merge lthy Y Z R dead_pre_rel
  3.2436 +      dead_sig_rel proto_sctr proto_sctr_def fp_k_T_rel_eqs [old_proto_sctr_transfer];
  3.2437 +    val embL_transfer = derive_transfer_by_transfer_prover lthy live_AsBs Rs R embL [embL_def]
  3.2438 +      fp_k_T_rel_eqs [old_sig_map_transfer];
  3.2439 +    val Lam_transfer = derive_Lam_or_eval_core_transfer lthy live_AsBs Y Z preT ssig_T Rs R pre_rel
  3.2440 +      sig_rel ssig_rel Lam Lam_def fp_k_T_rel_eqs
  3.2441 +      [pre_map_transfer, old_Lam_transfer, embL_transfer, rho_transfer];
  3.2442 +
  3.2443 +    val ((((((((flat, _, flat_simps), flat_transfer),
  3.2444 +            ((eval_core, _, eval_core_simps), eval_core_transfer)), (eval, eval_def)),
  3.2445 +          (cutSsig, cutSsig_def)), (algLam, algLam_def)), (corecU, corecU_def)), lthy) = lthy
  3.2446 +      |> define_flat_etc fp_b version live_AsBs Y Z preT fpT sig_T ssig_T Oper VLeaf CLeaf pre_rel
  3.2447 +        dead_pre_map dtor dtor_unfold dead_sig_map ssig_rel dead_ssig_map Lam Rs R pre_map_transfer
  3.2448 +        fp_k_T_rel_eqs sig_map_transfer ssig_map_transfer Lam_transfer dtor_transfer;
  3.2449 +
  3.2450 +    val (Sig_pointful_natural, flat_pointful_natural, Lam_natural_pointful, Lam_pointful_natural,
  3.2451 +         flat_VLeaf, eval_core_pointful_natural, eval_thm, eval_flat,
  3.2452 +         eval_simps as [eval_Oper, _, _], corecU_ctor, corecU_unique, dtor_algLam) =
  3.2453 +      derive_Sig_natural_etc lthy live live_AsBs Y Z preT fpT k_T sig_T ssig_T pre_map dead_pre_map
  3.2454 +        ctor dtor Sig dead_sig_map Oper VLeaf CLeaf ssig_map dead_ssig_map Lam flat eval_core eval
  3.2455 +        cutSsig algLam corecU x fs f g ctor_dtor dtor_inject dtor_unfold_thm dtor_unfold_unique
  3.2456 +        sig_map_thm ssig_induct ssig_map_thms Oper_map_thm VLeaf_map_thm CLeaf_map_thm Lam_transfer
  3.2457 +        flat_simps flat_transfer eval_core_simps eval_core_transfer eval_def cutSsig_def algLam_def
  3.2458 +        corecU_def live_pre_bnf pre_bnf dead_pre_bnf fp_bnf sig_bnf ssig_bnf dead_ssig_bnf;
  3.2459 +
  3.2460 +    val proto_sctr_natural = derive_natural_from_transfer_with_pre_type lthy live_AsBs Y Z preT
  3.2461 +      ssig_T pre_map ssig_map fs f proto_sctr proto_sctr_transfer [pre_bnf, sig_bnf] [];
  3.2462 +    val proto_sctr_pointful_natural = mk_pointful lthy proto_sctr_natural RS sym;
  3.2463 +
  3.2464 +    val (embL_pointful_natural, old_algLam_pointful, eval_embL, algLam_algLam) =
  3.2465 +      derive_embL_natural_etc lthy Inl_const old_ssig_bnf ssig_bnf Y Z preT fpT old_ssig_T ssig_T
  3.2466 +        dead_pre_map Sig dead_old_ssig_map embL old_algLam algLam old_flat flat old_eval_core
  3.2467 +        eval_core old_eval eval x f old_ssig_induct dead_pre_map_comp0 dead_pre_map_comp fp_map_id
  3.2468 +        dtor_inject dtor_unfold_unique Sig_pointful_natural unsig_thm sig_map_thm old_sig_map_comp
  3.2469 +        old_sig_map_cong old_ssig_map_thms old_Lam_pointful_natural Lam_def old_flat_simps
  3.2470 +        flat_simps embL_simps embL_transfer old_eval_core_simps eval_core_simps old_eval_thm
  3.2471 +        eval_thm old_dtor_algLam dtor_algLam old_algLam_thm;
  3.2472 +
  3.2473 +    val algLam_thm = derive_algLam_step_or_merge lthy Y fpT ctor proto_sctr algLam proto_sctr_def
  3.2474 +      old_algLam_pointful algLam_algLam;
  3.2475 +
  3.2476 +    val k_as_ssig = mk_k_as_ssig Z old_sig_T k_T ssig_T Sig dead_sig_map Oper VLeaf;
  3.2477 +    val k_as_ssig' = substT Y fpT k_as_ssig;
  3.2478 +
  3.2479 +    val algrho_rhs = HOLogic.mk_comp (eval, k_as_ssig');
  3.2480 +    val ((algrho, algrho_def), lthy) = lthy
  3.2481 +      |> define_const true fp_b version algrhoN algrho_rhs;
  3.2482 +
  3.2483 +    val k_as_ssig_transfer = derive_transfer_by_transfer_prover lthy live_AsBs Rs R k_as_ssig []
  3.2484 +      fp_k_T_rel_eqs [sig_map_transfer];
  3.2485 +
  3.2486 +    val k_as_ssig_natural = derive_natural_from_transfer lthy [(Y, Z)] [] [] f k_as_ssig
  3.2487 +      k_as_ssig_transfer [ssig_bnf] [dead_k_bnf];
  3.2488 +
  3.2489 +    val k_as_ssig_natural_pointful = mk_pointful lthy k_as_ssig_natural;
  3.2490 +
  3.2491 +    val [_, Lam_Inr] = derive_Lam_Inl_Inr lthy Y Z preT old_sig_T old_ssig_T k_T ssig_T
  3.2492 +      dead_pre_map Sig embL old_Lam Lam rho unsig_thm Lam_def;
  3.2493 +
  3.2494 +    val eval_core_k_as_ssig = derive_eval_core_k_as_ssig lthy Y preT k_T rho eval_core k_as_ssig x
  3.2495 +      pre_map_comp dead_pre_map_id sig_map_comp ssig_map_thms Lam_natural_pointful Lam_Inr
  3.2496 +      flat_VLeaf eval_core_simps;
  3.2497 +
  3.2498 +    val algLam_algrho = derive_algLam_algrho lthy Y fpT Sig algLam algrho algLam_def algrho_def;
  3.2499 +    val dtor_algrho = derive_dtor_algrho lthy Y Z preT fpT k_T ssig_T dead_pre_map dead_k_map dtor
  3.2500 +      rho eval algrho x eval_thm k_as_ssig_natural_pointful eval_core_k_as_ssig algrho_def;
  3.2501 +    val all_algLam_algs = algLam_algLam :: algLam_algrho :: old_all_algLam_algs;
  3.2502 +
  3.2503 +    val (((corecUU, _), corecUU_thm, corecUU_unique, corecUU_transfer, _, sctr_transfer,
  3.2504 +          sctr_pointful_natural), lthy) = lthy
  3.2505 +      |> define_corecUU_etc fp_b version live_AsBs Y Z preT fpT ssig_T pre_map dead_pre_map pre_rel
  3.2506 +        fp_rel ctor Oper ssig_map dead_ssig_map ssig_rel proto_sctr flat eval_core eval corecU fs f
  3.2507 +        g Rs R pre_map_transfer fp_k_T_rel_eqs dtor_unfold_transfer dtor_transfer ssig_map_transfer
  3.2508 +        proto_sctr_transfer proto_sctr_pointful_natural flat_transfer flat_pointful_natural
  3.2509 +        eval_core_transfer eval_core_pointful_natural eval_thm eval_flat eval_Oper algLam_thm
  3.2510 +        cutSsig_def corecU_def corecU_ctor corecU_unique pre_bnf dead_pre_bnf fp_res ssig_fp_sugar;
  3.2511 +
  3.2512 +    val (ctr_wrapper, friends) =
  3.2513 +      mk_ctr_wrapper_friends lthy friend_name friend_T old_sig_T k_T Sig old_buffer;
  3.2514 +
  3.2515 +    val Retr = enforce_type lthy (domain_type o domain_type) fpT old_Retr0;
  3.2516 +
  3.2517 +    val (dtor_coinduct_info, lthy) = lthy
  3.2518 +      |> derive_cong_step fp_b version fpT dead_ssig_bnf dead_pre_bnf eval eval_thm
  3.2519 +        eval_core_transfer old_dtor_coinduct_info algrho_def k_as_ssig_transfer Retr equivp_Retr
  3.2520 +        Retr_coinduct eval_embL embL_transfer old_all_dead_k_bnfs;
  3.2521 +
  3.2522 +    val buffer =
  3.2523 +      {Oper = Oper, VLeaf = VLeaf, CLeaf = CLeaf, ctr_wrapper = ctr_wrapper, friends = friends};
  3.2524 +
  3.2525 +    val notes =
  3.2526 +      [(corecUU_transferN, [corecUU_transfer])] @
  3.2527 +      (if Config.get lthy bnf_internals then
  3.2528 +         [(algLamN, [algLam_thm]),
  3.2529 +          (algLam_algLamN, [algLam_algLam]),
  3.2530 +          (algLam_algrhoN, [algLam_algrho]),
  3.2531 +          (cong_alg_introsN, #cong_alg_intros dtor_coinduct_info),
  3.2532 +          (cong_localeN, [#cong_locale dtor_coinduct_info]),
  3.2533 +          (corecU_ctorN, [corecU_ctor]),
  3.2534 +          (corecU_uniqueN, [corecU_unique]),
  3.2535 +          (corecUUN, [corecUU_thm]),
  3.2536 +          (corecUU_uniqueN, [corecUU_unique]),
  3.2537 +          (dtor_algLamN, [dtor_algLam]),
  3.2538 +          (dtor_algrhoN, [dtor_algrho]),
  3.2539 +          (dtor_coinductN, [#dtor_coinduct dtor_coinduct_info]),
  3.2540 +          (embL_pointful_naturalN, [embL_pointful_natural]),
  3.2541 +          (embL_transferN, [embL_transfer]),
  3.2542 +          (evalN, [eval_thm]),
  3.2543 +          (eval_core_pointful_naturalN, [eval_core_pointful_natural]),
  3.2544 +          (eval_core_transferN, [eval_core_transfer]),
  3.2545 +          (eval_flatN, [eval_flat]),
  3.2546 +          (eval_simpsN, eval_simps),
  3.2547 +          (flat_pointful_naturalN, [flat_pointful_natural]),
  3.2548 +          (flat_transferN, [flat_transfer]),
  3.2549 +          (k_as_ssig_naturalN, [k_as_ssig_natural]),
  3.2550 +          (k_as_ssig_transferN, [k_as_ssig_transfer]),
  3.2551 +          (Lam_pointful_naturalN, [Lam_pointful_natural]),
  3.2552 +          (Lam_transferN, [Lam_transfer]),
  3.2553 +          (proto_sctr_pointful_naturalN, [proto_sctr_pointful_natural]),
  3.2554 +          (proto_sctr_transferN, [proto_sctr_transfer]),
  3.2555 +          (rho_transferN, [rho_transfer]),
  3.2556 +          (sctr_pointful_naturalN, [sctr_pointful_natural]),
  3.2557 +          (sctr_transferN, [sctr_transfer]),
  3.2558 +          (Sig_pointful_naturalN, [Sig_pointful_natural])]
  3.2559 +       else
  3.2560 +         [])
  3.2561 +      |> map (fn (thmN, thms) =>
  3.2562 +        ((mk_version_fp_binding true lthy version fp_b thmN, []), [(thms, [])]));
  3.2563 +
  3.2564 +    val phi = Local_Theory.target_morphism lthy;
  3.2565 +  in
  3.2566 +    (({fp_b = fp_b, version = version, fpT = fpT, Y = Y, Z = Z, friend_names = friend_names,
  3.2567 +       sig_fp_sugars = sig_fp_sugar :: old_sig_fp_sugars, ssig_fp_sugar = ssig_fp_sugar, Lam = Lam,
  3.2568 +       proto_sctr = proto_sctr, flat = flat, eval_core = eval_core, eval = eval, algLam = algLam,
  3.2569 +       corecUU = corecUU, dtor_transfer = dtor_transfer, Lam_transfer = Lam_transfer,
  3.2570 +       Lam_pointful_natural = Lam_pointful_natural, proto_sctr_transfer = proto_sctr_transfer,
  3.2571 +       flat_simps = flat_simps, eval_core_simps = eval_core_simps, eval_thm = eval_thm,
  3.2572 +       eval_simps = eval_simps, all_algLam_algs = all_algLam_algs, algLam_thm = algLam_thm,
  3.2573 +       dtor_algLam = dtor_algLam, corecUU_thm = corecUU_thm, corecUU_unique = corecUU_unique,
  3.2574 +       corecUU_transfer = corecUU_transfer, buffer = buffer,
  3.2575 +       all_dead_k_bnfs = dead_k_bnf :: old_all_dead_k_bnfs, Retr = Retr, equivp_Retr = equivp_Retr,
  3.2576 +       Retr_coinduct = Retr_coinduct, dtor_coinduct_info = dtor_coinduct_info}
  3.2577 +      |> morph_corec_info phi,
  3.2578 +      ({algrho = algrho, dtor_algrho = dtor_algrho, algLam_algrho = algLam_algrho}
  3.2579 +       |> morph_friend_info phi)),
  3.2580 +     lthy |> Local_Theory.notes notes |> snd)
  3.2581 +  end;
  3.2582 +
  3.2583 +fun derive_corecUU_merge (fpT as Type (fpT_name, res_Ds))
  3.2584 +    ({friend_names = old1_friend_names,
  3.2585 +      sig_fp_sugars = old1_sig_fp_sugars as old1_sig_fp_sugar :: _,
  3.2586 +      ssig_fp_sugar = old1_ssig_fp_sugar, Lam = old1_Lam0, proto_sctr = old1_proto_sctr0,
  3.2587 +      flat = old1_flat0, eval_core = old1_eval_core0, eval = old1_eval0, algLam = old1_algLam0,
  3.2588 +      dtor_transfer, Lam_transfer = old1_Lam_transfer,
  3.2589 +      Lam_pointful_natural = old1_Lam_pointful_natural,
  3.2590 +      proto_sctr_transfer = old1_proto_sctr_transfer, flat_simps = old1_flat_simps,
  3.2591 +      eval_core_simps = old1_eval_core_simps, eval_thm = old1_eval_thm,
  3.2592 +      all_algLam_algs = old1_all_algLam_algs, algLam_thm = old1_algLam_thm,
  3.2593 +      dtor_algLam = old1_dtor_algLam, buffer = old1_buffer, all_dead_k_bnfs = old1_all_dead_k_bnfs,
  3.2594 +      Retr = old1_Retr0, equivp_Retr, Retr_coinduct, dtor_coinduct_info = old1_dtor_coinduct_info,
  3.2595 +      ...} : corec_info)
  3.2596 +    ({friend_names = old2_friend_names,
  3.2597 +      sig_fp_sugars = old2_sig_fp_sugars as old2_sig_fp_sugar :: _,
  3.2598 +      ssig_fp_sugar = old2_ssig_fp_sugar, Lam = old2_Lam0, flat = old2_flat0,
  3.2599 +      eval_core = old2_eval_core0, eval = old2_eval0, algLam = old2_algLam0,
  3.2600 +      Lam_transfer = old2_Lam_transfer, Lam_pointful_natural = old2_Lam_pointful_natural,
  3.2601 +      flat_simps = old2_flat_simps, eval_core_simps = old2_eval_core_simps,
  3.2602 +      eval_thm = old2_eval_thm, all_algLam_algs = old2_all_algLam_algs,
  3.2603 +      algLam_thm = old2_algLam_thm, dtor_algLam = old2_dtor_algLam, buffer = old2_buffer,
  3.2604 +      all_dead_k_bnfs = old2_all_dead_k_bnfs, dtor_coinduct_info = old2_dtor_coinduct_info, ...}
  3.2605 +     : corec_info)
  3.2606 +    lthy =
  3.2607 +  let
  3.2608 +    val {pre_bnf = live_pre_bnf, fp_bnf = live_fp_bnf, fp_res, ...} =
  3.2609 +      checked_fp_sugar_of lthy fpT_name;
  3.2610 +    val num_fp_tyargs = length res_Ds;
  3.2611 +    val live_fp_alives = liveness_of_fp_bnf num_fp_tyargs live_fp_bnf;
  3.2612 +
  3.2613 +    val ((Ds, [Y, Z]), names_lthy) = lthy
  3.2614 +      |> mk_TFrees num_fp_tyargs
  3.2615 +      ||>> mk_TFrees 2;
  3.2616 +
  3.2617 +    (* FIXME *)
  3.2618 +    val live_EsFs = [];
  3.2619 +    val live_AsBs = live_EsFs @ [(Y, Z)];
  3.2620 +    val live = length live_EsFs;
  3.2621 +
  3.2622 +    val ((((x, f), g), R), _) = names_lthy
  3.2623 +      |> yield_singleton (mk_Frees "x") Y
  3.2624 +      ||>> yield_singleton (mk_Frees "f") (Y --> Z)
  3.2625 +      ||>> yield_singleton (mk_Frees "g") (Y --> Z)
  3.2626 +      ||>> yield_singleton (mk_Frees "R") (mk_pred2T Y Z);
  3.2627 +
  3.2628 +    (* FIXME *)
  3.2629 +    val fs = [];
  3.2630 +    val Rs = [];
  3.2631 +
  3.2632 +    val ctor = mk_ctor res_Ds (the_single (#ctors fp_res));
  3.2633 +    val dtor = mk_dtor res_Ds (the_single (#dtors fp_res));
  3.2634 +
  3.2635 +    val old1_sig_T_name = fst (dest_Type (#T old1_sig_fp_sugar));
  3.2636 +    val old2_sig_T_name = fst (dest_Type (#T old2_sig_fp_sugar));
  3.2637 +    val old1_ssig_T_name = fst (dest_Type (#T old1_ssig_fp_sugar));
  3.2638 +    val old2_ssig_T_name = fst (dest_Type (#T old2_ssig_fp_sugar));
  3.2639 +
  3.2640 +    val fp_alives = map (K false) live_fp_alives;
  3.2641 +
  3.2642 +    val As = Ds @ [Y];
  3.2643 +    val res_As = res_Ds @ [Y];
  3.2644 +    val res_Bs = res_Ds @ [Z];
  3.2645 +    val preT = pre_type_of_ctor Y ctor;
  3.2646 +    val YpreT = HOLogic.mk_prodT (Y, preT);
  3.2647 +    val fpT0 = Type (fpT_name, Ds);
  3.2648 +    val old1_sig_T0 = Type (old1_sig_T_name, As);
  3.2649 +    val old2_sig_T0 = Type (old2_sig_T_name, As);
  3.2650 +    val old1_sig_T = Type (old1_sig_T_name, res_As);
  3.2651 +    val old2_sig_T = Type (old2_sig_T_name, res_As);
  3.2652 +    val old1_ssig_T = Type (old1_ssig_T_name, res_As);
  3.2653 +    val old2_ssig_T = Type (old2_ssig_T_name, res_As);
  3.2654 +    val old1_Lam_domT = Tsubst Y YpreT old1_sig_T;
  3.2655 +    val old2_Lam_domT = Tsubst Y YpreT old2_sig_T;
  3.2656 +    val old1_eval_core_domT = Tsubst Y YpreT old1_ssig_T;
  3.2657 +    val old2_eval_core_domT = Tsubst Y YpreT old2_ssig_T;
  3.2658 +
  3.2659 +    val ((fp_b, version), lthy) = lthy |> get_name_next_version_of fpT_name;
  3.2660 +
  3.2661 +    val ((sig_fp_sugar, ssig_fp_sugar), lthy) = lthy
  3.2662 +      |> define_sig_type fp_b version fp_alives Ds Y (mk_sumT (old1_sig_T0, old2_sig_T0))
  3.2663 +      ||>> define_ssig_type fp_b version fp_alives Ds Y fpT0;
  3.2664 +
  3.2665 +    val sig_T_name = fst (dest_Type (#T sig_fp_sugar));
  3.2666 +    val ssig_T_name = fst (dest_Type (#T ssig_fp_sugar));
  3.2667 +
  3.2668 +    val old1_sig_bnf = #fp_bnf old1_sig_fp_sugar;
  3.2669 +    val old2_sig_bnf = #fp_bnf old2_sig_fp_sugar;
  3.2670 +    val old1_ssig_bnf = #fp_bnf old1_ssig_fp_sugar;
  3.2671 +    val old2_ssig_bnf = #fp_bnf old2_ssig_fp_sugar;
  3.2672 +    val sig_bnf = #fp_bnf sig_fp_sugar;
  3.2673 +    val ssig_bnf = #fp_bnf ssig_fp_sugar;
  3.2674 +
  3.2675 +    val ((((((((dead_pre_bnf, dead_fp_bnf), dead_old1_sig_bnf), dead_old2_sig_bnf),
  3.2676 +        dead_old1_ssig_bnf), dead_old2_ssig_bnf), dead_sig_bnf), dead_ssig_bnf), lthy) = lthy
  3.2677 +      |> bnf_kill_all_but 1 live_pre_bnf
  3.2678 +      ||>> bnf_kill_all_but 0 live_fp_bnf
  3.2679 +      ||>> bnf_kill_all_but 1 old1_sig_bnf
  3.2680 +      ||>> bnf_kill_all_but 1 old2_sig_bnf
  3.2681 +      ||>> bnf_kill_all_but 1 old1_ssig_bnf
  3.2682 +      ||>> bnf_kill_all_but 1 old2_ssig_bnf
  3.2683 +      ||>> bnf_kill_all_but 1 sig_bnf
  3.2684 +      ||>> bnf_kill_all_but 1 ssig_bnf;
  3.2685 +
  3.2686 +    (* FIXME *)
  3.2687 +    val pre_bnf = dead_pre_bnf;
  3.2688 +    val fp_bnf = dead_fp_bnf;
  3.2689 +
  3.2690 +    val old1_ssig_fp_ctr_sugar = #fp_ctr_sugar old1_ssig_fp_sugar;
  3.2691 +    val old2_ssig_fp_ctr_sugar = #fp_ctr_sugar old2_ssig_fp_sugar;
  3.2692 +    val sig_fp_ctr_sugar = #fp_ctr_sugar sig_fp_sugar;
  3.2693 +    val ssig_fp_ctr_sugar = #fp_ctr_sugar ssig_fp_sugar;
  3.2694 +
  3.2695 +    val sig_fp_bnf_sugar = #fp_bnf_sugar sig_fp_sugar;
  3.2696 +    val old1_ssig_fp_bnf_sugar = #fp_bnf_sugar old1_ssig_fp_sugar;
  3.2697 +    val old2_ssig_fp_bnf_sugar = #fp_bnf_sugar old2_ssig_fp_sugar;
  3.2698 +    val ssig_fp_bnf_sugar = #fp_bnf_sugar ssig_fp_sugar;
  3.2699 +    val old1_ssig_fp_induct_sugar = #fp_co_induct_sugar old1_ssig_fp_sugar;
  3.2700 +    val old2_ssig_fp_induct_sugar = #fp_co_induct_sugar old2_ssig_fp_sugar;
  3.2701 +    val ssig_fp_induct_sugar = #fp_co_induct_sugar ssig_fp_sugar;
  3.2702 +
  3.2703 +    val old1_ssig_ctr_sugar = #ctr_sugar old1_ssig_fp_ctr_sugar;
  3.2704 +    val old2_ssig_ctr_sugar = #ctr_sugar old2_ssig_fp_ctr_sugar;
  3.2705 +    val sig_ctr_sugar = #ctr_sugar sig_fp_ctr_sugar;
  3.2706 +    val ssig_ctr_sugar = #ctr_sugar ssig_fp_ctr_sugar;
  3.2707 +
  3.2708 +    val sig_T = Type (sig_T_name, res_As);
  3.2709 +    val ssig_T = Type (ssig_T_name, res_As);
  3.2710 +
  3.2711 +    val pre_map = mk_mapN lthy live_AsBs preT pre_bnf;
  3.2712 +    val pre_rel = mk_relN lthy live_AsBs preT pre_bnf;
  3.2713 +    val dead_pre_map = mk_map1 lthy Y Z preT dead_pre_bnf;
  3.2714 +    val dead_pre_rel = mk_rel1 lthy Y Z preT dead_pre_bnf;
  3.2715 +    val fp_rel = mk_relN lthy live_EsFs fpT fp_bnf;
  3.2716 +    val dtor_unfold = mk_co_rec (Proof_Context.theory_of lthy) Greatest_FP [Z] fpT
  3.2717 +      (the_single (#xtor_un_folds fp_res));
  3.2718 +    val Sig = mk_ctr res_As (the_single (#ctrs sig_ctr_sugar));
  3.2719 +    val unsig = mk_disc_or_sel res_As (the_single (the_single (#selss sig_ctr_sugar)));
  3.2720 +    val sig_rel = mk_relN lthy live_AsBs sig_T sig_bnf;
  3.2721 +    val dead_old1_sig_map = mk_map 1 res_As res_Bs (map_of_bnf dead_old1_sig_bnf);
  3.2722 +    val dead_old2_sig_map = mk_map 1 res_As res_Bs (map_of_bnf dead_old2_sig_bnf);
  3.2723 +    val dead_sig_map = mk_map 1 res_As res_Bs (map_of_bnf dead_sig_bnf);
  3.2724 +    val dead_sig_rel = mk_rel 1 res_As res_Bs (rel_of_bnf dead_sig_bnf);
  3.2725 +    val [old1_Oper, old1_VLeaf, old1_CLeaf] = map (mk_ctr res_As) (#ctrs old1_ssig_ctr_sugar);
  3.2726 +    val [old2_Oper, old2_VLeaf, old2_CLeaf] = map (mk_ctr res_As) (#ctrs old2_ssig_ctr_sugar);
  3.2727 +    val [Oper, VLeaf, CLeaf] = map (mk_ctr res_As) (#ctrs ssig_ctr_sugar);
  3.2728 +    val old1_ssig_map = mk_map 1 res_As res_Bs (map_of_bnf dead_old1_ssig_bnf);
  3.2729 +    val old2_ssig_map = mk_map 1 res_As res_Bs (map_of_bnf dead_old2_ssig_bnf);
  3.2730 +    val ssig_map = mk_mapN lthy live_AsBs ssig_T ssig_bnf;
  3.2731 +    val ssig_rel = mk_relN lthy live_AsBs ssig_T ssig_bnf;
  3.2732 +    val dead_ssig_map = mk_map 1 res_As res_Bs (map_of_bnf dead_ssig_bnf);
  3.2733 +    val old1_Lam = enforce_type lthy domain_type old1_Lam_domT old1_Lam0;
  3.2734 +    val old2_Lam = enforce_type lthy domain_type old2_Lam_domT old2_Lam0;
  3.2735 +    val old1_proto_sctr = enforce_type lthy domain_type preT old1_proto_sctr0;
  3.2736 +    val old1_flat = enforce_type lthy range_type old1_ssig_T old1_flat0;
  3.2737 +    val old2_flat = enforce_type lthy range_type old2_ssig_T old2_flat0;
  3.2738 +    val old1_eval_core = enforce_type lthy domain_type old1_eval_core_domT old1_eval_core0;
  3.2739 +    val old2_eval_core = enforce_type lthy domain_type old2_eval_core_domT old2_eval_core0;
  3.2740 +    val old1_eval = enforce_type lthy range_type fpT old1_eval0;
  3.2741 +    val old2_eval = enforce_type lthy range_type fpT old2_eval0;
  3.2742 +    val old1_algLam = enforce_type lthy range_type fpT old1_algLam0;
  3.2743 +    val old2_algLam = enforce_type lthy range_type fpT old2_algLam0;
  3.2744 +
  3.2745 +    val ((embLL, embLL_def, embLL_simps), lthy) = lthy
  3.2746 +      |> define_embL embLLN fp_b version Y Z fpT old1_sig_T old1_ssig_T old2_sig_T ssig_T Inl_const
  3.2747 +        dead_old1_sig_map Sig old1_Oper old1_VLeaf old1_CLeaf Oper VLeaf CLeaf;
  3.2748 +
  3.2749 +    val ((embLR, embLR_def, embLR_simps), lthy) = lthy
  3.2750 +      |> define_embL embLRN fp_b version Y Z fpT old2_sig_T old2_ssig_T old1_sig_T ssig_T
  3.2751 +        (fn T => fn U => Inr_const U T) dead_old2_sig_map Sig old2_Oper old2_VLeaf old2_CLeaf Oper
  3.2752 +        VLeaf CLeaf;
  3.2753 +
  3.2754 +    val ((Lam, Lam_def), lthy) = lthy
  3.2755 +      |> define_Lam_merge fp_b version Y Z preT old1_ssig_T old2_ssig_T ssig_T dead_pre_map unsig
  3.2756 +        embLL embLR old1_Lam old2_Lam;
  3.2757 +
  3.2758 +    val ((proto_sctr, proto_sctr_def), lthy) = lthy
  3.2759 +      |> define_proto_sctr_step_or_merge fp_b version old1_sig_T old2_sig_T Sig old1_proto_sctr;
  3.2760 +
  3.2761 +    val pre_map_transfer = map_transfer_of_bnf pre_bnf;
  3.2762 +    val dead_pre_map_comp0 = map_comp0_of_bnf dead_pre_bnf;
  3.2763 +    val dead_pre_map_comp = map_comp_of_bnf dead_pre_bnf;
  3.2764 +    val fp_map_id = map_id_of_bnf fp_bnf;
  3.2765 +    val fp_rel_eq = rel_eq_of_bnf fp_bnf;
  3.2766 +    val [ctor_dtor] = #ctor_dtors fp_res;
  3.2767 +    val [dtor_inject] = #dtor_injects fp_res;
  3.2768 +    val [dtor_unfold_thm] = #xtor_un_fold_thms fp_res;
  3.2769 +    val [dtor_unfold_unique] = #xtor_un_fold_uniques fp_res;
  3.2770 +    val [dtor_unfold_transfer] = #xtor_un_fold_transfers fp_res;
  3.2771 +    val unsig_thm = the_single (the_single (#sel_thmss sig_ctr_sugar));
  3.2772 +    val [sig_map_thm] = #map_thms sig_fp_bnf_sugar;
  3.2773 +    val old1_sig_map_comp = map_comp_of_bnf old1_sig_bnf;
  3.2774 +    val old2_sig_map_comp = map_comp_of_bnf old2_sig_bnf;
  3.2775 +    val old1_sig_map_cong = map_cong_of_bnf old1_sig_bnf;
  3.2776 +    val old2_sig_map_cong = map_cong_of_bnf old2_sig_bnf;
  3.2777 +    val old1_ssig_map_thms = #map_thms old1_ssig_fp_bnf_sugar;
  3.2778 +    val old2_ssig_map_thms = #map_thms old2_ssig_fp_bnf_sugar;
  3.2779 +    val [Oper_map_thm, VLeaf_map_thm, CLeaf_map_thm] = #map_thms ssig_fp_bnf_sugar;
  3.2780 +    val old1_sig_map_transfer = map_transfer_of_bnf old1_sig_bnf;
  3.2781 +    val old2_sig_map_transfer = map_transfer_of_bnf old2_sig_bnf;
  3.2782 +    val sig_map_transfer = map_transfer_of_bnf sig_bnf;
  3.2783 +    val ssig_map_thms = #map_thms ssig_fp_bnf_sugar;
  3.2784 +    val ssig_map_transfer = map_transfer_of_bnf ssig_bnf;
  3.2785 +    val old1_ssig_induct = the_single (#co_inducts old1_ssig_fp_induct_sugar);
  3.2786 +    val old2_ssig_induct = the_single (#co_inducts old2_ssig_fp_induct_sugar);
  3.2787 +    val ssig_induct = the_single (#co_inducts ssig_fp_induct_sugar);
  3.2788 +
  3.2789 +    val proto_sctr_transfer = derive_proto_sctr_transfer_step_or_merge lthy Y Z R dead_pre_rel
  3.2790 +      dead_sig_rel proto_sctr proto_sctr_def [] [old1_proto_sctr_transfer];
  3.2791 +    val embLL_transfer = derive_transfer_by_transfer_prover lthy live_AsBs Rs R embLL [embLL_def] []
  3.2792 +      [old1_sig_map_transfer];
  3.2793 +    val embLR_transfer = derive_transfer_by_transfer_prover lthy live_AsBs Rs R embLR [embLR_def] []
  3.2794 +      [old2_sig_map_transfer];
  3.2795 +    val Lam_transfer = derive_Lam_or_eval_core_transfer lthy live_AsBs Y Z preT ssig_T Rs R
  3.2796 +      pre_rel sig_rel ssig_rel Lam Lam_def []
  3.2797 +      [pre_map_transfer, old1_Lam_transfer, old2_Lam_transfer, embLL_transfer, embLR_transfer];
  3.2798 +
  3.2799 +    val ((((((((flat, _, flat_simps), flat_transfer),
  3.2800 +            ((eval_core, _, eval_core_simps), eval_core_transfer)), (eval, eval_def)),
  3.2801 +          (cutSsig, cutSsig_def)), (algLam, algLam_def)), (corecU, corecU_def)), lthy) = lthy
  3.2802 +      |> define_flat_etc fp_b version live_AsBs Y Z preT fpT sig_T ssig_T Oper VLeaf CLeaf pre_rel
  3.2803 +        dead_pre_map dtor dtor_unfold dead_sig_map ssig_rel dead_ssig_map Lam Rs R pre_map_transfer
  3.2804 +        [fp_rel_eq] sig_map_transfer ssig_map_transfer Lam_transfer dtor_transfer;
  3.2805 +
  3.2806 +    val (Sig_pointful_natural, flat_pointful_natural, _, Lam_pointful_natural, _,
  3.2807 +         eval_core_pointful_natural, eval_thm, eval_flat, eval_simps as [eval_Oper, _, _],
  3.2808 +         corecU_ctor, corecU_unique, dtor_algLam) =
  3.2809 +      derive_Sig_natural_etc lthy live live_AsBs Y Z preT fpT fpT sig_T ssig_T pre_map dead_pre_map
  3.2810 +        ctor dtor Sig dead_sig_map Oper VLeaf CLeaf ssig_map dead_ssig_map Lam flat eval_core eval
  3.2811 +        cutSsig algLam corecU x fs f g ctor_dtor dtor_inject dtor_unfold_thm dtor_unfold_unique
  3.2812 +        sig_map_thm ssig_induct ssig_map_thms Oper_map_thm VLeaf_map_thm CLeaf_map_thm Lam_transfer
  3.2813 +        flat_simps flat_transfer eval_core_simps eval_core_transfer eval_def cutSsig_def algLam_def
  3.2814 +        corecU_def live_pre_bnf pre_bnf dead_pre_bnf fp_bnf sig_bnf ssig_bnf dead_ssig_bnf;
  3.2815 +
  3.2816 +    val proto_sctr_natural = derive_natural_from_transfer_with_pre_type lthy live_AsBs Y Z preT
  3.2817 +      ssig_T pre_map ssig_map fs f proto_sctr proto_sctr_transfer [pre_bnf, sig_bnf] [];
  3.2818 +    val proto_sctr_pointful_natural = mk_pointful lthy proto_sctr_natural RS sym;
  3.2819 +
  3.2820 +    val (embLL_pointful_natural, old1_algLam_pointful, eval_embLL, algLam_algLamL) =
  3.2821 +      derive_embL_natural_etc lthy Inl_const old1_ssig_bnf ssig_bnf Y Z preT fpT old1_ssig_T ssig_T
  3.2822 +        dead_pre_map Sig old1_ssig_map embLL old1_algLam algLam old1_flat flat old1_eval_core
  3.2823 +        eval_core old1_eval eval x f old1_ssig_induct dead_pre_map_comp0 dead_pre_map_comp fp_map_id
  3.2824 +        dtor_inject dtor_unfold_unique Sig_pointful_natural unsig_thm sig_map_thm old1_sig_map_comp
  3.2825 +        old1_sig_map_cong old1_ssig_map_thms old1_Lam_pointful_natural Lam_def old1_flat_simps
  3.2826 +        flat_simps embLL_simps embLL_transfer old1_eval_core_simps eval_core_simps old1_eval_thm
  3.2827 +        eval_thm old1_dtor_algLam dtor_algLam old1_algLam_thm;
  3.2828 +
  3.2829 +    val (embLR_pointful_natural, _, eval_embLR, algLam_algLamR) =
  3.2830 +      derive_embL_natural_etc lthy Inr_const old2_ssig_bnf ssig_bnf Y Z preT fpT old2_ssig_T ssig_T
  3.2831 +        dead_pre_map Sig old2_ssig_map embLR old2_algLam algLam old2_flat flat old2_eval_core
  3.2832 +        eval_core old2_eval eval x f old2_ssig_induct dead_pre_map_comp0 dead_pre_map_comp fp_map_id
  3.2833 +        dtor_inject dtor_unfold_unique Sig_pointful_natural unsig_thm sig_map_thm old2_sig_map_comp
  3.2834 +        old2_sig_map_cong old2_ssig_map_thms old2_Lam_pointful_natural Lam_def old2_flat_simps
  3.2835 +        flat_simps embLR_simps embLR_transfer old2_eval_core_simps eval_core_simps old2_eval_thm
  3.2836 +        eval_thm old2_dtor_algLam dtor_algLam old2_algLam_thm;
  3.2837 +
  3.2838 +    val algLam_thm = derive_algLam_step_or_merge lthy Y fpT ctor proto_sctr algLam proto_sctr_def
  3.2839 +      old1_algLam_pointful algLam_algLamL;
  3.2840 +
  3.2841 +    val all_algLam_algs = algLam_algLamL :: algLam_algLamR ::
  3.2842 +      merge_lists (Thm.eq_thm_prop o apply2 zero_var_indexes) old1_all_algLam_algs
  3.2843 +        old2_all_algLam_algs;
  3.2844 +
  3.2845 +    val (((corecUU, _), corecUU_thm, corecUU_unique, corecUU_transfer, _, sctr_transfer,
  3.2846 +          sctr_pointful_natural), lthy) = lthy
  3.2847 +      |> define_corecUU_etc fp_b version live_AsBs Y Z preT fpT ssig_T pre_map dead_pre_map pre_rel
  3.2848 +        fp_rel ctor Oper ssig_map dead_ssig_map ssig_rel proto_sctr flat eval_core eval corecU fs f
  3.2849 +        g Rs R pre_map_transfer [] dtor_unfold_transfer dtor_transfer ssig_map_transfer
  3.2850 +        proto_sctr_transfer proto_sctr_pointful_natural flat_transfer flat_pointful_natural
  3.2851 +        eval_core_transfer eval_core_pointful_natural eval_thm eval_flat eval_Oper algLam_thm
  3.2852 +        cutSsig_def corecU_def corecU_ctor corecU_unique pre_bnf dead_pre_bnf fp_res ssig_fp_sugar;
  3.2853 +
  3.2854 +    val Retr = enforce_type lthy (domain_type o domain_type) fpT old1_Retr0;
  3.2855 +
  3.2856 +    val embed_Sig_inl = embed_Sig lthy Sig (Inl_const old1_sig_T old2_sig_T);
  3.2857 +    val embed_Sig_inr = embed_Sig lthy Sig (Inr_const old1_sig_T old2_sig_T);
  3.2858 +
  3.2859 +    val ctr_wrapper = embed_Sig_inl (#ctr_wrapper old1_buffer);
  3.2860 +    val friends = Symtab.merge (K true)
  3.2861 +      (Symtab.map (K (apsnd embed_Sig_inl)) (#friends old1_buffer),
  3.2862 +       Symtab.map (K (apsnd embed_Sig_inr)) (#friends old2_buffer));
  3.2863 +
  3.2864 +    val old_fp_sugars =
  3.2865 +      merge_lists (op = o apply2 (fst o dest_Type o #T)) old1_sig_fp_sugars old2_sig_fp_sugars;
  3.2866 +
  3.2867 +    val ((dtor_coinduct_info, all_dead_k_bnfs, friend_names), lthy) = lthy
  3.2868 +      |> derive_cong_merge fp_b version fpT old1_friend_names old2_friend_names dead_ssig_bnf
  3.2869 +        dead_pre_bnf eval eval_thm eval_core_transfer old1_dtor_coinduct_info
  3.2870 +        old2_dtor_coinduct_info Retr equivp_Retr Retr_coinduct eval_embLL embLL_transfer eval_embLR
  3.2871 +        embLR_transfer old1_all_dead_k_bnfs old2_all_dead_k_bnfs;
  3.2872 +
  3.2873 +    val buffer =
  3.2874 +      {Oper = Oper, VLeaf = VLeaf, CLeaf = CLeaf, ctr_wrapper = ctr_wrapper, friends = friends};
  3.2875 +
  3.2876 +    val notes =
  3.2877 +      [(corecUU_transferN, [corecUU_transfer])] @
  3.2878 +      (if Config.get lthy bnf_internals then
  3.2879 +         [(algLamN, [algLam_thm]),
  3.2880 +          (algLam_algLamN, [algLam_algLamL, algLam_algLamR]),
  3.2881 +          (cong_alg_introsN, #cong_alg_intros dtor_coinduct_info),
  3.2882 +          (cong_localeN, [#cong_locale dtor_coinduct_info]),
  3.2883 +          (corecU_ctorN, [corecU_ctor]),
  3.2884 +          (corecU_uniqueN, [corecU_unique]),
  3.2885 +          (corecUUN, [corecUU_thm]),
  3.2886 +          (corecUU_uniqueN, [corecUU_unique]),
  3.2887 +          (dtor_algLamN, [dtor_algLam]),
  3.2888 +          (dtor_coinductN, [#dtor_coinduct dtor_coinduct_info]),
  3.2889 +          (eval_core_pointful_naturalN, [eval_core_pointful_natural]),
  3.2890 +          (eval_core_transferN, [eval_core_transfer]),
  3.2891 +          (embL_pointful_naturalN, [embLL_pointful_natural, embLR_pointful_natural]),
  3.2892 +          (embL_transferN, [embLL_transfer, embLR_transfer]),
  3.2893 +          (evalN, [eval_thm]),
  3.2894 +          (eval_flatN, [eval_flat]),
  3.2895 +          (eval_simpsN, eval_simps),
  3.2896 +          (flat_pointful_naturalN, [flat_pointful_natural]),
  3.2897 +          (flat_transferN, [flat_transfer]),
  3.2898 +          (Lam_pointful_naturalN, [Lam_pointful_natural]),
  3.2899 +          (Lam_transferN, [Lam_transfer]),
  3.2900 +          (proto_sctr_pointful_naturalN, [proto_sctr_pointful_natural]),
  3.2901 +          (proto_sctr_transferN, [proto_sctr_transfer]),
  3.2902 +          (sctr_pointful_naturalN, [sctr_pointful_natural]),
  3.2903 +          (sctr_transferN, [sctr_transfer]),
  3.2904 +          (Sig_pointful_naturalN, [Sig_pointful_natural])]
  3.2905 +       else
  3.2906 +         [])
  3.2907 +      |> map (fn (thmN, thms) =>
  3.2908 +        ((mk_version_fp_binding true lthy version fp_b thmN, []), [(thms, [])]));
  3.2909 +  in
  3.2910 +    ({fp_b = fp_b, version = version, fpT = fpT, Y = Y, Z = Z, friend_names = friend_names,
  3.2911 +      sig_fp_sugars = sig_fp_sugar :: old_fp_sugars, ssig_fp_sugar = ssig_fp_sugar, Lam = Lam,
  3.2912 +      proto_sctr = proto_sctr, flat = flat, eval_core = eval_core, eval = eval, algLam = algLam,
  3.2913 +      corecUU = corecUU, dtor_transfer = dtor_transfer, Lam_transfer = Lam_transfer,
  3.2914 +      Lam_pointful_natural = Lam_pointful_natural, proto_sctr_transfer = proto_sctr_transfer,
  3.2915 +      flat_simps = flat_simps, eval_core_simps = eval_core_simps, eval_thm = eval_thm,
  3.2916 +      eval_simps = eval_simps, all_algLam_algs = all_algLam_algs, algLam_thm = algLam_thm,
  3.2917 +      dtor_algLam = dtor_algLam, corecUU_thm = corecUU_thm, corecUU_unique = corecUU_unique,
  3.2918 +      corecUU_transfer = corecUU_transfer, buffer = buffer, all_dead_k_bnfs = all_dead_k_bnfs,
  3.2919 +      Retr = Retr, equivp_Retr = equivp_Retr, Retr_coinduct = Retr_coinduct,
  3.2920 +      dtor_coinduct_info = dtor_coinduct_info}
  3.2921 +     |> morph_corec_info (Local_Theory.target_morphism lthy),
  3.2922 +     lthy |> Local_Theory.notes notes |> snd)
  3.2923 +  end;
  3.2924 +
  3.2925 +fun set_corec_info_exprs fpT_name f =
  3.2926 +  Local_Theory.declaration {syntax = false, pervasive = true} (fn phi =>
  3.2927 +    let val exprs = f phi in
  3.2928 +      Data.map (apsnd (fn [info_tab] => [Symtab.map_default (fpT_name, exprs) (K exprs) info_tab]))
  3.2929 +    end);
  3.2930 +
  3.2931 +fun subsume_corec_info_ad ctxt {fpT = fpT1, friend_names = friend_names1}
  3.2932 +    {fpT = fpT2, friend_names = friend_names2} =
  3.2933 +  Sign.typ_instance (Proof_Context.theory_of ctxt) (fpT1, fpT2) andalso
  3.2934 +  subset (op =) (friend_names1, friend_names2);
  3.2935 +
  3.2936 +fun subsume_corec_info_expr ctxt expr1 expr2 =
  3.2937 +  subsume_corec_info_ad ctxt (corec_ad_of_expr expr1) (corec_ad_of_expr expr2);
  3.2938 +
  3.2939 +fun instantiate_corec_info thy res_T (info as {fpT, ...}) =
  3.2940 +  let
  3.2941 +    val As_rho = tvar_subst thy [fpT] [res_T];
  3.2942 +    val substAT = Term.typ_subst_TVars As_rho;
  3.2943 +    val substA = Term.subst_TVars As_rho;
  3.2944 +    val phi = Morphism.typ_morphism "BNF" substAT $> Morphism.term_morphism "BNF" substA;
  3.2945 +  in
  3.2946 +    morph_corec_info phi info
  3.2947 +  end;
  3.2948 +
  3.2949 +fun instantiate_corec_info_expr thy res_T (Ad ({friend_names, ...}, f)) =
  3.2950 +    Ad ({fpT = res_T, friend_names = friend_names}, f #>> instantiate_corec_info thy res_T)
  3.2951 +  | instantiate_corec_info_expr thy res_T (Info info) =
  3.2952 +    Info (instantiate_corec_info thy res_T info);
  3.2953 +
  3.2954 +fun ensure_Info expr = corec_info_of_expr expr #>> Info
  3.2955 +and ensure_Info_if_Info old_expr (expr, lthy) =
  3.2956 +  if is_Info old_expr then ensure_Info expr lthy else (expr, lthy)
  3.2957 +and merge_corec_info_exprs old_exprs expr1 expr2 lthy =
  3.2958 +  if subsume_corec_info_expr lthy expr2 expr1 then
  3.2959 +    if subsume_corec_info_expr lthy expr1 expr2 andalso is_Ad expr1 then
  3.2960 +      (expr2, lthy)
  3.2961 +    else
  3.2962 +      ensure_Info_if_Info expr2 (expr1, lthy)
  3.2963 +  else if subsume_corec_info_expr lthy expr1 expr2 then
  3.2964 +    ensure_Info_if_Info expr1 (expr2, lthy)
  3.2965 +  else
  3.2966 +    let
  3.2967 +      val thy = Proof_Context.theory_of lthy;
  3.2968 +
  3.2969 +      val {fpT = fpT1, friend_names = friend_names1} = corec_ad_of_expr expr1;
  3.2970 +      val {fpT = fpT2, friend_names = friend_names2} = corec_ad_of_expr expr2;
  3.2971 +      val fpT0 = typ_unify_disjointly thy (fpT1, fpT2);
  3.2972 +
  3.2973 +      val fpT = singleton (freeze_types lthy []) fpT0;
  3.2974 +      val friend_names = merge_lists (op =) friend_names1 friend_names2;
  3.2975 +
  3.2976 +      val expr =
  3.2977 +        Ad ({fpT = fpT, friend_names = friend_names},
  3.2978 +          corec_info_of_expr expr1
  3.2979 +          ##>> corec_info_of_expr expr2
  3.2980 +          #-> uncurry (derive_corecUU_merge fpT));
  3.2981 +
  3.2982 +      val old_same_type_exprs =
  3.2983 +        if old_exprs then
  3.2984 +          []
  3.2985 +          |> Sign.typ_instance thy (fpT1, fpT0) ? cons expr1
  3.2986 +          |> Sign.typ_instance thy (fpT2, fpT0) ? cons expr2
  3.2987 +        else
  3.2988 +          [];
  3.2989 +    in
  3.2990 +      (expr, lthy) |> fold ensure_Info_if_Info old_same_type_exprs
  3.2991 +    end
  3.2992 +and insert_corec_info_expr expr exprs lthy =
  3.2993 +  let
  3.2994 +    val thy = Proof_Context.theory_of lthy;
  3.2995 +
  3.2996 +    val {fpT = new_fpT, ...} = corec_ad_of_expr expr;
  3.2997 +
  3.2998 +    val is_Tinst = curry (Sign.typ_instance thy);
  3.2999 +    fun is_Tequiv T U = is_Tinst T U andalso is_Tinst U T;
  3.3000 +
  3.3001 +    val (((equiv_exprs, sub_exprs), sup_exprs), incomp_exprs) = exprs
  3.3002 +      |> List.partition ((fn {fpT, ...} => is_Tequiv fpT new_fpT) o corec_ad_of_expr)
  3.3003 +      ||>> List.partition ((fn {fpT, ...} => is_Tinst fpT new_fpT) o corec_ad_of_expr)
  3.3004 +      ||>> List.partition ((fn {fpT, ...} => is_Tinst new_fpT fpT) o corec_ad_of_expr);
  3.3005 +
  3.3006 +    fun add_instantiated_incomp_expr expr exprs =
  3.3007 +      let val {fpT, ...} = corec_ad_of_expr expr in
  3.3008 +        (case try (typ_unify_disjointly thy) (fpT, new_fpT) of
  3.3009 +          SOME new_T =>
  3.3010 +          let val subsumes = (fn {fpT, ...} => is_Tinst new_T fpT) o corec_ad_of_expr in
  3.3011 +            if exists (exists subsumes) [exprs, sub_exprs] then exprs
  3.3012 +            else instantiate_corec_info_expr thy new_T expr :: exprs
  3.3013 +          end
  3.3014 +        | NONE => exprs)
  3.3015 +      end;
  3.3016 +
  3.3017 +    val unincomp_exprs = fold add_instantiated_incomp_expr incomp_exprs [];
  3.3018 +    val ((merged_sub_exprs, merged_unincomp_exprs), lthy) = lthy
  3.3019 +      |> fold_map (merge_corec_info_exprs true expr) sub_exprs
  3.3020 +      ||>> fold_map (merge_corec_info_exprs false expr) unincomp_exprs;
  3.3021 +    val (merged_equiv_expr, lthy) = (expr, lthy)
  3.3022 +      |> fold (uncurry o merge_corec_info_exprs true) equiv_exprs;
  3.3023 +  in
  3.3024 +    (merged_unincomp_exprs @ merged_sub_exprs @ merged_equiv_expr :: sup_exprs @ incomp_exprs
  3.3025 +     |> sort (rev_order o int_ord o apply2 (length o #friend_names o corec_ad_of_expr)),
  3.3026 +     lthy)
  3.3027 +  end
  3.3028 +and register_corec_info (info as {fpT = Type (fpT_name, _), ...}) lthy =
  3.3029 +  let
  3.3030 +    val (exprs, lthy) = insert_corec_info_expr (Info info) (corec_info_exprs_of lthy fpT_name) lthy;
  3.3031 +  in
  3.3032 +    lthy |> set_corec_info_exprs fpT_name (fn phi => map (morph_corec_info_expr phi) exprs)
  3.3033 +  end
  3.3034 +and corec_info_of_expr (Ad (_, f)) lthy = f lthy
  3.3035 +  | corec_info_of_expr (Info info) lthy = (info, lthy);
  3.3036 +
  3.3037 +fun nonempty_corec_info_exprs_of fpT_name lthy =
  3.3038 +  (case corec_info_exprs_of lthy fpT_name of
  3.3039 +    [] =>
  3.3040 +    derive_corecUU_base fpT_name lthy
  3.3041 +    |> (fn (info, lthy) =>
  3.3042 +      ([Info info], lthy
  3.3043 +         |> set_corec_info_exprs fpT_name (fn phi => [Info (morph_corec_info phi info)])))
  3.3044 +  | exprs => (exprs, lthy));
  3.3045 +
  3.3046 +fun corec_info_of res_T lthy =
  3.3047 +  (case res_T of
  3.3048 +    Type (fpT_name, _) =>
  3.3049 +    let
  3.3050 +      val (exprs, lthy) = nonempty_corec_info_exprs_of fpT_name lthy;
  3.3051 +      val thy = Proof_Context.theory_of lthy;
  3.3052 +      val SOME expr =
  3.3053 +        find_first ((fn {fpT, ...} => Sign.typ_instance thy (res_T, fpT)) o corec_ad_of_expr) exprs;
  3.3054 +      val (info, lthy) = corec_info_of_expr expr lthy;
  3.3055 +    in
  3.3056 +      (instantiate_corec_info thy res_T info, lthy |> is_Ad expr ? register_corec_info info)
  3.3057 +    end
  3.3058 +  | _ => not_codatatype lthy res_T);
  3.3059 +
  3.3060 +fun maybe_corec_info_of ctxt res_T =
  3.3061 +  (case res_T of
  3.3062 +    Type (fpT_name, _) =>
  3.3063 +    let
  3.3064 +      val thy = Proof_Context.theory_of ctxt;
  3.3065 +      val infos = corec_infos_of ctxt fpT_name;
  3.3066 +    in
  3.3067 +      find_first (fn {fpT, ...} => Sign.typ_instance thy (res_T, fpT)) infos
  3.3068 +      |> Option.map (instantiate_corec_info thy res_T)
  3.3069 +    end
  3.3070 +  | _ => not_codatatype ctxt res_T);
  3.3071 +
  3.3072 +fun prepare_friend_corec friend_name friend_T lthy =
  3.3073 +  let
  3.3074 +    val (arg_Ts, res_T) = strip_type friend_T;
  3.3075 +    val Type (fpT_name, res_Ds) =
  3.3076 +      (case res_T of
  3.3077 +        T as Type _ => T
  3.3078 +      | T => error (not_codatatype lthy T));
  3.3079 +
  3.3080 +    val _ = not (null arg_Ts) orelse
  3.3081 +      error "Function with no argument cannot be registered as friend";
  3.3082 +
  3.3083 +    val {pre_bnf, fp_bnf = live_fp_bnf, fp_res, ...} = checked_fp_sugar_of lthy fpT_name;
  3.3084 +    val num_fp_tyargs = length res_Ds;
  3.3085 +    val live_fp_alives = liveness_of_fp_bnf num_fp_tyargs live_fp_bnf;
  3.3086 +
  3.3087 +    val fpT_name = fst (dest_Type res_T);
  3.3088 +
  3.3089 +    val (old_info as {friend_names = old_friend_names, sig_fp_sugars = old_sig_fp_sugar :: _,
  3.3090 +           buffer = old_buffer, ...}, lthy) =
  3.3091 +      corec_info_of res_T lthy;
  3.3092 +    val old_sig_T_name = fst (dest_Type (#T old_sig_fp_sugar));
  3.3093 +    val old_sig_alives = liveness_of_fp_bnf (num_fp_tyargs + 1) (#fp_bnf old_sig_fp_sugar);
  3.3094 +
  3.3095 +    (* FIXME: later *)
  3.3096 +    val fp_alives = fst (split_last old_sig_alives);
  3.3097 +    val fp_alives = map (K false) live_fp_alives;
  3.3098 +
  3.3099 +    val _ = not (member (op =) old_friend_names friend_name) orelse
  3.3100 +      error ("Function " ^ quote (Syntax.string_of_term lthy (Const (friend_name, friend_T))) ^
  3.3101 +        " already registered as friend");
  3.3102 +
  3.3103 +    val lthy = lthy |> Variable.declare_typ friend_T;
  3.3104 +    val ((Ds, [Y, Z]), _) = lthy
  3.3105 +      |> mk_TFrees num_fp_tyargs
  3.3106 +      ||>> mk_TFrees 2;
  3.3107 +
  3.3108 +    (* FIXME *)
  3.3109 +    val dead_Ds = Ds;
  3.3110 +    val live_As = [Y];
  3.3111 +
  3.3112 +    val ctor = mk_ctor res_Ds (the_single (#ctors fp_res));
  3.3113 +
  3.3114 +    val fpT0 = Type (fpT_name, Ds);
  3.3115 +    val k_Ts0 = map (typ_subst_nonatomic (res_Ds ~~ Ds) o typ_subst_nonatomic [(res_T, Y)]) arg_Ts;
  3.3116 +    val k_T0 = mk_tupleT_balanced k_Ts0;
  3.3117 +
  3.3118 +    val As = Ds @ [Y];
  3.3119 +    val res_As = res_Ds @ [Y];
  3.3120 +
  3.3121 +    val k_As = fold Term.add_tfreesT k_Ts0 [];
  3.3122 +    val _ = (case filter_out (member (op =) As o TFree) k_As of [] => ()
  3.3123 +      | k_A :: _ => error ("Cannot have type variable " ^
  3.3124 +          quote (Syntax.string_of_typ lthy (TFree k_A)) ^ " used like that in friend"));
  3.3125 +
  3.3126 +    val substDT = Term.typ_subst_atomic (Ds ~~ res_Ds);
  3.3127 +
  3.3128 +    val old_sig_T0 = Type (old_sig_T_name, As);
  3.3129 +
  3.3130 +    val ((fp_b, version), lthy) = lthy |> get_name_next_version_of fpT_name;
  3.3131 +
  3.3132 +    val (((dead_k_bnf, sig_fp_sugar), ssig_fp_sugar), lthy) = lthy
  3.3133 +      |> bnf_with_deads_and_lives dead_Ds live_As Y fpT0 k_T0
  3.3134 +      ||>> define_sig_type fp_b version fp_alives Ds Y (mk_sumT (old_sig_T0, k_T0))
  3.3135 +      ||>> define_ssig_type fp_b version fp_alives Ds Y fpT0;
  3.3136 +
  3.3137 +    val _ = live_of_bnf dead_k_bnf = 1 orelse
  3.3138 +      error "Impossible type for friend (the result codatatype must occur live in the arguments)";
  3.3139 +
  3.3140 +    val (dead_pre_bnf, lthy) = lthy
  3.3141 +      |> bnf_kill_all_but 1 pre_bnf;
  3.3142 +
  3.3143 +    val sig_fp_ctr_sugar = #fp_ctr_sugar sig_fp_sugar;
  3.3144 +    val ssig_fp_ctr_sugar = #fp_ctr_sugar ssig_fp_sugar;
  3.3145 +
  3.3146 +    val sig_ctr_sugar = #ctr_sugar sig_fp_ctr_sugar;
  3.3147 +    val ssig_ctr_sugar = #ctr_sugar ssig_fp_ctr_sugar;
  3.3148 +
  3.3149 +    val ssig_T_name = fst (dest_Type (#T ssig_fp_sugar));
  3.3150 +
  3.3151 +    val preT = pre_type_of_ctor Y ctor;
  3.3152 +    val old_sig_T = substDT old_sig_T0;
  3.3153 +    val k_T = substDT k_T0;
  3.3154 +    val ssig_T = Type (ssig_T_name, res_As);
  3.3155 +
  3.3156 +    val Sig = mk_ctr res_As (the_single (#ctrs sig_ctr_sugar));
  3.3157 +
  3.3158 +    val [Oper, VLeaf, CLeaf] = map (mk_ctr res_As) (#ctrs ssig_ctr_sugar);
  3.3159 +    val (ctr_wrapper, friends) =
  3.3160 +      mk_ctr_wrapper_friends lthy friend_name friend_T old_sig_T k_T Sig old_buffer;
  3.3161 +
  3.3162 +    val buffer =
  3.3163 +      {Oper = Oper, VLeaf = VLeaf, CLeaf = CLeaf, ctr_wrapper = ctr_wrapper, friends = friends};
  3.3164 +  in
  3.3165 +    ((old_info, fp_b, version, Y, Z, preT, k_T, ssig_T, dead_pre_bnf, dead_k_bnf, sig_fp_sugar,
  3.3166 +      ssig_fp_sugar, buffer), lthy)
  3.3167 +  end;
  3.3168 +
  3.3169 +fun register_friend_corec key fp_b version Y Z k_T dead_k_bnf sig_fp_sugar ssig_fp_sugar
  3.3170 +    friend_const rho rho_transfer old_info lthy =
  3.3171 +  let
  3.3172 +    val friend_T = fastype_of friend_const;
  3.3173 +    val res_T = body_type friend_T;
  3.3174 +  in
  3.3175 +    derive_corecUU_step res_T old_info key friend_T fp_b version Y Z k_T dead_k_bnf sig_fp_sugar
  3.3176 +      ssig_fp_sugar rho rho_transfer lthy
  3.3177 +    |> (fn ((info, friend_info), lthy) => (friend_info, register_corec_info info lthy))
  3.3178 +  end;
  3.3179 +
  3.3180 +fun merge_corec_info_exprss exprs1 exprs2 lthy =
  3.3181 +  let
  3.3182 +    fun all_friend_names_of exprs =
  3.3183 +      fold (union (op =)) (map (#friend_names o corec_ad_of_expr) exprs) [];
  3.3184 +
  3.3185 +    val friend_names1 = all_friend_names_of exprs1;
  3.3186 +    val friend_names2 = all_friend_names_of exprs2;
  3.3187 +  in
  3.3188 +    if subset (op =) (friend_names2, friend_names1) then
  3.3189 +      if subset (op =) (friend_names1, friend_names2) andalso
  3.3190 +         length (filter is_Info exprs2) > length (filter is_Info exprs1) then
  3.3191 +        (exprs2, lthy)
  3.3192 +      else
  3.3193 +        (exprs1, lthy)
  3.3194 +    else if subset (op =) (friend_names1, friend_names2) then
  3.3195 +      (exprs2, lthy)
  3.3196 +    else
  3.3197 +      fold_rev (uncurry o insert_corec_info_expr) exprs2 (exprs1, lthy)
  3.3198 +  end;
  3.3199 +
  3.3200 +fun merge_corec_info_tabs info_tab1 info_tab2 lthy =
  3.3201 +  let
  3.3202 +    val fpT_names = union (op =) (Symtab.keys info_tab1) (Symtab.keys info_tab2);
  3.3203 +
  3.3204 +    fun add_infos_of fpT_name (info_tab, lthy) =
  3.3205 +      (case Symtab.lookup info_tab1 fpT_name of
  3.3206 +        NONE =>
  3.3207 +        (Symtab.update_new (fpT_name, the (Symtab.lookup info_tab2 fpT_name)) info_tab, lthy)
  3.3208 +      | SOME exprs1 =>
  3.3209 +        (case Symtab.lookup info_tab2 fpT_name of
  3.3210 +          NONE => (Symtab.update_new (fpT_name, exprs1) info_tab, lthy)
  3.3211 +        | SOME exprs2 =>
  3.3212 +          let val (exprs, lthy) = merge_corec_info_exprss exprs1 exprs2 lthy in
  3.3213 +            (Symtab.update_new (fpT_name, exprs) info_tab, lthy)
  3.3214 +          end));
  3.3215 +  in
  3.3216 +    fold add_infos_of fpT_names (Symtab.empty, lthy)
  3.3217 +  end;
  3.3218 +
  3.3219 +fun consolidate lthy =
  3.3220 +  (case snd (Data.get (Context.Proof lthy)) of
  3.3221 +    [_] => raise Same.SAME
  3.3222 +  | info_tab :: info_tabs =>
  3.3223 +    let
  3.3224 +      val (info_tab', lthy) = fold_rev (uncurry o merge_corec_info_tabs) info_tabs (info_tab, lthy);
  3.3225 +    in
  3.3226 +      Local_Theory.declaration {syntax = false, pervasive = true} (fn phi =>
  3.3227 +          Data.map (apsnd (fn _ => [Symtab.map (K (map (morph_corec_info_expr phi))) info_tab'])))
  3.3228 +        lthy
  3.3229 +    end);
  3.3230 +
  3.3231 +fun consolidate_global thy =
  3.3232 +  SOME (Named_Target.theory_map consolidate thy)
  3.3233 +  handle Same.SAME => NONE;
  3.3234 +
  3.3235 +val _ = Theory.setup (Theory.at_begin consolidate_global);
  3.3236 +
  3.3237 +end;
     4.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     4.2 +++ b/src/HOL/Tools/BNF/bnf_gfp_grec_sugar.ML	Tue Mar 22 12:39:37 2016 +0100
     4.3 @@ -0,0 +1,2412 @@
     4.4 +(*  Title:      HOL/Tools/BNF/bnf_gfp_grec_sugar.ML
     4.5 +    Author:     Aymeric Bouzy, Ecole polytechnique
     4.6 +    Author:     Jasmin Blanchette, Inria, LORIA, MPII
     4.7 +    Author:     Dmitriy Traytel, ETH Zürich
     4.8 +    Copyright   2015, 2016
     4.9 +
    4.10 +Generalized corecursor sugar ("corec" and friends).
    4.11 +*)
    4.12 +
    4.13 +signature BNF_GFP_GREC_SUGAR =
    4.14 +sig
    4.15 +  datatype corec_option =
    4.16 +    Plugins_Option of Proof.context -> Plugin_Name.filter |
    4.17 +    Friend_Option |
    4.18 +    Transfer_Option
    4.19 +
    4.20 +  val parse_corec_equation: Proof.context -> term list -> term -> term list * term
    4.21 +  val explore_corec_equation: Proof.context -> bool -> bool -> string -> term ->
    4.22 +    BNF_GFP_Grec_Sugar_Util.s_parse_info -> typ -> term list * term -> term list * term
    4.23 +  val build_corecUU_arg_and_goals: bool -> term -> term list * term -> local_theory ->
    4.24 +    (((thm list * thm list * thm list) * term list) * term) * local_theory
    4.25 +  val derive_eq_corecUU: Proof.context -> BNF_GFP_Grec.corec_info -> term -> term -> thm -> thm
    4.26 +  val derive_unique: Proof.context -> morphism -> term -> BNF_GFP_Grec.corec_info -> typ -> thm ->
    4.27 +    thm
    4.28 +
    4.29 +  val corec_cmd: corec_option list -> (binding * string option * mixfix) list * string ->
    4.30 +    local_theory -> local_theory
    4.31 +  val corecursive_cmd: corec_option list -> (binding * string option * mixfix) list * string ->
    4.32 +    local_theory -> Proof.state
    4.33 +  val friend_of_corec_cmd: (string * string option) * string -> local_theory -> Proof.state
    4.34 +  val coinduction_upto_cmd: string * string -> local_theory -> local_theory
    4.35 +end;
    4.36 +
    4.37 +structure BNF_GFP_Grec_Sugar : BNF_GFP_GREC_SUGAR =
    4.38 +struct
    4.39 +
    4.40 +open Ctr_Sugar
    4.41 +open BNF_Util
    4.42 +open BNF_Tactics
    4.43 +open BNF_Def
    4.44 +open BNF_Comp
    4.45 +open BNF_FP_Util
    4.46 +open BNF_FP_Def_Sugar
    4.47 +open BNF_FP_N2M_Sugar
    4.48 +open BNF_GFP_Rec_Sugar
    4.49 +open BNF_GFP_Util
    4.50 +open BNF_GFP_Grec
    4.51 +open BNF_GFP_Grec_Sugar_Util
    4.52 +open BNF_GFP_Grec_Sugar_Tactics
    4.53 +
    4.54 +val cong_N = "cong_";
    4.55 +val baseN = "base";
    4.56 +val reflN = "refl";
    4.57 +val symN = "sym";
    4.58 +val transN = "trans";
    4.59 +val cong_introsN = prefix cong_N "intros";
    4.60 +val cong_intros_friendN = "cong_intros_friend";
    4.61 +val codeN = "code";
    4.62 +val coinductN = "coinduct";
    4.63 +val coinduct_uptoN = "coinduct_upto";
    4.64 +val corecN = "corec";
    4.65 +val ctrN = "ctr";
    4.66 +val discN = "disc";
    4.67 +val disc_iffN = "disc_iff";
    4.68 +val eq_algrhoN = "eq_algrho";
    4.69 +val eq_corecUUN = "eq_corecUU";
    4.70 +val friendN = "friend";
    4.71 +val inner_elimN = "inner_elim";
    4.72 +val inner_inductN = "inner_induct";
    4.73 +val inner_simpN = "inner_simp";
    4.74 +val rhoN = "rho";
    4.75 +val selN = "sel";
    4.76 +val uniqueN = "unique";
    4.77 +
    4.78 +val inner_fp_suffix = "_inner_fp";
    4.79 +
    4.80 +val nitpicksimp_attrs = @{attributes [nitpick_simp]};
    4.81 +val simp_attrs = @{attributes [simp]};
    4.82 +val transfer_rule_attrs = @{attributes [transfer_rule]};
    4.83 +
    4.84 +val unfold_id_thms1 =
    4.85 +  map (fn thm => thm RS eq_reflection) @{thms id_bnf_o o_id_bnf id_apply o_apply} @
    4.86 +  @{thms fst_def[abs_def, symmetric] snd_def[abs_def, symmetric]};
    4.87 +
    4.88 +fun unfold_id_bnf_etc lthy =
    4.89 +  let val thy = Proof_Context.theory_of lthy in
    4.90 +    Raw_Simplifier.rewrite_term thy unfold_id_thms1 []
    4.91 +    #> Raw_Simplifier.rewrite_term thy @{thms BNF_Composition.id_bnf_def} []
    4.92 +  end;
    4.93 +
    4.94 +fun unexpected_corec_call ctxt eqns t =
    4.95 +  error_at ctxt eqns ("Unexpected corecursive call in " ^ quote (Syntax.string_of_term ctxt t));
    4.96 +fun unsupported_case_around_corec_call ctxt eqns t =
    4.97 +  error_at ctxt eqns ("Unsupported corecursive call under case expression " ^
    4.98 +    quote (Syntax.string_of_term ctxt t) ^ "\n(Define " ^
    4.99 +    quote (Syntax.string_of_typ ctxt (domain_type (fastype_of t))) ^
   4.100 +    " with  discriminators and selectors to circumvent this limitation.)");
   4.101 +
   4.102 +datatype corec_option =
   4.103 +  Plugins_Option of Proof.context -> Plugin_Name.filter |
   4.104 +  Friend_Option |
   4.105 +  Transfer_Option;
   4.106 +
   4.107 +val corec_option_parser = Parse.group (K "option")
   4.108 +  (Plugin_Name.parse_filter >> Plugins_Option
   4.109 +   || Parse.reserved "friend" >> K Friend_Option
   4.110 +   || Parse.reserved "transfer" >> K Transfer_Option);
   4.111 +
   4.112 +type codatatype_extra =
   4.113 +  {case_dtor: thm,
   4.114 +   case_trivial: thm,
   4.115 +   abs_rep_transfers: thm list};
   4.116 +
   4.117 +fun morph_codatatype_extra phi ({case_dtor, case_trivial, abs_rep_transfers} : codatatype_extra) =
   4.118 +  {case_dtor = Morphism.thm phi case_dtor, case_trivial = Morphism.thm phi case_trivial,
   4.119 +   abs_rep_transfers = map (Morphism.thm phi) abs_rep_transfers};
   4.120 +
   4.121 +val transfer_codatatype_extra = morph_codatatype_extra o Morphism.transfer_morphism;
   4.122 +
   4.123 +type coinduct_extra =
   4.124 +  {coinduct: thm,
   4.125 +   coinduct_attrs: Token.src list,
   4.126 +   cong_intro_tab: thm list Symtab.table};
   4.127 +
   4.128 +fun morph_coinduct_extra phi ({coinduct, coinduct_attrs, cong_intro_tab} : coinduct_extra) =
   4.129 +  {coinduct = Morphism.thm phi coinduct, coinduct_attrs = coinduct_attrs,
   4.130 +   cong_intro_tab = Symtab.map (K (Morphism.fact phi)) cong_intro_tab};
   4.131 +
   4.132 +val transfer_coinduct_extra = morph_coinduct_extra o Morphism.transfer_morphism;
   4.133 +
   4.134 +type friend_extra =
   4.135 +  {eq_algrhos: thm list,
   4.136 +   algrho_eqs: thm list};
   4.137 +
   4.138 +val empty_friend_extra = {eq_algrhos = [], algrho_eqs = []};
   4.139 +
   4.140 +fun merge_friend_extras ({eq_algrhos = eq_algrhos1, algrho_eqs = algrho_eqs1},
   4.141 +    {eq_algrhos = eq_algrhos2, algrho_eqs = algrho_eqs2}) =
   4.142 +  {eq_algrhos = union Thm.eq_thm_prop eq_algrhos1 eq_algrhos2,
   4.143 +   algrho_eqs = union Thm.eq_thm_prop algrho_eqs1 algrho_eqs2};
   4.144 +
   4.145 +type corec_sugar_data =
   4.146 +  codatatype_extra Symtab.table * coinduct_extra Symtab.table * friend_extra Symtab.table;
   4.147 +
   4.148 +structure Data = Generic_Data
   4.149 +(
   4.150 +  type T = corec_sugar_data;
   4.151 +  val empty = (Symtab.empty, Symtab.empty, Symtab.empty);
   4.152 +  val extend = I;
   4.153 +  fun merge data : T =
   4.154 +    (Symtab.merge (K true) (apply2 #1 data), Symtab.merge (K true) (apply2 #2 data),
   4.155 +     Symtab.join (K merge_friend_extras) (apply2 #3 data));
   4.156 +);
   4.157 +
   4.158 +fun register_codatatype_extra fpT_name extra =
   4.159 +  Local_Theory.declaration {syntax = false, pervasive = true} (fn phi =>
   4.160 +    Data.map (@{apply 3(1)} (Symtab.update (fpT_name, morph_codatatype_extra phi extra))));
   4.161 +
   4.162 +fun codatatype_extra_of ctxt =
   4.163 +  Symtab.lookup (#1 (Data.get (Context.Proof ctxt)))
   4.164 +  #> Option.map (transfer_codatatype_extra (Proof_Context.theory_of ctxt));
   4.165 +
   4.166 +fun all_codatatype_extras_of ctxt =
   4.167 +  Symtab.dest (#1 (Data.get (Context.Proof ctxt)));
   4.168 +
   4.169 +fun register_coinduct_extra fpT_name extra =
   4.170 +  Local_Theory.declaration {syntax = false, pervasive = true} (fn phi =>
   4.171 +    Data.map (@{apply 3(2)} (Symtab.update (fpT_name, morph_coinduct_extra phi extra))));
   4.172 +
   4.173 +fun coinduct_extra_of ctxt =
   4.174 +  Symtab.lookup (#2 (Data.get (Context.Proof ctxt)))
   4.175 +  #> Option.map (transfer_coinduct_extra (Proof_Context.theory_of ctxt));
   4.176 +
   4.177 +fun register_friend_extra fun_name eq_algrho algrho_eq =
   4.178 +  Local_Theory.declaration {syntax = false, pervasive = true} (fn phi =>
   4.179 +    Data.map (@{apply 3(3)} (Symtab.map_default (fun_name, empty_friend_extra)
   4.180 +      (fn {eq_algrhos, algrho_eqs} =>
   4.181 +        {eq_algrhos = Morphism.thm phi eq_algrho :: eq_algrhos,
   4.182 +         algrho_eqs = Morphism.thm phi algrho_eq :: algrho_eqs}))));
   4.183 +
   4.184 +fun all_friend_extras_of ctxt =
   4.185 +  Symtab.dest (#3 (Data.get (Context.Proof ctxt)));
   4.186 +
   4.187 +fun coinduct_extras_of_generic context =
   4.188 +  corec_infos_of_generic context
   4.189 +  #> map (#corecUU #> dest_Const #> fst #> Symtab.lookup (#2 (Data.get context)) #> the
   4.190 +    #> transfer_coinduct_extra (Context.theory_of context));
   4.191 +
   4.192 +fun get_coinduct_uptos fpT_name context =
   4.193 +  coinduct_extras_of_generic context fpT_name |> map #coinduct;
   4.194 +fun get_cong_all_intros fpT_name context =
   4.195 +  coinduct_extras_of_generic context fpT_name |> maps (#cong_intro_tab #> Symtab.dest #> maps snd);
   4.196 +fun get_cong_intros fpT_name name context =
   4.197 +  coinduct_extras_of_generic context fpT_name
   4.198 +  |> maps (#cong_intro_tab #> (fn tab => Symtab.lookup_list tab name));
   4.199 +
   4.200 +fun ctr_names_of_fp_name lthy fpT_name =
   4.201 +  fpT_name |> fp_sugar_of lthy |> the |> #fp_ctr_sugar |> #ctr_sugar |> #ctrs
   4.202 +  |> map (Long_Name.base_name o name_of_ctr);
   4.203 +
   4.204 +fun register_coinduct_dynamic_base fpT_name lthy =
   4.205 +  let val fp_b = Binding.name (Long_Name.base_name fpT_name) in
   4.206 +    lthy
   4.207 +    |> fold Local_Theory.add_thms_dynamic
   4.208 +      ((mk_fp_binding fp_b coinduct_uptoN, get_coinduct_uptos fpT_name) ::
   4.209 +        map (fn N =>
   4.210 +          let val N = cong_N ^ N in
   4.211 +            (mk_fp_binding fp_b N, get_cong_intros fpT_name N)
   4.212 +          end)
   4.213 +        ([baseN, reflN, symN, transN] @ ctr_names_of_fp_name lthy fpT_name))
   4.214 +    |> Local_Theory.add_thms_dynamic
   4.215 +      (mk_fp_binding fp_b cong_introsN, get_cong_all_intros fpT_name)
   4.216 +  end;
   4.217 +
   4.218 +fun register_coinduct_dynamic_friend fpT_name friend_name =
   4.219 +  let
   4.220 +    val fp_b = Binding.name (Long_Name.base_name fpT_name);
   4.221 +    val friend_base_name = cong_N ^ Long_Name.base_name friend_name;
   4.222 +  in
   4.223 +    Local_Theory.add_thms_dynamic
   4.224 +      (mk_fp_binding fp_b friend_base_name, get_cong_intros fpT_name friend_base_name)
   4.225 +  end;
   4.226 +
   4.227 +fun derive_case_dtor ctxt fpT_name =
   4.228 +  let
   4.229 +    val thy = Proof_Context.theory_of ctxt;
   4.230 +
   4.231 +    val SOME ({fp_res_index, fp_res = {dtors, dtor_ctors, ...},
   4.232 +        absT_info = {rep = rep0, abs_inverse, ...},
   4.233 +        fp_ctr_sugar = {ctr_defs, ctr_sugar = {casex, exhaust, case_thms, ...}, ...}, ...}) =
   4.234 +      fp_sugar_of ctxt fpT_name;
   4.235 +
   4.236 +    val (f_Ts, Type (_, [fpT, _])) = strip_fun_type (fastype_of casex);
   4.237 +    val x_Tss = map binder_types f_Ts;
   4.238 +
   4.239 +    val (((u, fs), xss), _) = ctxt
   4.240 +      |> yield_singleton (mk_Frees "y") fpT
   4.241 +      ||>> mk_Frees "f" f_Ts
   4.242 +      ||>> mk_Freess "x" x_Tss;
   4.243 +
   4.244 +    val dtor = nth dtors fp_res_index;
   4.245 +    val u' = dtor $ u;
   4.246 +
   4.247 +    val absT = fastype_of u';
   4.248 +
   4.249 +    val rep = mk_rep absT rep0;
   4.250 +
   4.251 +    val goal = mk_Trueprop_eq (list_comb (casex, fs) $ u,
   4.252 +        mk_case_absumprod absT rep fs xss xss $ u')
   4.253 +      |> Raw_Simplifier.rewrite_term thy @{thms comp_def[THEN eq_reflection]} [];
   4.254 +    val vars = map (fst o dest_Free) (u :: fs);
   4.255 +
   4.256 +    val dtor_ctor = nth dtor_ctors fp_res_index;
   4.257 +  in
   4.258 +    Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
   4.259 +      mk_case_dtor_tac ctxt u abs_inverse dtor_ctor ctr_defs exhaust case_thms)
   4.260 +    |> Thm.close_derivation
   4.261 +  end;
   4.262 +
   4.263 +fun derive_case_trivial ctxt fpT_name =
   4.264 +  let
   4.265 +    val SOME {casex, exhaust, case_thms, ...} = ctr_sugar_of ctxt fpT_name;
   4.266 +
   4.267 +    val fpT0 as Type (_, As0) = domain_type (body_fun_type (fastype_of casex));
   4.268 +
   4.269 +    val (As, _) = ctxt
   4.270 +      |> mk_TFrees (length As0);
   4.271 +    val fpT = Type (fpT_name, As);
   4.272 +
   4.273 +    val (var_name, ()) = singleton (Variable.variant_frees ctxt []) ("x", ());
   4.274 +    val var = Free (var_name, fpT);
   4.275 +    val goal = mk_Trueprop_eq (expand_to_ctr_term ctxt fpT var, var);
   4.276 +
   4.277 +    val exhaust' = Drule.infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt var)] exhaust;
   4.278 +  in
   4.279 +    Goal.prove_sorry ctxt [var_name] [] goal (fn {context = ctxt, prems = _} =>
   4.280 +      HEADGOAL (rtac ctxt exhaust') THEN ALLGOALS (hyp_subst_tac ctxt) THEN
   4.281 +      unfold_thms_tac ctxt case_thms THEN ALLGOALS (rtac ctxt refl))
   4.282 +    |> Thm.close_derivation
   4.283 +  end;
   4.284 +
   4.285 +fun mk_abs_rep_transfers ctxt fpT_name =
   4.286 +  [mk_abs_transfer ctxt fpT_name, mk_rep_transfer ctxt fpT_name]
   4.287 +  handle Fail _ => [];
   4.288 +
   4.289 +fun set_transfer_rule_attrs thms =
   4.290 +  snd o Local_Theory.notes [((Binding.empty, []), [(thms, transfer_rule_attrs)])];
   4.291 +
   4.292 +fun ensure_codatatype_extra fpT_name ctxt =
   4.293 +  (case codatatype_extra_of ctxt fpT_name of
   4.294 +    NONE =>
   4.295 +    let val abs_rep_transfers = mk_abs_rep_transfers ctxt fpT_name in
   4.296 +      ctxt
   4.297 +      |> register_codatatype_extra fpT_name
   4.298 +        {case_dtor = derive_case_dtor ctxt fpT_name,
   4.299 +         case_trivial = derive_case_trivial ctxt fpT_name,
   4.300 +         abs_rep_transfers = abs_rep_transfers}
   4.301 +      |> set_transfer_rule_attrs abs_rep_transfers
   4.302 +    end
   4.303 +  | SOME {abs_rep_transfers, ...} => ctxt |> set_transfer_rule_attrs abs_rep_transfers);
   4.304 +
   4.305 +fun setup_base fpT_name =
   4.306 +  register_coinduct_dynamic_base fpT_name
   4.307 +  #> ensure_codatatype_extra fpT_name;
   4.308 +
   4.309 +(*TODO: Merge with primcorec "case_of"*)
   4.310 +fun case_of ctxt fcT_name =
   4.311 +  (case ctr_sugar_of ctxt fcT_name of
   4.312 +    SOME {casex = Const (s, _), ...} => SOME s
   4.313 +  | _ => NONE);
   4.314 +
   4.315 +fun is_set ctxt (const_name, T) =
   4.316 +  (case T of
   4.317 +    Type (@{type_name fun}, [Type (fpT_name, _), Type (@{type_name set}, [_])]) =>
   4.318 +    (case bnf_of ctxt fpT_name of
   4.319 +      SOME bnf => exists (fn Const (s, _) => s = const_name | _ => false) (sets_of_bnf bnf)
   4.320 +    | NONE => false)
   4.321 +  | _ => false);
   4.322 +
   4.323 +fun case_eq_if_thms_of_term ctxt t =
   4.324 +  let val ctr_sugars = map_filter (ctr_sugar_of_case ctxt o fst) (Term.add_consts t []) in
   4.325 +    maps #case_eq_ifs ctr_sugars
   4.326 +  end;
   4.327 +
   4.328 +fun all_algrho_eqs_of ctxt =
   4.329 +  maps (#algrho_eqs o snd) (all_friend_extras_of ctxt);
   4.330 +
   4.331 +fun derive_code ctxt inner_fp_simps goal
   4.332 +    {sig_fp_sugars, ssig_fp_sugar, eval, eval_simps, all_algLam_algs, corecUU_thm, ...} res_T fun_t
   4.333 +    fun_def =
   4.334 +  let
   4.335 +    val fun_T = fastype_of fun_t;
   4.336 +    val (arg_Ts, Type (fpT_name, _)) = strip_type fun_T;
   4.337 +    val num_args = length arg_Ts;
   4.338 +
   4.339 +    val SOME {pre_bnf, fp_bnf, absT_info, fp_nesting_bnfs, live_nesting_bnfs, fp_ctr_sugar, ...} =
   4.340 +      fp_sugar_of ctxt fpT_name;
   4.341 +    val SOME {case_trivial, ...} = codatatype_extra_of ctxt fpT_name;
   4.342 +
   4.343 +    val ctr_sugar = #ctr_sugar fp_ctr_sugar;
   4.344 +    val pre_map_def = map_def_of_bnf pre_bnf;
   4.345 +    val abs_inverse = #abs_inverse absT_info;
   4.346 +    val ctr_defs = #ctr_defs fp_ctr_sugar;
   4.347 +    val case_eq_ifs = #case_eq_ifs ctr_sugar @ case_eq_if_thms_of_term ctxt goal;
   4.348 +    val all_sig_map_thms = maps (#map_thms o #fp_bnf_sugar) sig_fp_sugars;
   4.349 +
   4.350 +    val fp_map_ident = map_ident_of_bnf fp_bnf;
   4.351 +    val fpsig_nesting_bnfs = fp_nesting_bnfs @ maps #live_nesting_bnfs sig_fp_sugars;
   4.352 +    val fpsig_nesting_T_names = map (fst o dest_Type o T_of_bnf) fpsig_nesting_bnfs;
   4.353 +    val fpsig_nesting_fp_sugars = map_filter (fp_sugar_of ctxt) fpsig_nesting_T_names;
   4.354 +    val fpsig_nesting_fp_bnf_sugars = map #fp_bnf_sugar fpsig_nesting_fp_sugars;
   4.355 +    val ssig_fp_bnf_sugar = #fp_bnf_sugar ssig_fp_sugar;
   4.356 +    val ssig_bnf = #fp_bnf ssig_fp_sugar;
   4.357 +    val ssig_map = map_of_bnf ssig_bnf;
   4.358 +    val fpsig_nesting_maps = map map_of_bnf fpsig_nesting_bnfs;
   4.359 +    val fpsig_nesting_map_ident0s = map map_ident0_of_bnf fpsig_nesting_bnfs;
   4.360 +    val fpsig_nesting_map_comps = map map_comp_of_bnf fpsig_nesting_bnfs;
   4.361 +    val fpsig_nesting_map_thms = maps #map_thms fpsig_nesting_fp_bnf_sugars;
   4.362 +    val live_nesting_map_ident0s = map map_ident0_of_bnf live_nesting_bnfs;
   4.363 +    val ssig_map_thms = #map_thms ssig_fp_bnf_sugar;
   4.364 +    val all_algLam_alg_pointfuls = map (mk_pointful ctxt) all_algLam_algs;
   4.365 +  in
   4.366 +    Variable.add_free_names ctxt goal []
   4.367 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
   4.368 +      mk_code_tac ctxt num_args fpsig_nesting_maps ssig_map eval pre_map_def abs_inverse
   4.369 +        fpsig_nesting_map_ident0s fpsig_nesting_map_comps fpsig_nesting_map_thms
   4.370 +        live_nesting_map_ident0s fp_map_ident case_trivial ctr_defs case_eq_ifs corecUU_thm
   4.371 +        all_sig_map_thms ssig_map_thms all_algLam_alg_pointfuls (all_algrho_eqs_of ctxt) eval_simps
   4.372 +        inner_fp_simps fun_def))
   4.373 +    |> Thm.close_derivation
   4.374 +  end;
   4.375 +
   4.376 +fun derive_unique ctxt phi code_goal
   4.377 +    {sig_fp_sugars, ssig_fp_sugar, eval, eval_simps, all_algLam_algs, corecUU_unique, ...}
   4.378 +    (res_T as Type (fpT_name, _)) eq_corecUU =
   4.379 +  let
   4.380 +    val SOME {pre_bnf, fp_bnf, absT_info, fp_nesting_bnfs, live_nesting_bnfs, fp_ctr_sugar, ...} =
   4.381 +      fp_sugar_of ctxt fpT_name;
   4.382 +    val SOME {case_trivial, ...} = codatatype_extra_of ctxt fpT_name;
   4.383 +
   4.384 +    val ctr_sugar = #ctr_sugar fp_ctr_sugar;
   4.385 +    val pre_map_def = map_def_of_bnf pre_bnf;
   4.386 +    val abs_inverse = #abs_inverse absT_info;
   4.387 +    val ctr_defs = #ctr_defs fp_ctr_sugar;
   4.388 +    val case_eq_ifs = #case_eq_ifs ctr_sugar @ case_eq_if_thms_of_term ctxt code_goal;
   4.389 +    val all_sig_map_thms = maps (#map_thms o #fp_bnf_sugar) sig_fp_sugars;
   4.390 +
   4.391 +    val fp_map_ident = map_ident_of_bnf fp_bnf;
   4.392 +    val fpsig_nesting_bnfs = fp_nesting_bnfs @ maps #live_nesting_bnfs sig_fp_sugars;
   4.393 +    val fpsig_nesting_T_names = map (fst o dest_Type o T_of_bnf) fpsig_nesting_bnfs;
   4.394 +    val fpsig_nesting_fp_sugars = map_filter (fp_sugar_of ctxt) fpsig_nesting_T_names;
   4.395 +    val fpsig_nesting_fp_bnf_sugars = map #fp_bnf_sugar fpsig_nesting_fp_sugars;
   4.396 +    val ssig_fp_bnf_sugar = #fp_bnf_sugar ssig_fp_sugar;
   4.397 +    val ssig_bnf = #fp_bnf ssig_fp_sugar;
   4.398 +    val ssig_map = map_of_bnf ssig_bnf;
   4.399 +    val fpsig_nesting_maps = map map_of_bnf fpsig_nesting_bnfs;
   4.400 +    val fpsig_nesting_map_ident0s = map map_ident0_of_bnf fpsig_nesting_bnfs;
   4.401 +    val fpsig_nesting_map_comps = map map_comp_of_bnf fpsig_nesting_bnfs;
   4.402 +    val fpsig_nesting_map_thms = maps #map_thms fpsig_nesting_fp_bnf_sugars;
   4.403 +    val live_nesting_map_ident0s = map map_ident0_of_bnf live_nesting_bnfs;
   4.404 +    val ssig_map_thms = #map_thms ssig_fp_bnf_sugar;
   4.405 +    val all_algLam_alg_pointfuls = map (mk_pointful ctxt) all_algLam_algs;
   4.406 +
   4.407 +    val @{const Trueprop} $ (Const (@{const_name HOL.eq}, _) $ lhs $ rhs) = code_goal;
   4.408 +    val (fun_t, args) = strip_comb lhs;
   4.409 +    val closed_rhs = fold_rev lambda args rhs;
   4.410 +
   4.411 +    val fun_T = fastype_of fun_t;
   4.412 +    val num_args = num_binder_types fun_T;
   4.413 +
   4.414 +    val f = Free (singleton (Variable.variant_frees ctxt []) ("f", fun_T));
   4.415 +
   4.416 +    val is_self_call = curry (op aconv) fun_t;
   4.417 +    val has_self_call = exists_subterm is_self_call;
   4.418 +
   4.419 +    fun fify args (t $ u) = fify (u :: args) t $ fify [] u
   4.420 +      | fify _ (Abs (s, T, t)) = Abs (s, T, fify [] t)
   4.421 +      | fify args t = if t = fun_t andalso not (exists has_self_call args) then f else t;
   4.422 +
   4.423 +    val goal = Logic.mk_implies (mk_Trueprop_eq (f, fify [] closed_rhs), mk_Trueprop_eq (f, fun_t))
   4.424 +      |> Morphism.term phi;
   4.425 +  in
   4.426 +    Goal.prove_sorry ctxt [fst (dest_Free f)] [] goal (fn {context = ctxt, prems = _} =>
   4.427 +      mk_unique_tac ctxt num_args fpsig_nesting_maps ssig_map eval pre_map_def abs_inverse
   4.428 +        fpsig_nesting_map_ident0s fpsig_nesting_map_comps fpsig_nesting_map_thms
   4.429 +        live_nesting_map_ident0s fp_map_ident case_trivial ctr_defs case_eq_ifs all_sig_map_thms
   4.430 +        ssig_map_thms all_algLam_alg_pointfuls (all_algrho_eqs_of ctxt) eval_simps corecUU_unique
   4.431 +        eq_corecUU)
   4.432 +    |> Thm.close_derivation
   4.433 +  end;
   4.434 +
   4.435 +fun derive_last_disc ctxt fcT_name =
   4.436 +  let
   4.437 +    val SOME {T = fcT, discs, exhaust, disc_thmss, ...} = ctr_sugar_of ctxt fcT_name;
   4.438 +
   4.439 +    val (u, _) = ctxt
   4.440 +      |> yield_singleton (mk_Frees "x") fcT;
   4.441 +
   4.442 +    val udiscs = map (rapp u) discs;
   4.443 +    val (not_udiscs, last_udisc) = split_last udiscs
   4.444 +      |>> map HOLogic.mk_not;
   4.445 +
   4.446 +    val goal = mk_Trueprop_eq (last_udisc, foldr1 HOLogic.mk_conj not_udiscs);
   4.447 +  in
   4.448 +    Goal.prove_sorry ctxt [fst (dest_Free u)] [] goal (fn {context = ctxt, prems = _} =>
   4.449 +      mk_last_disc_tac ctxt u exhaust (flat disc_thmss))
   4.450 +    |> Thm.close_derivation
   4.451 +  end;
   4.452 +
   4.453 +fun derive_eq_algrho ctxt {sig_fp_sugars, ssig_fp_sugar, eval, eval_simps, all_algLam_algs,
   4.454 +      corecUU_unique, ...}
   4.455 +    ({algrho = algrho0, dtor_algrho, ...} : friend_info) fun_t k_T code_goal const_transfers rho_def
   4.456 +    eq_corecUU =
   4.457 +  let
   4.458 +    val fun_T = fastype_of fun_t;
   4.459 +    val (arg_Ts, Type (fpT_name, Ts)) = strip_type fun_T;
   4.460 +    val num_args = length arg_Ts;
   4.461 +
   4.462 +    val SOME {fp_res_index, fp_res, pre_bnf, fp_bnf, absT_info, fp_nesting_bnfs, live_nesting_bnfs,
   4.463 +        fp_ctr_sugar, ...} =
   4.464 +      fp_sugar_of ctxt fpT_name;
   4.465 +    val SOME {case_dtor, ...} = codatatype_extra_of ctxt fpT_name;
   4.466 +
   4.467 +    val fp_nesting_Ts = map T_of_bnf fp_nesting_bnfs;
   4.468 +
   4.469 +    fun is_nullary_disc_def (@{const Trueprop} $ (Const (@{const_name HOL.eq}, _) $ _
   4.470 +          $ (Const (@{const_name HOL.eq}, _) $ _ $ _))) = true
   4.471 +      | is_nullary_disc_def (Const (@{const_name Pure.eq}, _) $ _
   4.472 +          $ (Const (@{const_name HOL.eq}, _) $ _ $ _)) = true
   4.473 +      | is_nullary_disc_def _ = false;
   4.474 +
   4.475 +    val dtor_ctor = nth (#dtor_ctors fp_res) fp_res_index;
   4.476 +    val ctor_iff_dtor = #ctor_iff_dtor fp_ctr_sugar;
   4.477 +    val ctr_sugar = #ctr_sugar fp_ctr_sugar;
   4.478 +    val pre_map_def = map_def_of_bnf pre_bnf;
   4.479 +    val abs_inverse = #abs_inverse absT_info;
   4.480 +    val ctr_defs = #ctr_defs fp_ctr_sugar;
   4.481 +    val nullary_disc_defs = filter (is_nullary_disc_def o Thm.prop_of) (#disc_defs ctr_sugar);
   4.482 +    val disc_sel_eq_cases = #disc_eq_cases ctr_sugar @ #sel_defs ctr_sugar;
   4.483 +    val case_eq_ifs = #case_eq_ifs ctr_sugar @ case_eq_if_thms_of_term ctxt code_goal;
   4.484 +    val all_sig_map_thms = maps (#map_thms o #fp_bnf_sugar) sig_fp_sugars;
   4.485 +
   4.486 +    fun add_tnameT (Type (s, Ts)) = insert (op =) s #> fold add_tnameT Ts
   4.487 +      | add_tnameT _ = I;
   4.488 +
   4.489 +    fun map_disc_sels'_of s =
   4.490 +      (case fp_sugar_of ctxt s of
   4.491 +        SOME {fp_bnf_sugar = {map_disc_iffs, map_selss, ...}, ...} =>
   4.492 +        let
   4.493 +          val map_selss' =
   4.494 +            if length map_selss <= 1 then map_selss
   4.495 +            else map (map (unfold_thms ctxt (no_refl [derive_last_disc ctxt s]))) map_selss;
   4.496 +        in
   4.497 +          map_disc_iffs @ flat map_selss'
   4.498 +        end
   4.499 +      | NONE => []);
   4.500 +
   4.501 +    fun mk_const_pointful_natural const_transfer =
   4.502 +      SOME (mk_pointful_natural_from_transfer ctxt const_transfer)
   4.503 +      handle UNNATURAL () => NONE;
   4.504 +
   4.505 +    val const_pointful_natural_opts = map mk_const_pointful_natural const_transfers;
   4.506 +    val const_pointful_naturals = map_filter I const_pointful_natural_opts;
   4.507 +    val fp_nesting_k_T_names = fold add_tnameT (k_T :: fp_nesting_Ts) [];
   4.508 +    val fp_nesting_k_map_disc_sels' = maps map_disc_sels'_of fp_nesting_k_T_names;
   4.509 +
   4.510 +    val fp_map_ident = map_ident_of_bnf fp_bnf;
   4.511 +    val fpsig_nesting_bnfs = fp_nesting_bnfs @ maps #live_nesting_bnfs sig_fp_sugars;
   4.512 +    val fpsig_nesting_T_names = map (fst o dest_Type o T_of_bnf) fpsig_nesting_bnfs;
   4.513 +    val fpsig_nesting_fp_sugars = map_filter (fp_sugar_of ctxt) fpsig_nesting_T_names;
   4.514 +    val fpsig_nesting_fp_bnf_sugars = map #fp_bnf_sugar fpsig_nesting_fp_sugars;
   4.515 +    val ssig_fp_bnf_sugar = #fp_bnf_sugar ssig_fp_sugar;
   4.516 +    val ssig_bnf = #fp_bnf ssig_fp_sugar;
   4.517 +    val ssig_map = map_of_bnf ssig_bnf;
   4.518 +    val fpsig_nesting_maps = map map_of_bnf fpsig_nesting_bnfs;
   4.519 +    val fpsig_nesting_map_ident0s = map map_ident0_of_bnf fpsig_nesting_bnfs;
   4.520 +    val fpsig_nesting_map_comps = map map_comp_of_bnf fpsig_nesting_bnfs;
   4.521 +    val fpsig_nesting_map_thms = maps #map_thms fpsig_nesting_fp_bnf_sugars;
   4.522 +    val live_nesting_map_ident0s = map map_ident0_of_bnf live_nesting_bnfs;
   4.523 +    val ssig_map_thms = #map_thms ssig_fp_bnf_sugar;
   4.524 +    val all_algLam_alg_pointfuls = map (mk_pointful ctxt) all_algLam_algs;
   4.525 +
   4.526 +    val ctor = nth (#ctors fp_res) fp_res_index;
   4.527 +    val abs = #abs absT_info;
   4.528 +    val rep = #rep absT_info;
   4.529 +    val algrho = mk_ctr Ts algrho0;
   4.530 +
   4.531 +    val goal = mk_Trueprop_eq (fun_t, abs_curried_balanced arg_Ts algrho);
   4.532 +
   4.533 +    fun const_of_transfer thm =
   4.534 +      (case Thm.prop_of thm of @{const Trueprop} $ (_ $ cst $ _) => cst);
   4.535 +
   4.536 +    val eq_algrho =
   4.537 +      Goal.prove_sorry (*FIXME*) (*no sorry*) ctxt [] [] goal (fn {context = ctxt, prems = _} =>
   4.538 +        mk_eq_algrho_tac ctxt fpsig_nesting_maps abs rep ctor ssig_map eval pre_map_def abs_inverse
   4.539 +          fpsig_nesting_map_ident0s fpsig_nesting_map_comps fpsig_nesting_map_thms
   4.540 +          live_nesting_map_ident0s fp_map_ident dtor_ctor ctor_iff_dtor ctr_defs nullary_disc_defs
   4.541 +          disc_sel_eq_cases case_dtor case_eq_ifs const_pointful_naturals
   4.542 +          fp_nesting_k_map_disc_sels' rho_def dtor_algrho corecUU_unique eq_corecUU all_sig_map_thms
   4.543 +          ssig_map_thms all_algLam_alg_pointfuls (all_algrho_eqs_of ctxt) eval_simps)
   4.544 +      |> Thm.close_derivation
   4.545 +      handle e as ERROR _ =>
   4.546 +        (case filter (is_none o snd) (const_transfers ~~ const_pointful_natural_opts) of
   4.547 +          [] => Exn.reraise e
   4.548 +        | thm_nones =>
   4.549 +          error ("Failed to state naturality property for " ^
   4.550 +            commas (map (Syntax.string_of_term ctxt o const_of_transfer o fst) thm_nones)));
   4.551 +
   4.552 +    val algrho_eq = eq_algrho RS (mk_curry_uncurryN_balanced ctxt num_args RS iffD2) RS sym;
   4.553 +  in
   4.554 +    (eq_algrho, algrho_eq)
   4.555 +  end;
   4.556 +
   4.557 +fun prime_rho_transfer_goal ctxt fpT_name rho_def goal =
   4.558 +  let
   4.559 +    val thy = Proof_Context.theory_of ctxt;
   4.560 +
   4.561 +    val SOME {pre_bnf, ...} = fp_sugar_of ctxt fpT_name;
   4.562 +    val SOME {abs_rep_transfers, ...} = codatatype_extra_of ctxt fpT_name;
   4.563 +
   4.564 +    val simps = rel_def_of_bnf pre_bnf :: rho_transfer_simps;
   4.565 +    val fold_rho = unfold_thms ctxt [rho_def RS @{thm symmetric}];
   4.566 +
   4.567 +    fun derive_unprimed rho_transfer' =
   4.568 +      Variable.add_free_names ctxt goal []
   4.569 +      |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
   4.570 +        unfold_thms_tac ctxt simps THEN HEADGOAL (rtac ctxt rho_transfer')))
   4.571 +      |> Thm.close_derivation;
   4.572 +
   4.573 +    val goal' = Raw_Simplifier.rewrite_term thy simps [] goal;
   4.574 +  in
   4.575 +    if null abs_rep_transfers then (goal', derive_unprimed #> fold_rho)
   4.576 +    else (goal, fold_rho)
   4.577 +  end;
   4.578 +
   4.579 +fun derive_rho_transfer_folded ctxt fpT_name const_transfers rho_def goal =
   4.580 +  let
   4.581 +    val SOME {pre_bnf, ...} = fp_sugar_of ctxt fpT_name;
   4.582 +    val SOME {abs_rep_transfers, ...} = codatatype_extra_of ctxt fpT_name;
   4.583 +  in
   4.584 +    Variable.add_free_names ctxt goal []
   4.585 +    |> (fn vars => Goal.prove_sorry (*FIXME*) (*no sorry*) ctxt vars [] goal (fn {context = ctxt, prems = _} =>
   4.586 +      mk_rho_transfer_tac ctxt (null abs_rep_transfers) (rel_def_of_bnf pre_bnf)
   4.587 +      const_transfers))
   4.588 +    |> unfold_thms ctxt [rho_def RS @{thm symmetric}]
   4.589 +    |> Thm.close_derivation
   4.590 +  end;
   4.591 +
   4.592 +fun mk_cong_intro_ctr_or_friend_goal ctxt fpT Rcong alg =
   4.593 +  let
   4.594 +    val xy_Ts = binder_types (fastype_of alg);
   4.595 +
   4.596 +    val ((xs, ys), _) = ctxt
   4.597 +      |> mk_Frees "x" xy_Ts
   4.598 +      ||>> mk_Frees "y" xy_Ts;
   4.599 +
   4.600 +    fun mk_prem xy_T x y =
   4.601 +      BNF_Def.build_rel [] ctxt [fpT]
   4.602 +        (fn (T, _) => if T = fpT then Rcong else HOLogic.eq_const T) (xy_T, xy_T) $ x $ y;
   4.603 +
   4.604 +    val prems = @{map 3} mk_prem xy_Ts xs ys;
   4.605 +    val concl = Rcong $ list_comb (alg, xs) $ list_comb (alg, ys);
   4.606 +  in
   4.607 +    Logic.list_implies (map HOLogic.mk_Trueprop prems, HOLogic.mk_Trueprop concl)
   4.608 +  end;
   4.609 +
   4.610 +fun derive_cong_ctr_intros ctxt cong_ctor_intro =
   4.611 +  let
   4.612 +    val @{const Pure.imp} $ _ $ (@{const Trueprop} $ ((Rcong as _ $ _) $ _ $ (ctor $ _))) =
   4.613 +      Thm.prop_of cong_ctor_intro;
   4.614 +
   4.615 +    val fpT as Type (fpT_name, fp_argTs) = range_type (fastype_of ctor);
   4.616 +
   4.617 +    val SOME {pre_bnf, absT_info = {abs_inverse, ...},
   4.618 +        fp_ctr_sugar = {ctr_defs, ctr_sugar = {ctrs = ctrs0, ...}, ...}, ...} =
   4.619 +      fp_sugar_of ctxt fpT_name;
   4.620 +
   4.621 +    val ctrs = map (mk_ctr fp_argTs) ctrs0;
   4.622 +    val pre_rel_def = rel_def_of_bnf pre_bnf;
   4.623 +
   4.624 +    fun prove ctr_def goal =
   4.625 +      Variable.add_free_names ctxt goal []
   4.626 +      |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
   4.627 +        mk_cong_intro_ctr_or_friend_tac ctxt ctr_def [pre_rel_def, abs_inverse] cong_ctor_intro))
   4.628 +      |> Thm.close_derivation;
   4.629 +
   4.630 +    val goals = map (mk_cong_intro_ctr_or_friend_goal ctxt fpT Rcong) ctrs;
   4.631 +  in
   4.632 +    map2 prove ctr_defs goals
   4.633 +  end;
   4.634 +
   4.635 +fun derive_cong_friend_intro ctxt cong_algrho_intro =
   4.636 +  let
   4.637 +    val @{const Pure.imp} $ _ $ (@{const Trueprop} $ ((Rcong as _ $ _) $ _
   4.638 +        $ ((algrho as Const (algrho_name, _)) $ _))) =
   4.639 +      Thm.prop_of cong_algrho_intro;
   4.640 +
   4.641 +    val fpT as Type (_, fp_argTs) = range_type (fastype_of algrho);
   4.642 +
   4.643 +    fun has_algrho (@{const Trueprop} $ (Const (@{const_name HOL.eq}, _) $ _ $ rhs)) =
   4.644 +      fst (dest_Const (head_of (strip_abs_body rhs))) = algrho_name;
   4.645 +
   4.646 +    val eq_algrho :: _ =
   4.647 +      maps (filter (has_algrho o Thm.prop_of) o #eq_algrhos o snd) (all_friend_extras_of ctxt);
   4.648 +
   4.649 +    val @{const Trueprop} $ (Const (@{const_name HOL.eq}, _) $ friend0 $ _) = Thm.prop_of eq_algrho;
   4.650 +    val friend = mk_ctr fp_argTs friend0;
   4.651 +
   4.652 +    val goal = mk_cong_intro_ctr_or_friend_goal ctxt fpT Rcong friend;
   4.653 +  in
   4.654 +    Variable.add_free_names ctxt goal []
   4.655 +    |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
   4.656 +      mk_cong_intro_ctr_or_friend_tac ctxt eq_algrho [] cong_algrho_intro))
   4.657 +    |> Thm.close_derivation
   4.658 +  end;
   4.659 +
   4.660 +fun derive_cong_intros lthy ctr_names friend_names
   4.661 +    ({cong_base, cong_refl, cong_sym, cong_trans, cong_alg_intros, ...} : dtor_coinduct_info) =
   4.662 +  let
   4.663 +    val cong_ctor_intro :: cong_algrho_intros = rev cong_alg_intros;
   4.664 +    val names = map (prefix cong_N) ([baseN, reflN, symN, transN] @ ctr_names @ friend_names);
   4.665 +    val thms = [cong_base, cong_refl, cong_sym, cong_trans] @
   4.666 +      derive_cong_ctr_intros lthy cong_ctor_intro @
   4.667 +      map (derive_cong_friend_intro lthy) cong_algrho_intros;
   4.668 +  in
   4.669 +    Symtab.make_list (names ~~ thms)
   4.670 +  end;
   4.671 +
   4.672 +fun derive_coinduct ctxt (fpT as Type (fpT_name, _)) dtor_coinduct =
   4.673 +  let
   4.674 +    val thy = Proof_Context.theory_of ctxt;
   4.675 +
   4.676 +    val @{const Pure.imp} $ (@{const Trueprop} $ (_ $ Abs (_, _, _ $
   4.677 +        Abs (_, _, @{const implies} $ _ $ (_ $ (cong0 $ _) $ _ $ _))))) $ _ =
   4.678 +      Thm.prop_of dtor_coinduct;
   4.679 +
   4.680 +    val SOME {X as TVar ((X_s, _), _), fp_res = {dtor_ctors, ...}, pre_bnf,
   4.681 +        absT_info = {abs_inverse, ...}, live_nesting_bnfs,
   4.682 +        fp_ctr_sugar = {ctrXs_Tss, ctr_defs,
   4.683 +          ctr_sugar = ctr_sugar0 as {T = T0, ctrs = ctrs0, discs = discs0, ...}, ...}, ...} =
   4.684 +      fp_sugar_of ctxt fpT_name;
   4.685 +
   4.686 +    val n = length ctrXs_Tss;
   4.687 +    val ms = map length ctrXs_Tss;
   4.688 +
   4.689 +    val X' = TVar ((X_s, maxidx_of_typ fpT + 1), @{sort type});
   4.690 +    val As_rho = tvar_subst thy [T0] [fpT];
   4.691 +    val substXAT = Term.typ_subst_TVars As_rho o Tsubst X X';
   4.692 +    val substXA = Term.subst_TVars As_rho o substT X X';
   4.693 +    val phi = Morphism.typ_morphism "BNF" substXAT $> Morphism.term_morphism "BNF" substXA;
   4.694 +
   4.695 +    fun mk_applied_cong arg =
   4.696 +      enforce_type ctxt domain_type (fastype_of arg) cong0 $ arg;
   4.697 +
   4.698 +    val thm = derive_coinduct_thms_for_types false mk_applied_cong [pre_bnf] dtor_coinduct
   4.699 +        dtor_ctors live_nesting_bnfs [fpT] [substXAT X] [map (map substXAT) ctrXs_Tss] [n]
   4.700 +        [abs_inverse] [abs_inverse] I [ctr_defs] [morph_ctr_sugar phi ctr_sugar0] ctxt
   4.701 +      |> map snd |> the_single;
   4.702 +    val (attrs, _) = mk_coinduct_attrs [fpT] [ctrs0] [discs0] [ms];
   4.703 +  in
   4.704 +    (thm, attrs)
   4.705 +  end;
   4.706 +
   4.707 +type explore_parameters =
   4.708 +  {bound_Us: typ list,
   4.709 +   bound_Ts: typ list,
   4.710 +   U: typ,
   4.711 +   T: typ};
   4.712 +
   4.713 +fun update_UT {bound_Us, bound_Ts, ...} U T =
   4.714 +  {bound_Us = bound_Us, bound_Ts = bound_Ts, U = U, T = T};
   4.715 +
   4.716 +fun explore_nested lthy explore {bound_Us, bound_Ts, U, T} t =
   4.717 +  let
   4.718 +    fun build_simple (T, U) =
   4.719 +      if T = U then
   4.720 +        @{term "%y. y"}
   4.721 +      else
   4.722 +        Bound 0
   4.723 +        |> explore {bound_Us = T :: bound_Us, bound_Ts = T :: bound_Ts, U = U, T = T}
   4.724 +        |> (fn t => Abs (Name.uu, T, t));
   4.725 +  in
   4.726 +    betapply (build_map lthy [] build_simple (T, U), t)
   4.727 +  end;
   4.728 +
   4.729 +fun add_boundvar t = betapply (incr_boundvars 1 t, Bound 0);
   4.730 +
   4.731 +fun explore_fun (arg_U :: arg_Us) explore {bound_Us, bound_Ts, U, T} t =
   4.732 +    let val arg_name = the_default Name.uu (try (fn (Abs (s, _, _)) => s) t) in
   4.733 +      add_boundvar t
   4.734 +      |> explore_fun arg_Us explore
   4.735 +        {bound_Us = arg_U :: bound_Us, bound_Ts = domain_type T :: bound_Ts, U = range_type U,
   4.736 +         T = range_type T}
   4.737 +      |> (fn t => Abs (arg_name, arg_U, t))
   4.738 +    end
   4.739 +  | explore_fun [] explore params t = explore params t;
   4.740 +
   4.741 +fun massage_fun explore (params as {T, U, ...}) =
   4.742 +  if can dest_funT T then explore_fun [domain_type U] explore params else explore params;
   4.743 +
   4.744 +fun massage_star massages explore =
   4.745 +  let
   4.746 +    fun after_massage massages' t params t' =
   4.747 +      if t aconv t' then massage_any massages' params t else massage_any massages params t'
   4.748 +    and massage_any [] params t = explore params t
   4.749 +      | massage_any (massage :: massages') params t =
   4.750 +        massage (after_massage massages' t) params t;
   4.751 +  in
   4.752 +    massage_any massages
   4.753 +  end;
   4.754 +
   4.755 +fun massage_let explore params t =
   4.756 +  (case strip_comb t of
   4.757 +    (Const (@{const_name Let}, _), [_, _]) => unfold_lets_splits t
   4.758 +  | _ => t)
   4.759 +  |> explore params;
   4.760 +
   4.761 +fun check_corec_equation ctxt fun_frees (lhs, rhs) =
   4.762 +  let
   4.763 +    val (fun_t, arg_ts) = strip_comb lhs;
   4.764 +
   4.765 +    fun check_fun_name () =
   4.766 +      null fun_frees orelse member (op aconv) fun_frees fun_t orelse
   4.767 +      error (quote (Syntax.string_of_term ctxt fun_t) ^
   4.768 +        " is not the function currently being defined");
   4.769 +
   4.770 +    fun check_args_are_vars () =
   4.771 +      let
   4.772 +        fun is_ok_Free_or_Var (Free (s, _)) = not (String.isSuffix inner_fp_suffix s)
   4.773 +          | is_ok_Free_or_Var (Var _) = true
   4.774 +          | is_ok_Free_or_Var _ = false;
   4.775 +
   4.776 +        fun is_valid arg =
   4.777 +          (is_ok_Free_or_Var arg andalso not (member (op aconv) fun_frees arg)) orelse
   4.778 +          error ("Argument " ^ quote (Syntax.string_of_term ctxt arg) ^ " is not free");
   4.779 +      in
   4.780 +        forall is_valid arg_ts
   4.781 +      end;
   4.782 +
   4.783 +    fun check_no_duplicate_arg () =
   4.784 +      (case duplicates (op =) arg_ts of
   4.785 +        [] => ()
   4.786 +      | arg :: _ => error ("Repeated argument: " ^ quote (Syntax.string_of_term ctxt arg)));
   4.787 +
   4.788 +    fun check_no_other_frees () =
   4.789 +      let
   4.790 +        val known_frees = fun_frees @ arg_ts;
   4.791 +
   4.792 +        fun check_free (t as Free (s, _)) =
   4.793 +            Variable.is_fixed ctxt s orelse member (op aconv) known_frees t orelse
   4.794 +            error ("Unexpected variable: " ^ quote s)
   4.795 +          | check_free _ = false;
   4.796 +      in
   4.797 +        Term.exists_subterm check_free rhs
   4.798 +      end;
   4.799 +  in
   4.800 +    check_no_duplicate_arg ();
   4.801 +    check_fun_name ();
   4.802 +    check_args_are_vars ();
   4.803 +    check_no_other_frees ()
   4.804 +  end;
   4.805 +
   4.806 +fun parse_corec_equation ctxt fun_frees eq =
   4.807 +  let
   4.808 +    val (lhs, rhs) = HOLogic.dest_eq (HOLogic.dest_Trueprop (drop_all eq))
   4.809 +      handle TERM _ => error "Expected equation";
   4.810 +
   4.811 +    val _ = check_corec_equation ctxt fun_frees (lhs, rhs);
   4.812 +
   4.813 +    val (fun_t, arg_ts) = strip_comb lhs;
   4.814 +    val (arg_Ts, _) = strip_type (fastype_of fun_t);
   4.815 +    val added_Ts = drop (length arg_ts) arg_Ts;
   4.816 +    val free_names = mk_names (length added_Ts) "x" ~~ added_Ts;
   4.817 +    val free_args = Variable.variant_frees ctxt [rhs, lhs] free_names |> map Free;
   4.818 +  in
   4.819 +    (arg_ts @ free_args, list_comb (rhs, free_args))
   4.820 +  end;
   4.821 +
   4.822 +fun morph_views phi (code, ctrs, discs, disc_iffs, sels) =
   4.823 +  (Morphism.term phi code, map (Morphism.term phi) ctrs, map (Morphism.term phi) discs,
   4.824 +   map (Morphism.term phi) disc_iffs, map (Morphism.term phi) sels);
   4.825 +
   4.826 +fun generate_views ctxt eq fun_t (lhs_free_args, rhs) =
   4.827 +  let
   4.828 +    val lhs = list_comb (fun_t, lhs_free_args);
   4.829 +    val T as Type (T_name, Ts) = fastype_of rhs;
   4.830 +    val SOME {fp_ctr_sugar = {ctr_sugar = {ctrs = ctrs0, discs = discs0, selss = selss0, ...}, ...},
   4.831 +        ...} =
   4.832 +      fp_sugar_of ctxt T_name;
   4.833 +    val ctrs = map (mk_ctr Ts) ctrs0;
   4.834 +    val discs = map (mk_disc_or_sel Ts) discs0;
   4.835 +    val selss = map (map (mk_disc_or_sel Ts)) selss0;
   4.836 +
   4.837 +    val code_view = drop_all eq;
   4.838 +
   4.839 +    fun can_case_expand t = not (can (dest_ctr ctxt T_name) t);
   4.840 +
   4.841 +    fun generate_raw_views conds t raw_views =
   4.842 +      let
   4.843 +        fun analyse (ctr :: ctrs) (disc :: discs) ctr' =
   4.844 +          if ctr = ctr' then
   4.845 +            (conds, disc, ctr)
   4.846 +          else
   4.847 +            analyse ctrs discs ctr';
   4.848 +      in
   4.849 +        (analyse ctrs discs (fst (strip_comb t))) :: raw_views
   4.850 +      end;
   4.851 +
   4.852 +    fun generate_disc_views raw_views =
   4.853 +      if length discs = 1 then
   4.854 +        ([], [])
   4.855 +      else
   4.856 +        let
   4.857 +          fun collect_condss_disc condss [] _ = condss
   4.858 +            | collect_condss_disc condss ((conds, disc', _) :: raw_views) disc =
   4.859 +              collect_condss_disc (condss |> disc = disc' ? cons conds) raw_views disc;
   4.860 +
   4.861 +          val grouped_disc_views = discs
   4.862 +            |> map (collect_condss_disc [] raw_views)
   4.863 +            |> curry (op ~~) (map (fn disc => disc $ lhs) discs);
   4.864 +
   4.865 +          fun mk_disc_iff_props props [] = props
   4.866 +            | mk_disc_iff_props _ ((lhs, @{const HOL.True}) :: _) = [lhs]
   4.867 +            | mk_disc_iff_props props ((lhs, rhs) :: views) =
   4.868 +              mk_disc_iff_props ((HOLogic.mk_eq (lhs, rhs)) :: props) views;
   4.869 +        in
   4.870 +          (grouped_disc_views
   4.871 +           |> map swap,
   4.872 +           grouped_disc_views
   4.873 +           |> map (apsnd (s_dnf #> mk_conjs))
   4.874 +           |> mk_disc_iff_props []
   4.875 +           |> map (fn eq => ([[]], eq)))
   4.876 +        end;
   4.877 +
   4.878 +    fun generate_ctr_views raw_views =
   4.879 +      let
   4.880 +        fun collect_condss_ctr condss [] _ = condss
   4.881 +          | collect_condss_ctr condss ((conds, _, ctr') :: raw_views) ctr =
   4.882 +            collect_condss_ctr (condss |> ctr = ctr' ? cons conds) raw_views ctr;
   4.883 +
   4.884 +        fun mk_ctr_eq ctr_sels ctr =
   4.885 +          let
   4.886 +            fun extract_arg n sel _(*bound_Ts*) fun_t arg_ts =
   4.887 +              if ctr = fun_t then
   4.888 +                nth arg_ts n
   4.889 +              else
   4.890 +                let val t = list_comb (fun_t, arg_ts) in
   4.891 +                  if can_case_expand t then
   4.892 +                    sel $ t
   4.893 +                  else
   4.894 +                    Term.dummy_pattern (range_type (fastype_of sel))
   4.895 +                end;
   4.896 +          in
   4.897 +            ctr_sels
   4.898 +            |> map_index (uncurry extract_arg)
   4.899 +            |> map (fn extract => massage_corec_code_rhs ctxt extract [] rhs)
   4.900 +            |> curry list_comb ctr
   4.901 +            |> curry HOLogic.mk_eq lhs
   4.902 +          end;
   4.903 +
   4.904 +          fun remove_condss_if_alone [(_, concl)] = [([[]], concl)]
   4.905 +            | remove_condss_if_alone views = views;
   4.906 +      in
   4.907 +        ctrs
   4.908 +        |> `(map (collect_condss_ctr [] raw_views))
   4.909 +        ||> map2 mk_ctr_eq selss
   4.910 +        |> op ~~
   4.911 +        |> filter_out (null o fst)
   4.912 +        |> remove_condss_if_alone
   4.913 +      end;
   4.914 +
   4.915 +    fun generate_sel_views raw_views only_one_ctr =
   4.916 +      let
   4.917 +        fun mk_sel_positions sel =
   4.918 +          let
   4.919 +            fun get_sel_position _ [] = NONE
   4.920 +              | get_sel_position i (sel' :: sels) =
   4.921 +                if sel = sel' then SOME i else get_sel_position (i + 1) sels;
   4.922 +          in
   4.923 +            ctrs ~~ map (get_sel_position 0) selss
   4.924 +            |> map_filter (fn (ctr, pos_opt) =>
   4.925 +              if is_some pos_opt then SOME (ctr, the pos_opt) else NONE)
   4.926 +          end;
   4.927 +
   4.928 +        fun collect_sel_condss0 condss [] _ = condss
   4.929 +          | collect_sel_condss0 condss ((conds, _, ctr) :: raw_views) sel_positions =
   4.930 +            let val condss' = condss |> is_some (AList.lookup (op =) sel_positions ctr) ? cons conds
   4.931 +            in
   4.932 +              collect_sel_condss0 condss' raw_views sel_positions
   4.933 +            end;
   4.934 +
   4.935 +        val collect_sel_condss =
   4.936 +          if only_one_ctr then K [[]] else collect_sel_condss0 [] raw_views;
   4.937 +
   4.938 +        fun mk_sel_rhs sel_positions sel =
   4.939 +          let
   4.940 +            val sel_T = range_type (fastype_of sel);
   4.941 +
   4.942 +            fun extract_sel_value _(*bound_Ts*) fun_t arg_ts =
   4.943 +              (case AList.lookup (op =) sel_positions fun_t of
   4.944 +                SOME n => nth arg_ts n
   4.945 +              | NONE =>
   4.946 +                let val t = list_comb (fun_t, arg_ts) in
   4.947 +                  if can_case_expand t then
   4.948 +                    sel $ t
   4.949 +                  else
   4.950 +                    Term.dummy_pattern sel_T
   4.951 +                end);
   4.952 +          in
   4.953 +            massage_corec_code_rhs ctxt extract_sel_value [] rhs
   4.954 +          end;
   4.955 +
   4.956 +        val ordered_sels = distinct (op =) (flat selss);
   4.957 +        val sel_positionss = map mk_sel_positions ordered_sels;
   4.958 +        val sel_rhss = map2 mk_sel_rhs sel_positionss ordered_sels;
   4.959 +        val sel_lhss = map (rapp lhs o mk_disc_or_sel Ts) ordered_sels;
   4.960 +        val sel_condss = map collect_sel_condss sel_positionss;
   4.961 +
   4.962 +        fun is_undefined (Const (@{const_name undefined}, _)) = true
   4.963 +          | is_undefined _ = false;
   4.964 +      in
   4.965 +        sel_condss ~~ (sel_lhss ~~ sel_rhss)
   4.966 +        |> filter_out (is_undefined o snd o snd)
   4.967 +        |> map (apsnd HOLogic.mk_eq)
   4.968 +      end;
   4.969 +
   4.970 +    fun mk_atomic_prop fun_args (condss, concl) =
   4.971 +      (Logic.list_all (map dest_Free fun_args, abstract_over_list fun_args
   4.972 +        (Logic.list_implies (map HOLogic.mk_Trueprop (s_dnf condss), HOLogic.mk_Trueprop concl))));
   4.973 +
   4.974 +    val raw_views = rhs
   4.975 +      |> massage_let_if_case ctxt (K false) (fn _(*bound_Ts*) => fn t => t
   4.976 +          |> can_case_expand t ? expand_to_ctr_term ctxt T) (K (K ())) (K I) []
   4.977 +      |> (fn expanded_rhs => fold_rev_let_if_case ctxt generate_raw_views [] expanded_rhs [])
   4.978 +      |> rev;
   4.979 +    val (disc_views, disc_iff_views) = generate_disc_views raw_views;
   4.980 +    val ctr_views = generate_ctr_views raw_views;
   4.981 +    val sel_views = generate_sel_views raw_views (length ctr_views = 1);
   4.982 +
   4.983 +    val mk_props = filter_out (null o fst) #> map (mk_atomic_prop lhs_free_args);
   4.984 +  in
   4.985 +    (code_view, mk_props ctr_views, mk_props disc_views, mk_props disc_iff_views,
   4.986 +     mk_props sel_views)
   4.987 +  end;
   4.988 +
   4.989 +fun find_all_associated_types [] _ = []
   4.990 +  | find_all_associated_types ((Type (_, Ts1), Type (_, Ts2)) :: TTs) T =
   4.991 +    find_all_associated_types ((Ts1 ~~ Ts2) @ TTs) T
   4.992 +  | find_all_associated_types ((T1, T2) :: TTs) T =
   4.993 +    find_all_associated_types TTs T |> T1 = T ? cons T2;
   4.994 +
   4.995 +fun as_member_of tab = try dest_Const #> Option.mapPartial (fst #> Symtab.lookup tab);
   4.996 +
   4.997 +fun extract_rho_from_equation
   4.998 +    ({ctr_guards, inner_buffer = {Oper, VLeaf, CLeaf, ctr_wrapper, friends}, ...},
   4.999 +     {pattern_ctrs, discs, sels, it, mk_case})
  4.1000 +    b version Y preT ssig_T friend_tm (lhs_args, rhs) lthy =
  4.1001 +  let
  4.1002 +    val thy = Proof_Context.theory_of lthy;
  4.1003 +
  4.1004 +    val res_T = fastype_of rhs;
  4.1005 +    val YpreT = HOLogic.mk_prodT (Y, preT);
  4.1006 +
  4.1007 +    fun fpT_to new_T T =
  4.1008 +      if T = res_T then
  4.1009 +        new_T
  4.1010 +      else
  4.1011 +        (case T of
  4.1012 +          Type (s, Ts) => Type (s, map (fpT_to new_T) Ts)
  4.1013 +        | _ => T);
  4.1014 +
  4.1015 +    fun build_params bound_Us bound_Ts T =
  4.1016 +      {bound_Us = bound_Us, bound_Ts = bound_Ts, U = T, T = T};
  4.1017 +
  4.1018 +    fun typ_before explore {bound_Us, bound_Ts, ...} t =
  4.1019 +      explore (build_params bound_Us bound_Ts (fastype_of1 (bound_Ts, t))) t;
  4.1020 +
  4.1021 +    val is_self_call = curry (op aconv) friend_tm;
  4.1022 +    val has_self_call = Term.exists_subterm is_self_call;
  4.1023 +
  4.1024 +    fun has_res_T bound_Ts t = fastype_of1 (bound_Ts, t) = res_T;
  4.1025 +
  4.1026 +    fun contains_res_T (Type (s, Ts)) = s = fst (dest_Type res_T) orelse exists contains_res_T Ts
  4.1027 +      | contains_res_T _ = false;
  4.1028 +
  4.1029 +    val is_lhs_arg = member (op =) lhs_args;
  4.1030 +
  4.1031 +    fun is_constant t =
  4.1032 +      not (Term.exists_subterm is_lhs_arg t orelse has_self_call t orelse loose_bvar (t, 0));
  4.1033 +    fun is_nested_type T = T <> res_T andalso T <> YpreT andalso T <> ssig_T;
  4.1034 +
  4.1035 +    val is_valid_case_argumentT = not o member (op =) [Y, ssig_T];
  4.1036 +
  4.1037 +    fun is_same_type_constr (Type (s, _)) (Type (s', _)) = (s = s')
  4.1038 +      | is_same_type_constr _ _ = false;
  4.1039 +
  4.1040 +    exception NO_ENCAPSULATION of unit;
  4.1041 +
  4.1042 +    val parametric_consts = Unsynchronized.ref [];
  4.1043 +
  4.1044 +    (* We are assuming that set functions are marked with "[transfer_rule]" (cf. the "transfer"
  4.1045 +       plugin). Otherwise, the "eq_algrho" tactic might fail. *)
  4.1046 +    fun is_special_parametric_const (x as (s, _)) =
  4.1047 +      s = @{const_name id} orelse is_set lthy x;
  4.1048 +
  4.1049 +    fun add_parametric_const s general_T T U =
  4.1050 +      let
  4.1051 +        fun tupleT_of_funT T =
  4.1052 +          let val (Ts, T) = strip_type T in
  4.1053 +            mk_tupleT_balanced (Ts @ [T])
  4.1054 +          end;
  4.1055 +
  4.1056 +        fun funT_of_tupleT n =
  4.1057 +          dest_tupleT_balanced (n + 1)
  4.1058 +          #> split_last
  4.1059 +          #> op --->;
  4.1060 +
  4.1061 +        val m = num_binder_types general_T;
  4.1062 +        val param1_T = Type_Infer.paramify_vars general_T;
  4.1063 +        val param2_T = Type_Infer.paramify_vars param1_T;
  4.1064 +
  4.1065 +        val deadfixed_T =
  4.1066 +          build_map lthy [] (mk_undefined o op -->) (apply2 tupleT_of_funT (param1_T, param2_T))
  4.1067 +          |> singleton (Type_Infer_Context.infer_types lthy)
  4.1068 +          |> singleton (Type_Infer.fixate lthy)
  4.1069 +          |> type_of
  4.1070 +          |> dest_funT
  4.1071 +          |-> BNF_GFP_Grec_Sugar_Util.generalize_types 1
  4.1072 +          |> funT_of_tupleT m;
  4.1073 +
  4.1074 +        val j = maxidx_of_typ deadfixed_T + 1;
  4.1075 +
  4.1076 +        fun varifyT (Type (s, Ts)) = Type (s, map varifyT Ts)
  4.1077 +          | varifyT (TFree (s, T)) = TVar ((s, j), T)
  4.1078 +          | varifyT T = T;
  4.1079 +
  4.1080 +        val dedvarified_T = varifyT deadfixed_T;
  4.1081 +
  4.1082 +        val new_vars = Sign.typ_match thy (dedvarified_T, T) Vartab.empty
  4.1083 +          |> Vartab.dest
  4.1084 +          |> filter (curry (op =) j o snd o fst)
  4.1085 +          |> Vartab.make;
  4.1086 +
  4.1087 +        val deadinstantiated_T = map_atyps (Type.devar new_vars) dedvarified_T;
  4.1088 +
  4.1089 +        val final_T =
  4.1090 +          if Sign.typ_instance thy (U, deadinstantiated_T) then deadfixed_T else general_T;
  4.1091 +      in
  4.1092 +        parametric_consts := insert (op =) (s, final_T) (!parametric_consts)
  4.1093 +      end;
  4.1094 +
  4.1095 +    fun encapsulate (params as {U, T, ...}) t =
  4.1096 +      if U = T then
  4.1097 +        t
  4.1098 +      else if T = Y then
  4.1099 +        VLeaf $ t
  4.1100 +      else if T = res_T then
  4.1101 +        CLeaf $ t
  4.1102 +      else if T = YpreT then
  4.1103 +        it $ t
  4.1104 +      else if is_nested_type T andalso is_same_type_constr T U then
  4.1105 +        explore_nested lthy encapsulate params t
  4.1106 +      else
  4.1107 +        raise NO_ENCAPSULATION ();
  4.1108 +
  4.1109 +    fun build_function_after_encapsulation fun_t fun_t' (params as {bound_Us, ...}) arg_ts arg_ts' =
  4.1110 +      let
  4.1111 +        val arg_Us' = fst (strip_typeN (length arg_ts) (fastype_of1 (bound_Us, fun_t')));
  4.1112 +
  4.1113 +        fun the_or_error arg NONE =
  4.1114 +            error ("Illegal argument " ^ quote (Syntax.string_of_term lthy arg) ^
  4.1115 +              " to " ^ quote (Syntax.string_of_term lthy fun_t))
  4.1116 +          | the_or_error _ (SOME arg') = arg';
  4.1117 +      in
  4.1118 +        arg_ts'
  4.1119 +        |> `(map (curry fastype_of1 bound_Us))
  4.1120 +        |>> map2 (update_UT params) arg_Us'
  4.1121 +        |> op ~~
  4.1122 +        |> map (try (uncurry encapsulate))
  4.1123 +        |> map2 the_or_error arg_ts
  4.1124 +        |> curry list_comb fun_t'
  4.1125 +      end;
  4.1126 +
  4.1127 +    fun rebuild_function_after_exploration old_fn new_fn explore params arg_ts =
  4.1128 +      arg_ts
  4.1129 +      |> map (typ_before explore params)
  4.1130 +      |> build_function_after_encapsulation old_fn new_fn params arg_ts;
  4.1131 +
  4.1132 +    fun update_case Us U casex =
  4.1133 +      let
  4.1134 +        val Type (T_name, _) = domain_type (snd (strip_fun_type (fastype_of casex)));
  4.1135 +        val SOME {fp_ctr_sugar = {ctr_sugar = {T = Type (_, Ts), casex, ...}, ...}, ...} =
  4.1136 +          fp_sugar_of lthy T_name;
  4.1137 +        val T = body_type (fastype_of casex);
  4.1138 +      in
  4.1139 +        Term.subst_atomic_types ((T :: Ts) ~~ (U :: Us)) casex
  4.1140 +      end;
  4.1141 +
  4.1142 +    fun deduce_according_type default_T [] = default_T
  4.1143 +      | deduce_according_type default_T Ts = (case distinct (op =) Ts of
  4.1144 +          U :: [] => U
  4.1145 +        | _ => fpT_to ssig_T default_T);
  4.1146 +
  4.1147 +    fun massage_if explore_cond explore (params as {bound_Us, bound_Ts, ...}) t =
  4.1148 +      (case strip_comb t of
  4.1149 +        (const as Const (@{const_name If}, _), obj :: (branches as [_, _])) =>
  4.1150 +        (case List.partition Term.is_dummy_pattern (map (explore params) branches) of
  4.1151 +          (dummy_branch' :: _, []) => dummy_branch'
  4.1152 +        | (_, [branch']) => branch'
  4.1153 +        | (_, branches') =>
  4.1154 +          let
  4.1155 +            val brancheUs = map (curry fastype_of1 bound_Us) branches';
  4.1156 +            val U = deduce_according_type (fastype_of1 (bound_Ts, hd branches)) brancheUs;
  4.1157 +            val const_obj' = (If_const U, obj)
  4.1158 +              ||> explore_cond (update_UT params @{typ bool} @{typ bool})
  4.1159 +              |> op $;
  4.1160 +          in
  4.1161 +            build_function_after_encapsulation (const $ obj) const_obj' params branches branches'
  4.1162 +          end)
  4.1163 +      | _ => explore params t);
  4.1164 +
  4.1165 +    fun massage_map explore (params as {bound_Us, bound_Ts, T = Type (T_name, Ts), ...})
  4.1166 +          (t as func $ mapped_arg) =
  4.1167 +        if is_self_call (head_of func) then
  4.1168 +          explore params t
  4.1169 +        else
  4.1170 +          (case try (dest_map lthy T_name) func of
  4.1171 +            SOME (map_tm, fs) =>
  4.1172 +            let
  4.1173 +              val n = length fs;
  4.1174 +              val mapped_arg' = mapped_arg
  4.1175 +                |> `(curry fastype_of1 bound_Ts)
  4.1176 +                |>> build_params bound_Us bound_Ts
  4.1177 +                |-> explore;
  4.1178 +              (* FIXME: This looks suspicious *)
  4.1179 +              val Us = map (fpT_to ssig_T) (snd (dest_Type (fastype_of1 (bound_Us, mapped_arg'))));
  4.1180 +              val temporary_map = map_tm
  4.1181 +                |> mk_map n Us Ts;
  4.1182 +              val map_fn_Ts = fastype_of #> strip_fun_type #> fst;
  4.1183 +              val binder_Uss = map_fn_Ts temporary_map
  4.1184 +                |> map (map (fpT_to ssig_T) o binder_types);
  4.1185 +              val fun_paramss = map_fn_Ts (head_of func)
  4.1186 +                |> map (build_params bound_Us bound_Ts);
  4.1187 +              val fs' = fs |> @{map 4} explore_fun binder_Uss (replicate n explore) fun_paramss;
  4.1188 +              val SOME bnf = bnf_of lthy T_name;
  4.1189 +              val Type (_, bnf_Ts) = T_of_bnf bnf;
  4.1190 +              val typ_alist =
  4.1191 +                lives_of_bnf bnf ~~ map (curry fastype_of1 bound_Us #> range_type) fs';
  4.1192 +              val Us' = map2 the_default Us (map (AList.lookup (op =) typ_alist) bnf_Ts);
  4.1193 +              val map_tm' = map_tm |> mk_map n Us Us';
  4.1194 +            in
  4.1195 +              build_function_after_encapsulation func (list_comb (map_tm', fs')) params [mapped_arg]
  4.1196 +                [mapped_arg']
  4.1197 +            end
  4.1198 +          | NONE => explore params t)
  4.1199 +      | massage_map explore params t = explore params t;
  4.1200 +
  4.1201 +    fun massage_comp explore (params as {bound_Us, ...}) t =
  4.1202 +      (case strip_comb t of
  4.1203 +        (Const (@{const_name comp}, _), f1 :: f2 :: args) =>
  4.1204 +        let
  4.1205 +          val args' = map (typ_before explore params) args;
  4.1206 +          val f2' = typ_before (explore_fun (map (curry fastype_of1 bound_Us) args') explore) params
  4.1207 +            f2;
  4.1208 +          val f1' = typ_before (explore_fun [range_type (fastype_of1 (bound_Us, f2'))] explore)
  4.1209 +            params f1;
  4.1210 +        in
  4.1211 +          betapply (f1', list_comb (f2', args'))
  4.1212 +        end
  4.1213 +      | _ => explore params t);
  4.1214 +
  4.1215 +    fun massage_ctr explore (params as {T = T as Type (s, Ts), bound_Us, ...}) t =
  4.1216 +        if T <> res_T then
  4.1217 +          (case try (dest_ctr lthy s) t of
  4.1218 +            SOME (ctr, args) =>
  4.1219 +            let
  4.1220 +              val args' = map (typ_before explore params) args;
  4.1221 +              val SOME {T = Type (_, ctr_Ts), ...} = ctr_sugar_of lthy s;
  4.1222 +              val temp_ctr = mk_ctr ctr_Ts ctr;
  4.1223 +              val argUs = map (curry fastype_of1 bound_Us) args';
  4.1224 +              val typ_alist = binder_types (fastype_of temp_ctr) ~~ argUs;
  4.1225 +              val Us = ctr_Ts
  4.1226 +                |> map (find_all_associated_types typ_alist)
  4.1227 +                |> map2 deduce_according_type Ts;
  4.1228 +              val ctr' = mk_ctr Us ctr;
  4.1229 +            in
  4.1230 +              build_function_after_encapsulation ctr ctr' params args args'
  4.1231 +            end
  4.1232 +          | NONE => explore params t)
  4.1233 +        else
  4.1234 +          explore params t
  4.1235 +      | massage_ctr explore params t = explore params t;
  4.1236 +
  4.1237 +    fun const_of [] _ = NONE
  4.1238 +      | const_of ((sel as Const (s1, _)) :: r) (const as Const (s2, _)) =
  4.1239 +        if s1 = s2 then SOME sel else const_of r const
  4.1240 +      | const_of _ _ = NONE;
  4.1241 +
  4.1242 +    fun massage_disc explore (params as {T, bound_Us, bound_Ts, ...}) t =
  4.1243 +      (case (strip_comb t, T = @{typ bool}) of
  4.1244 +        ((fun_t, arg :: []), true) =>
  4.1245 +        let val arg_T = fastype_of1 (bound_Ts, arg) in
  4.1246 +          if arg_T <> res_T then
  4.1247 +            (case arg_T |> try (fst o dest_Type) |> Option.mapPartial (ctr_sugar_of lthy) of
  4.1248 +              SOME {discs, T = Type (_, Ts), ...} =>
  4.1249 +              (case const_of discs fun_t of
  4.1250 +                SOME disc =>
  4.1251 +                let
  4.1252 +                  val arg' = arg |> typ_before explore params;
  4.1253 +                  val Type (_, Us) = fastype_of1 (bound_Us, arg');
  4.1254 +                  val disc' = disc |> Term.subst_TVars (map (fst o dest_TVar) Ts ~~ Us);
  4.1255 +                in
  4.1256 +                  disc' $ arg'
  4.1257 +                end
  4.1258 +              | NONE => explore params t)
  4.1259 +            | NONE => explore params t)
  4.1260 +          else
  4.1261 +            explore params t
  4.1262 +        end
  4.1263 +      | _ => explore params t);
  4.1264 +
  4.1265 +    fun massage_sel explore (params as {bound_Us, bound_Ts, ...}) t =
  4.1266 +      let val (fun_t, args) = strip_comb t in
  4.1267 +        if args = [] then
  4.1268 +          explore params t
  4.1269 +        else
  4.1270 +          let val T = fastype_of1 (bound_Ts, hd args) in
  4.1271 +            (case (Option.mapPartial (ctr_sugar_of lthy) (try (fst o dest_Type) T), T <> res_T) of
  4.1272 +              (SOME {selss, T = Type (_, Ts), ...}, true) =>
  4.1273 +              (case const_of (fold (curry op @) selss []) fun_t of
  4.1274 +                SOME sel =>
  4.1275 +                let
  4.1276 +                  val args' = args |> map (typ_before explore params);
  4.1277 +                  val Type (_, Us) = fastype_of1 (bound_Us, hd args');
  4.1278 +                  val sel' = sel |> Term.subst_TVars (map (fst o dest_TVar) Ts ~~ Us);
  4.1279 +                in
  4.1280 +                  build_function_after_encapsulation sel sel' params args args'
  4.1281 +                end
  4.1282 +              | NONE => explore params t)
  4.1283 +            | _ => explore params t)
  4.1284 +          end
  4.1285 +      end;
  4.1286 +
  4.1287 +    fun massage_equality explore (params as {bound_Us, bound_Ts, ...})
  4.1288 +          (t as Const (@{const_name HOL.eq}, _) $ t1 $ t2) =
  4.1289 +        let
  4.1290 +          val check_is_VLeaf =
  4.1291 +            not o (Term.exists_subterm (fn t => t aconv CLeaf orelse t aconv Oper));
  4.1292 +
  4.1293 +          fun try_pattern_matching (fun_t, arg_ts) t =
  4.1294 +            (case as_member_of pattern_ctrs fun_t of
  4.1295 +              SOME (disc, sels) =>
  4.1296 +              let val t' = typ_before explore params t in
  4.1297 +                if fastype_of1 (bound_Us, t') = YpreT then
  4.1298 +                  let
  4.1299 +                    val arg_ts' = map (typ_before explore params) arg_ts;
  4.1300 +                    val sels_t' = map (fn sel => betapply (sel, t')) sels;
  4.1301 +                    val Ts = map (curry fastype_of1 bound_Us) arg_ts';
  4.1302 +                    val Us = map (curry fastype_of1 bound_Us) sels_t';
  4.1303 +                    val arg_ts' = map2 encapsulate (map2 (update_UT params) Us Ts) arg_ts';
  4.1304 +                  in
  4.1305 +                    if forall check_is_VLeaf arg_ts' then
  4.1306 +                      SOME (Library.foldl1 HOLogic.mk_conj
  4.1307 +                        (betapply (disc, t') :: (map HOLogic.mk_eq (arg_ts' ~~ sels_t'))))
  4.1308 +                    else
  4.1309 +                      NONE
  4.1310 +                  end
  4.1311 +                else
  4.1312 +                  NONE
  4.1313 +              end
  4.1314 +            | NONE => NONE);
  4.1315 +        in
  4.1316 +          (case try_pattern_matching (strip_comb t1) t2 of
  4.1317 +            SOME cond => cond
  4.1318 +          | NONE => (case try_pattern_matching (strip_comb t2) t1 of
  4.1319 +              SOME cond => cond
  4.1320 +            | NONE =>
  4.1321 +              let
  4.1322 +                val T = fastype_of1 (bound_Ts, t1);
  4.1323 +                val params' = build_params bound_Us bound_Ts T;
  4.1324 +                val t1' = explore params' t1;
  4.1325 +                val t2' = explore params' t2;
  4.1326 +              in
  4.1327 +                if fastype_of1 (bound_Us, t1') = T andalso fastype_of1 (bound_Us, t2') = T then
  4.1328 +                  HOLogic.mk_eq (t1', t2')
  4.1329 +                else
  4.1330 +                  error ("Unsupported condition: " ^ quote (Syntax.string_of_term lthy t))
  4.1331 +              end))
  4.1332 +        end
  4.1333 +      | massage_equality explore params t = explore params t;
  4.1334 +
  4.1335 +    fun infer_types (TVar _) (TVar _) = []
  4.1336 +      | infer_types (U as TVar _) T = [(U, T)]
  4.1337 +      | infer_types (Type (s', Us)) (Type (s, Ts)) =
  4.1338 +        if s' = s then flat (map2 infer_types Us Ts) else []
  4.1339 +      | infer_types _ _ = [];
  4.1340 +
  4.1341 +    fun group_by_fst associations [] = associations
  4.1342 +      | group_by_fst associations ((a, b) :: r) = group_by_fst (add_association a b associations) r
  4.1343 +    and add_association a b [] = [(a, [b])]
  4.1344 +      | add_association a b ((c, d) :: r) =
  4.1345 +        if a = c then (c, b :: d) :: r
  4.1346 +        else (c, d) :: (add_association a b r);
  4.1347 +
  4.1348 +    fun new_TVar known_TVars =
  4.1349 +      Name.invent_list (map (fst o fst o dest_TVar) known_TVars) "x" 1
  4.1350 +      |> (fn [s] => TVar ((s, 0), []));
  4.1351 +
  4.1352 +    fun instantiate_type inferred_types =
  4.1353 +      Term.typ_subst_TVars (map (apfst (fst o dest_TVar)) inferred_types);
  4.1354 +
  4.1355 +    fun chose_unknown_TVar (T as TVar _) = SOME T
  4.1356 +      | chose_unknown_TVar (Type (_, Ts)) =
  4.1357 +        fold (curry merge_options) (map chose_unknown_TVar Ts) NONE
  4.1358 +      | chose_unknown_TVar _ = NONE;
  4.1359 +
  4.1360 +    (* The function under definition might not be defined yet when this is queried. *)
  4.1361 +    fun maybe_const_type ctxt (s, T) =
  4.1362 +      Sign.const_type (Proof_Context.theory_of ctxt) s |> the_default T;
  4.1363 +
  4.1364 +    fun massage_polymorphic_const explore (params as {bound_Us, ...}) t =
  4.1365 +      let val (fun_t, arg_ts) = strip_comb t in
  4.1366 +        (case fun_t of
  4.1367 +          Const (fun_x as (s, fun_T)) =>
  4.1368 +          let val general_T = maybe_const_type lthy fun_x in
  4.1369 +            if contains_res_T (body_type general_T) orelse is_constant t then
  4.1370 +              explore params t
  4.1371 +            else
  4.1372 +              let
  4.1373 +                val inferred_types = infer_types general_T fun_T;
  4.1374 +
  4.1375 +                fun prepare_skeleton [] _ = []
  4.1376 +                  | prepare_skeleton ((T, U) :: inferred_types) As =
  4.1377 +                    let
  4.1378 +                      fun schematize_res_T U As =
  4.1379 +                        if U = res_T then
  4.1380 +                          let val A = new_TVar As in
  4.1381 +                            (A, A :: As)
  4.1382 +                          end
  4.1383 +                        else
  4.1384 +                          (case U of
  4.1385 +                            Type (s, Us) => fold_map schematize_res_T Us As |>> curry Type s
  4.1386 +                          | _ => (U, As));
  4.1387 +
  4.1388 +                      val (U', As') = schematize_res_T U As;
  4.1389 +                    in
  4.1390 +                      (T, U') :: (prepare_skeleton inferred_types As')
  4.1391 +                    end;
  4.1392 +
  4.1393 +                val inferred_types' = prepare_skeleton inferred_types (map fst inferred_types);
  4.1394 +                val skeleton_T = instantiate_type inferred_types' general_T;
  4.1395 +
  4.1396 +                fun explore_if_possible (exp_arg as (_, true)) _ = exp_arg
  4.1397 +                  | explore_if_possible (exp_arg as (arg, false)) arg_T =
  4.1398 +                    if exists (exists_subtype is_TVar) (binder_types arg_T) then exp_arg
  4.1399 +                    else (typ_before (explore_fun (binder_types arg_T) explore) params arg, true);
  4.1400 +
  4.1401 +                fun collect_inferred_types [] _ = []
  4.1402 +                  | collect_inferred_types ((arg, explored) :: exp_arg_ts) (arg_T :: arg_Ts) =
  4.1403 +                    (if explored then infer_types arg_T (fastype_of1 (bound_Us, arg)) else []) @
  4.1404 +                    collect_inferred_types exp_arg_ts arg_Ts;
  4.1405 +
  4.1406 +                fun propagate exp_arg_ts skeleton_T =
  4.1407 +                  let
  4.1408 +                    val arg_gen_Ts = binder_types skeleton_T;
  4.1409 +                    val exp_arg_ts = map2 explore_if_possible exp_arg_ts arg_gen_Ts;
  4.1410 +                    val inferred_types = collect_inferred_types exp_arg_ts arg_gen_Ts
  4.1411 +                      |> group_by_fst []
  4.1412 +                      |> map (apsnd (deduce_according_type ssig_T));
  4.1413 +                  in
  4.1414 +                    (exp_arg_ts, instantiate_type inferred_types skeleton_T)
  4.1415 +                  end;
  4.1416 +
  4.1417 +                val remaining_to_be_explored = filter_out snd #> length;
  4.1418 +
  4.1419 +                fun try_exploring_args exp_arg_ts skeleton_T =
  4.1420 +                  let
  4.1421 +                    val n = remaining_to_be_explored exp_arg_ts;
  4.1422 +                    val (exp_arg_ts', skeleton_T') = propagate exp_arg_ts skeleton_T;
  4.1423 +                    val n' = remaining_to_be_explored exp_arg_ts';
  4.1424 +
  4.1425 +                    fun try_instantiating A T =
  4.1426 +                      try (try_exploring_args exp_arg_ts') (instantiate_type [(A, T)] skeleton_T');
  4.1427 +                  in
  4.1428 +                    if n' = 0 then
  4.1429 +                      SOME (exp_arg_ts', skeleton_T')
  4.1430 +                    else if n = n' then
  4.1431 +                      if exists_subtype is_TVar skeleton_T' then
  4.1432 +                        let val SOME A = chose_unknown_TVar skeleton_T' in
  4.1433 +                          (case try_instantiating A ssig_T of
  4.1434 +                            SOME result => result
  4.1435 +                          | NONE => (case try_instantiating A YpreT of
  4.1436 +                              SOME result => result
  4.1437 +                            | NONE => (case try_instantiating A res_T of
  4.1438 +                                SOME result => result
  4.1439 +                              | NONE => NONE)))
  4.1440 +                        end
  4.1441 +                      else
  4.1442 +                        NONE
  4.1443 +                    else
  4.1444 +                      try_exploring_args exp_arg_ts' skeleton_T'
  4.1445 +                  end;
  4.1446 +              in
  4.1447 +                (case try_exploring_args (map (fn arg => (arg, false)) arg_ts) skeleton_T of
  4.1448 +                  SOME (exp_arg_ts, fun_U) =>
  4.1449 +                  let
  4.1450 +                    val arg_ts' = map fst exp_arg_ts;
  4.1451 +                    val fun_t' = Const (s, fun_U);
  4.1452 +                    val t' = build_function_after_encapsulation fun_t fun_t' params arg_ts arg_ts';
  4.1453 +                  in
  4.1454 +                    (case try type_of1 (bound_Us, t') of
  4.1455 +                      SOME _ =>
  4.1456 +                      (if fun_T = fun_U orelse is_special_parametric_const (s, fun_T) then ()
  4.1457 +                       else add_parametric_const s general_T fun_T fun_U;
  4.1458 +                       t')
  4.1459 +                    | NONE => explore params t)
  4.1460 +                  end
  4.1461 +                | NONE => explore params t)
  4.1462 +              end
  4.1463 +          end
  4.1464 +        | _ => explore params t)
  4.1465 +      end;
  4.1466 +
  4.1467 +    fun massage_rho explore =
  4.1468 +      massage_star [massage_let, massage_if explore_cond, massage_case, massage_fun, massage_comp,
  4.1469 +          massage_map, massage_ctr, massage_sel, massage_disc, massage_equality,
  4.1470 +          massage_polymorphic_const]
  4.1471 +        explore
  4.1472 +    and massage_case explore (params as {bound_Ts, bound_Us, ...}) t =
  4.1473 +      (case strip_comb t of
  4.1474 +        (casex as Const (case_x as (c, _)), args as _ :: _ :: _) =>
  4.1475 +        (case try strip_fun_type (maybe_const_type lthy case_x) of
  4.1476 +          SOME (gen_branch_Ts, gen_body_fun_T) =>
  4.1477 +          let
  4.1478 +            val gen_branch_ms = map num_binder_types gen_branch_Ts;
  4.1479 +            val n = length gen_branch_ms;
  4.1480 +            val (branches, obj_leftovers) = chop n args;
  4.1481 +          in
  4.1482 +            if n < length args then
  4.1483 +              (case gen_body_fun_T of
  4.1484 +                Type (_, [Type (T_name, _), _]) =>
  4.1485 +                if case_of lthy T_name = SOME c then
  4.1486 +                  let
  4.1487 +                    val brancheTs = binder_fun_types (fastype_of1 (bound_Ts, casex));
  4.1488 +                    val obj_leftover_Ts = map (curry fastype_of1 bound_Ts) obj_leftovers;
  4.1489 +                    val obj_leftovers' =
  4.1490 +                      if is_constant (hd obj_leftovers) then
  4.1491 +                        obj_leftovers
  4.1492 +                      else
  4.1493 +                        (obj_leftover_Ts, obj_leftovers)
  4.1494 +                        |>> map (build_params bound_Us bound_Ts)
  4.1495 +                        |> op ~~
  4.1496 +                        |> map (uncurry explore_inner);
  4.1497 +                    val obj_leftoverUs = obj_leftovers' |> map (curry fastype_of1 bound_Us);
  4.1498 +
  4.1499 +                    val _ = is_valid_case_argumentT (hd obj_leftoverUs) orelse
  4.1500 +                      error (quote (Syntax.string_of_term lthy (hd obj_leftovers)) ^
  4.1501 +                        " is not a valid case argument");
  4.1502 +
  4.1503 +                    val Us = obj_leftoverUs |> hd |> dest_Type |> snd;
  4.1504 +
  4.1505 +                    val branche_binderUss =
  4.1506 +                      (if hd obj_leftoverUs = YpreT then mk_case HOLogic.boolT
  4.1507 +                       else update_case Us HOLogic.boolT casex)
  4.1508 +                      |> fastype_of
  4.1509 +                      |> binder_fun_types
  4.1510 +                      |> map binder_types;
  4.1511 +                    val b_params = map (build_params bound_Us bound_Ts) brancheTs;
  4.1512 +
  4.1513 +                    val branches' = branches
  4.1514 +                      |> @{map 4} explore_fun branche_binderUss (replicate n explore) b_params;
  4.1515 +                    val brancheUs = map (curry fastype_of1 bound_Us) branches';
  4.1516 +                    val U = deduce_according_type (body_type (hd brancheTs))
  4.1517 +                      (map body_type brancheUs);
  4.1518 +                    val casex' =
  4.1519 +                      if hd obj_leftoverUs = YpreT then mk_case U else update_case Us U casex;
  4.1520 +                  in
  4.1521 +                    build_function_after_encapsulation casex casex' params
  4.1522 +                      (branches @ obj_leftovers) (branches' @ obj_leftovers')
  4.1523 +                  end
  4.1524 +                else
  4.1525 +                  explore params t
  4.1526 +              | _ => explore params t)
  4.1527 +            else
  4.1528 +              explore params t
  4.1529 +          end
  4.1530 +        | NONE => explore params t)
  4.1531 +      | _ => explore params t)
  4.1532 +    and explore_cond params t =
  4.1533 +      if has_self_call t then
  4.1534 +        error ("Unallowed corecursive call in condition " ^ quote (Syntax.string_of_term lthy t))
  4.1535 +      else
  4.1536 +        explore_inner params t
  4.1537 +    and explore_inner params t =
  4.1538 +      massage_rho explore_inner_general params t
  4.1539 +    and explore_inner_general (params as {bound_Us, bound_Ts, T, ...}) t =
  4.1540 +      let val (fun_t, arg_ts) = strip_comb t in
  4.1541 +        if is_constant t then
  4.1542 +          t
  4.1543 +        else
  4.1544 +          (case (as_member_of discs fun_t,
  4.1545 +              length arg_ts = 1 andalso has_res_T bound_Ts (the_single arg_ts)) of
  4.1546 +            (SOME disc', true) =>
  4.1547 +            let
  4.1548 +              val arg' = explore_inner params (the_single arg_ts);
  4.1549 +              val arg_U = fastype_of1 (bound_Us, arg');
  4.1550 +            in
  4.1551 +              if arg_U = res_T then
  4.1552 +                fun_t $ arg'
  4.1553 +              else if arg_U = YpreT then
  4.1554 +                disc' $ arg'
  4.1555 +              else
  4.1556 +                error ("Discriminator " ^ quote (Syntax.string_of_term lthy fun_t) ^
  4.1557 +                  " cannot be applied to non-lhs argument " ^
  4.1558 +                  quote (Syntax.string_of_term lthy (hd arg_ts)))
  4.1559 +            end
  4.1560 +          | _ =>
  4.1561 +            (case as_member_of sels fun_t of
  4.1562 +              SOME sel' =>
  4.1563 +              let
  4.1564 +                val arg_ts' = map (explore_inner params) arg_ts;
  4.1565 +                val arg_U = fastype_of1 (bound_Us, hd arg_ts');
  4.1566 +              in
  4.1567 +                if arg_U = res_T then
  4.1568 +                  build_function_after_encapsulation fun_t fun_t params arg_ts arg_ts'
  4.1569 +                else if arg_U = YpreT then
  4.1570 +                  build_function_after_encapsulation fun_t sel' params arg_ts arg_ts'
  4.1571 +                else
  4.1572 +                  error ("Selector " ^ quote (Syntax.string_of_term lthy fun_t) ^
  4.1573 +                    " cannot be applied to non-lhs argument " ^
  4.1574 +                    quote (Syntax.string_of_term lthy (hd arg_ts)))
  4.1575 +              end
  4.1576 +            | NONE =>
  4.1577 +              (case as_member_of friends fun_t of
  4.1578 +                SOME (_, friend') =>
  4.1579 +                rebuild_function_after_exploration fun_t friend' explore_inner params arg_ts
  4.1580 +                |> curry (op $) Oper
  4.1581 +              | NONE =>
  4.1582 +                (case as_member_of ctr_guards fun_t of
  4.1583 +                  SOME ctr_guard' =>
  4.1584 +                  rebuild_function_after_exploration fun_t ctr_guard' explore_inner params arg_ts
  4.1585 +                  |> curry (op $) ctr_wrapper
  4.1586 +                  |> curry (op $) Oper
  4.1587 +                | NONE =>
  4.1588 +                  if is_Bound fun_t then
  4.1589 +                    rebuild_function_after_exploration fun_t fun_t explore_inner params arg_ts
  4.1590 +                  else if is_Free fun_t then
  4.1591 +                    let val fun_t' = map_types (fpT_to YpreT) fun_t in
  4.1592 +                      rebuild_function_after_exploration fun_t fun_t' explore_inner params arg_ts
  4.1593 +                    end
  4.1594 +                  else if T = res_T then
  4.1595 +                    error (quote (Syntax.string_of_term lthy fun_t) ^
  4.1596 +                      " not polymorphic enough to be applied like this and no friend")
  4.1597 +                  else
  4.1598 +                    error (quote (Syntax.string_of_term lthy fun_t) ^
  4.1599 +                      " not polymorphic enough to be applied like this")))))
  4.1600 +      end;
  4.1601 +
  4.1602 +    fun explore_ctr params t =
  4.1603 +      massage_rho explore_ctr_general params t
  4.1604 +    and explore_ctr_general params t =
  4.1605 +      let
  4.1606 +        val (fun_t, arg_ts) = strip_comb t;
  4.1607 +        val ctr_opt = as_member_of ctr_guards fun_t;
  4.1608 +      in
  4.1609 +        if is_some ctr_opt then
  4.1610 +          rebuild_function_after_exploration fun_t (the ctr_opt) explore_inner params arg_ts
  4.1611 +        else
  4.1612 +          error ("Constructor expected on right-hand side, " ^
  4.1613 +            quote (Syntax.string_of_term lthy fun_t) ^ " found instead")
  4.1614 +      end;
  4.1615 +
  4.1616 +    val rho_rhs = rhs
  4.1617 +      |> explore_ctr (build_params [] [] (fastype_of rhs))
  4.1618 +      |> abs_tuple_balanced (map (map_types (fpT_to YpreT)) lhs_args)
  4.1619 +      |> unfold_id_bnf_etc lthy;
  4.1620 +  in
  4.1621 +    lthy
  4.1622 +    |> define_const false b version rhoN rho_rhs
  4.1623 +    |>> pair (!parametric_consts, rho_rhs)
  4.1624 +  end;
  4.1625 +
  4.1626 +fun mk_rho_parametricity_goal ctxt Y Z preT ssig_T dead_pre_rel dead_k_rel dead_ssig_rel rho_rhs =
  4.1627 +  let
  4.1628 +    val YpreT = HOLogic.mk_prodT (Y, preT);
  4.1629 +    val ZpreT = Tsubst Y Z YpreT;
  4.1630 +    val ssigZ_T = Tsubst Y Z ssig_T;
  4.1631 +
  4.1632 +    val dead_pre_rel' = Term.subst_atomic_types [(Y, ssig_T), (Z, ssigZ_T)] dead_pre_rel;
  4.1633 +    val dead_k_rel' = Term.subst_atomic_types [(Y, YpreT), (Z, ZpreT)] dead_k_rel;
  4.1634 +
  4.1635 +    val (R, _) = ctxt
  4.1636 +      |> yield_singleton (mk_Frees "R") (mk_pred2T Y Z);
  4.1637 +
  4.1638 +    val rho_rel = mk_rel_fun (dead_k_rel' $ mk_rel_prod R (dead_pre_rel $ R))
  4.1639 +      (dead_pre_rel' $ (dead_ssig_rel $ R));
  4.1640 +    val rho_rhsZ = substT Y Z rho_rhs;
  4.1641 +  in
  4.1642 +    HOLogic.mk_Trueprop (rho_rel $ rho_rhs $ rho_rhsZ)
  4.1643 +  end;
  4.1644 +
  4.1645 +fun extract_rho_return_transfer_goals fun_b version dead_pre_bnf dead_k_bnf Y Z preT fun_T k_T
  4.1646 +    ssig_T ssig_fp_sugar friend_parse_info fun_t parsed_eq lthy =
  4.1647 +  let
  4.1648 +    val Type (fpT_name, _) = body_type fun_T;
  4.1649 +
  4.1650 +    fun mk_rel T bnf =
  4.1651 +      let
  4.1652 +        val ZT = Tsubst Y Z T;
  4.1653 +        val rel_T = mk_predT [mk_pred2T Y Z, T, ZT];
  4.1654 +      in
  4.1655 +        enforce_type lthy I rel_T (rel_of_bnf bnf)
  4.1656 +      end;
  4.1657 +
  4.1658 +    val ssig_bnf = #fp_bnf ssig_fp_sugar;
  4.1659 +
  4.1660 +    val (dead_ssig_bnf, lthy) = bnf_kill_all_but 1 ssig_bnf lthy;
  4.1661 +
  4.1662 +    val dead_pre_rel = mk_rel preT dead_pre_bnf;
  4.1663 +    val dead_k_rel = mk_rel k_T dead_k_bnf;
  4.1664 +    val dead_ssig_rel = mk_rel ssig_T dead_ssig_bnf;
  4.1665 +
  4.1666 +    val (((parametric_consts, rho_rhs), rho_data), lthy) =
  4.1667 +      extract_rho_from_equation friend_parse_info fun_b version Y preT ssig_T fun_t parsed_eq lthy;
  4.1668 +
  4.1669 +    val const_transfer_goals = map (mk_const_transfer_goal lthy) parametric_consts;
  4.1670 +
  4.1671 +    val rho_transfer_goal =
  4.1672 +      mk_rho_parametricity_goal lthy Y Z preT ssig_T dead_pre_rel dead_k_rel dead_ssig_rel rho_rhs;
  4.1673 +  in
  4.1674 +    ((rho_data, (const_transfer_goals, rho_transfer_goal)), lthy)
  4.1675 +  end;
  4.1676 +
  4.1677 +fun explore_corec_equation ctxt could_be_friend friend fun_name fun_free
  4.1678 +    {outer_buffer, ctr_guards, inner_buffer} res_T (args, rhs) =
  4.1679 +  let
  4.1680 +    val is_self_call = curry (op aconv) fun_free;
  4.1681 +    val has_self_call = Term.exists_subterm is_self_call;
  4.1682 +
  4.1683 +    val outer_ssig_T = body_type (fastype_of (#Oper outer_buffer));
  4.1684 +
  4.1685 +    fun inner_fp_of (Free (s, _)) =
  4.1686 +      Free (s ^ inner_fp_suffix, mk_tupleT_balanced (map fastype_of args) --> outer_ssig_T);
  4.1687 +
  4.1688 +    fun build_params bound_Ts U T =
  4.1689 +      {bound_Us = bound_Ts, bound_Ts = bound_Ts, U = U, T = T};
  4.1690 +
  4.1691 +    fun rebuild_function_after_exploration new_fn explore {bound_Ts, ...} arg_ts =
  4.1692 +      let
  4.1693 +        val binder_types_old_fn = map (curry fastype_of1 bound_Ts) arg_ts;
  4.1694 +        val binder_types_new_fn = new_fn
  4.1695 +          |> binder_types o (curry fastype_of1 bound_Ts)
  4.1696 +          |> take (length binder_types_old_fn);
  4.1697 +        val paramss =
  4.1698 +          map2 (build_params bound_Ts) binder_types_new_fn binder_types_old_fn;
  4.1699 +      in
  4.1700 +        map2 explore paramss arg_ts
  4.1701 +        |> curry list_comb new_fn
  4.1702 +      end;
  4.1703 +
  4.1704 +    fun massage_map_corec explore {bound_Ts, U, T, ...} t =
  4.1705 +      let val explore' = explore ooo build_params in
  4.1706 +        massage_nested_corec_call ctxt has_self_call explore' explore' bound_Ts U T t
  4.1707 +      end;
  4.1708 +
  4.1709 +    fun massage_comp explore params t =
  4.1710 +      (case strip_comb t of
  4.1711 +        (Const (@{const_name comp}, _), f1 :: f2 :: args) =>
  4.1712 +        explore params (betapply (f1, (betapplys (f2, args))))
  4.1713 +      | _ => explore params t);
  4.1714 +
  4.1715 +    fun massage_fun explore (params as {bound_Us, bound_Ts, U, T}) t =
  4.1716 +      if can dest_funT T then
  4.1717 +        let
  4.1718 +          val arg_T = domain_type T;
  4.1719 +          val arg_name = the_default Name.uu (try (fn (Abs (s, _, _)) => s) t);
  4.1720 +        in
  4.1721 +          add_boundvar t
  4.1722 +          |> explore {bound_Us = arg_T :: bound_Us, bound_Ts = arg_T :: bound_Ts,
  4.1723 +             U = range_type U, T = range_type T}
  4.1724 +          |> (fn t => Abs (arg_name, arg_T, t))
  4.1725 +        end
  4.1726 +      else
  4.1727 +        explore params t
  4.1728 +
  4.1729 +    fun massage_let_if_case_corec explore {bound_Ts, U, T, ...} t =
  4.1730 +      massage_let_if_case ctxt has_self_call (fn bound_Ts => explore (build_params bound_Ts U T))
  4.1731 +        (K (unexpected_corec_call ctxt [t])) (K (unsupported_case_around_corec_call ctxt [t]))
  4.1732 +        bound_Ts t;
  4.1733 +
  4.1734 +    val massage_map_let_if_case =
  4.1735 +      massage_star [massage_map_corec, massage_fun, massage_comp, massage_let_if_case_corec];
  4.1736 +
  4.1737 +    fun explore_arg _ t =
  4.1738 +      if has_self_call t then
  4.1739 +        error (quote (Syntax.string_of_term ctxt t) ^ " contains a nested corecursive call" ^
  4.1740 +          (if could_be_friend then " (try specifying \"(friend)\")" else ""))
  4.1741 +      else
  4.1742 +        t;
  4.1743 +
  4.1744 +    fun explore_inner params t =
  4.1745 +      massage_map_let_if_case explore_inner_general params t
  4.1746 +    and explore_inner_general (params as {bound_Ts, T, ...}) t =
  4.1747 +      if T = res_T then
  4.1748 +        let val (f_t, arg_ts) = strip_comb t in
  4.1749 +          if has_self_call t then
  4.1750 +            (case as_member_of (#friends inner_buffer) f_t of
  4.1751 +              SOME (_, friend') =>
  4.1752 +              rebuild_function_after_exploration friend' explore_inner params arg_ts
  4.1753 +              |> curry (op $) (#Oper inner_buffer)
  4.1754 +            | NONE =>
  4.1755 +              (case as_member_of ctr_guards f_t of
  4.1756 +                SOME ctr_guard' =>
  4.1757 +                rebuild_function_after_exploration ctr_guard' explore_inner params arg_ts
  4.1758 +                |> curry (op $) (#ctr_wrapper inner_buffer)
  4.1759 +                |> curry (op $) (#Oper inner_buffer)
  4.1760 +              | NONE =>
  4.1761 +                if is_self_call f_t then
  4.1762 +                  if friend andalso exists has_self_call arg_ts then
  4.1763 +                    (case Symtab.lookup (#friends inner_buffer) fun_name of
  4.1764 +                      SOME (_, friend') =>
  4.1765 +                      rebuild_function_after_exploration friend' explore_inner params arg_ts
  4.1766 +                      |> curry (op $) (#Oper inner_buffer))
  4.1767 +                  else
  4.1768 +                    let val arg_Ts = binder_types (fastype_of1 (bound_Ts, f_t)) in
  4.1769 +                      map2 explore_arg (map2 (update_UT params) arg_Ts arg_Ts) arg_ts
  4.1770 +                      |> mk_tuple1_balanced bound_Ts
  4.1771 +                      |> curry (op $) (#VLeaf inner_buffer)
  4.1772 +                    end
  4.1773 +                else
  4.1774 +                  error (quote (Syntax.string_of_term ctxt f_t) ^ " not registered as friend")))
  4.1775 +          else
  4.1776 +            #CLeaf inner_buffer $ t
  4.1777 +        end
  4.1778 +      else if has_self_call t then
  4.1779 +        error (quote (Syntax.string_of_term ctxt t) ^ " contains a corecursive call but has type " ^
  4.1780 +          quote (Syntax.string_of_typ ctxt T))
  4.1781 +      else
  4.1782 +        explore_nested ctxt explore_inner_general params t;
  4.1783 +
  4.1784 +    fun explore_outer params t =
  4.1785 +      massage_map_let_if_case explore_outer_general params t
  4.1786 +    and explore_outer_general (params as {bound_Ts, T, ...}) t =
  4.1787 +      if T = res_T then
  4.1788 +        let val (f_t, arg_ts) = strip_comb t in
  4.1789 +          (case as_member_of ctr_guards f_t of
  4.1790 +            SOME ctr_guard' =>
  4.1791 +            rebuild_function_after_exploration ctr_guard' explore_inner params arg_ts
  4.1792 +            |> curry (op $) (#VLeaf outer_buffer)
  4.1793 +          | NONE =>
  4.1794 +            if not (has_self_call t) then
  4.1795 +              t
  4.1796 +              |> expand_to_ctr_term ctxt T
  4.1797 +              |> massage_let_if_case_corec explore_outer_general params
  4.1798 +            else
  4.1799 +              (case as_member_of (#friends outer_buffer) f_t of
  4.1800 +                SOME (_, friend') =>
  4.1801 +                rebuild_function_after_exploration friend' explore_outer params arg_ts
  4.1802 +                |> curry (op $) (#Oper outer_buffer)
  4.1803 +              | NONE =>
  4.1804 +                if is_self_call f_t then
  4.1805 +                  let val arg_Ts = binder_types (fastype_of1 (bound_Ts, f_t)) in
  4.1806 +                    map2 explore_arg (map2 (update_UT params) arg_Ts arg_Ts) arg_ts
  4.1807 +                    |> mk_tuple1_balanced bound_Ts
  4.1808 +                    |> curry (op $) (inner_fp_of f_t)
  4.1809 +                  end
  4.1810 +                else
  4.1811 +                  error (quote (Syntax.string_of_term ctxt f_t) ^ " not registered as friend")))
  4.1812 +        end
  4.1813 +      else if has_self_call t then
  4.1814 +        error (quote (Syntax.string_of_term ctxt t) ^ " contains a corecursive call but has type " ^
  4.1815 +          quote (Syntax.string_of_typ ctxt T))
  4.1816 +      else
  4.1817 +        explore_nested ctxt explore_outer_general params t;
  4.1818 +  in
  4.1819 +    (args, rhs
  4.1820 +      |> explore_outer (build_params [] outer_ssig_T res_T)
  4.1821 +      |> abs_tuple_balanced args)
  4.1822 +  end;
  4.1823 +
  4.1824 +fun mk_corec_fun_def_rhs ctxt arg_Ts corecUU0 corecUU_arg =
  4.1825 +  let val corecUU = enforce_type ctxt domain_type (fastype_of corecUU_arg) corecUU0 in
  4.1826 +    abs_curried_balanced arg_Ts (corecUU $ unfold_id_bnf_etc ctxt corecUU_arg)
  4.1827 +  end;
  4.1828 +
  4.1829 +fun get_options ctxt opts =
  4.1830 +  let
  4.1831 +    val plugins = get_first (fn Plugins_Option f => SOME (f ctxt) | _ => NONE) (rev opts)
  4.1832 +      |> the_default Plugin_Name.default_filter;
  4.1833 +    val friend = exists (can (fn Friend_Option => ())) opts;
  4.1834 +    val transfer = exists (can (fn Transfer_Option => ())) opts;
  4.1835 +  in
  4.1836 +    (plugins, friend, transfer)
  4.1837 +  end;
  4.1838 +
  4.1839 +fun add_function name parsed_eq lthy =
  4.1840 +  let
  4.1841 +    fun pat_completeness_auto ctxt =
  4.1842 +      Pat_Completeness.pat_completeness_tac ctxt 1 THEN auto_tac ctxt;
  4.1843 +
  4.1844 +    val ({defname, pelims = [[pelim]], pinducts = [pinduct], psimps = [psimp], ...}, lthy) =
  4.1845 +      Function.add_function [(Binding.concealed (Binding.name name), NONE, NoSyn)]
  4.1846 +        [(apfst Binding.concealed Attrib.empty_binding, parsed_eq)]
  4.1847 +        Function_Common.default_config pat_completeness_auto lthy;
  4.1848 +  in
  4.1849 +    ((defname, (pelim, pinduct, psimp)), lthy)
  4.1850 +  end;
  4.1851 +
  4.1852 +fun build_corecUU_arg_and_goals prove_termin (Free (fun_base_name, _)) (arg_ts, explored_rhs) lthy =
  4.1853 +  let
  4.1854 +    val inner_fp_name0 = fun_base_name ^ inner_fp_suffix;
  4.1855 +    val inner_fp_free = Free (inner_fp_name0, fastype_of explored_rhs);
  4.1856 +  in
  4.1857 +    if Term.exists_subterm (curry (op aconv) inner_fp_free) explored_rhs then
  4.1858 +      let
  4.1859 +        val arg = mk_tuple_balanced arg_ts;
  4.1860 +        val inner_fp_eq =
  4.1861 +          mk_Trueprop_eq (betapply (inner_fp_free, arg), betapply (explored_rhs, arg));
  4.1862 +
  4.1863 +        val ((inner_fp_name, (pelim, pinduct, psimp)), lthy') =
  4.1864 +          add_function inner_fp_name0 inner_fp_eq lthy;
  4.1865 +
  4.1866 +        fun mk_triple elim induct simp = ([elim], [induct], [simp]);
  4.1867 +
  4.1868 +        fun prepare_termin () =
  4.1869 +          let
  4.1870 +            val {goal, ...} = Proof.goal (Function.termination NONE lthy');
  4.1871 +            val termin_goal = goal |> Thm.concl_of |> Logic.unprotect |> Envir.beta_eta_contract;
  4.1872 +          in
  4.1873 +            (lthy', (mk_triple pelim pinduct psimp, [termin_goal]))
  4.1874 +          end;
  4.1875 +
  4.1876 +        val (lthy'', (inner_fp_triple, termin_goals)) =
  4.1877 +          if prove_termin then
  4.1878 +            (case try (Function.prove_termination NONE
  4.1879 +                (Function_Common.termination_prover_tac true lthy')) lthy' of
  4.1880 +              NONE => prepare_termin ()
  4.1881 +            | SOME ({elims = SOME [[elim]], inducts = SOME [induct], simps = SOME [simp], ...},
  4.1882 +                lthy'') =>
  4.1883 +              (lthy'', (mk_triple elim induct simp, [])))
  4.1884 +          else
  4.1885 +            prepare_termin ();
  4.1886 +
  4.1887 +        val inner_fp_const = (inner_fp_name, fastype_of explored_rhs)
  4.1888 +          |>> Proof_Context.read_const {proper = true, strict = false} lthy'
  4.1889 +          |> (fn (Const (s, _), T) => Const (s, T));
  4.1890 +      in
  4.1891 +        (((inner_fp_triple, termin_goals), inner_fp_const), lthy'')
  4.1892 +      end
  4.1893 +    else
  4.1894 +      (((([], [], []), []), explored_rhs), lthy)
  4.1895 +  end;
  4.1896 +
  4.1897 +fun derive_eq_corecUU ctxt {sig_fp_sugars, ssig_fp_sugar, eval, corecUU, eval_simps,
  4.1898 +      all_algLam_algs, corecUU_unique, ...}
  4.1899 +    fun_t corecUU_arg fun_code =
  4.1900 +  let
  4.1901 +    val fun_T = fastype_of fun_t;
  4.1902 +    val (arg_Ts, Type (fpT_name, _)) = strip_type fun_T;
  4.1903 +    val num_args = length arg_Ts;
  4.1904 +
  4.1905 +    val SOME {pre_bnf, fp_bnf, absT_info, fp_nesting_bnfs, live_nesting_bnfs, fp_ctr_sugar, ...} =
  4.1906 +      fp_sugar_of ctxt fpT_name;
  4.1907 +    val SOME {case_trivial, ...} = codatatype_extra_of ctxt fpT_name;
  4.1908 +
  4.1909 +    val ctr_sugar = #ctr_sugar fp_ctr_sugar;
  4.1910 +    val pre_map_def = map_def_of_bnf pre_bnf;
  4.1911 +    val abs_inverse = #abs_inverse absT_info;
  4.1912 +    val ctr_defs = #ctr_defs fp_ctr_sugar;
  4.1913 +    val case_eq_ifs = #case_eq_ifs ctr_sugar @ case_eq_if_thms_of_term ctxt (Thm.prop_of fun_code);
  4.1914 +    val all_sig_map_thms = maps (#map_thms o #fp_bnf_sugar) sig_fp_sugars;
  4.1915 +
  4.1916 +    val fp_map_ident = map_ident_of_bnf fp_bnf;
  4.1917 +    val fpsig_nesting_bnfs = fp_nesting_bnfs @ maps #live_nesting_bnfs sig_fp_sugars;
  4.1918 +    val fpsig_nesting_T_names = map (fst o dest_Type o T_of_bnf) fpsig_nesting_bnfs;
  4.1919 +    val fpsig_nesting_fp_sugars = map_filter (fp_sugar_of ctxt) fpsig_nesting_T_names;
  4.1920 +    val fpsig_nesting_fp_bnf_sugars = map #fp_bnf_sugar fpsig_nesting_fp_sugars;
  4.1921 +    val ssig_fp_bnf_sugar = #fp_bnf_sugar ssig_fp_sugar;
  4.1922 +    val ssig_bnf = #fp_bnf ssig_fp_sugar;
  4.1923 +    val ssig_map = map_of_bnf ssig_bnf;
  4.1924 +    val fpsig_nesting_maps = map map_of_bnf fpsig_nesting_bnfs;
  4.1925 +    val fpsig_nesting_map_ident0s = map map_ident0_of_bnf fpsig_nesting_bnfs;
  4.1926 +    val fpsig_nesting_map_comps = map map_comp_of_bnf fpsig_nesting_bnfs;
  4.1927 +    val fpsig_nesting_map_thms = maps #map_thms fpsig_nesting_fp_bnf_sugars;
  4.1928 +    val live_nesting_map_ident0s = map map_ident0_of_bnf live_nesting_bnfs;
  4.1929 +    val ssig_map_thms = #map_thms ssig_fp_bnf_sugar;
  4.1930 +    val all_algLam_alg_pointfuls = map (mk_pointful ctxt) all_algLam_algs;
  4.1931 +
  4.1932 +    val def_rhs = mk_corec_fun_def_rhs ctxt arg_Ts corecUU corecUU_arg;
  4.1933 +
  4.1934 +    val goal = mk_Trueprop_eq (fun_t, def_rhs);
  4.1935 +  in
  4.1936 +    Goal.prove_sorry ctxt [] [] goal (fn {context = ctxt, prems = _} =>
  4.1937 +      mk_eq_corecUU_tac ctxt num_args fpsig_nesting_maps ssig_map eval pre_map_def abs_inverse
  4.1938 +        fpsig_nesting_map_ident0s fpsig_nesting_map_comps fpsig_nesting_map_thms
  4.1939 +        live_nesting_map_ident0s fp_map_ident case_trivial ctr_defs case_eq_ifs all_sig_map_thms
  4.1940 +        ssig_map_thms all_algLam_alg_pointfuls (all_algrho_eqs_of ctxt) eval_simps corecUU_unique
  4.1941 +        fun_code)
  4.1942 +    |> Thm.close_derivation
  4.1943 +  end;
  4.1944 +
  4.1945 +fun derive_coinduct_cong_intros
  4.1946 +    ({fpT = fpT0 as Type (fpT_name, _), friend_names = friend_names0,
  4.1947 +      corecUU = Const (corecUU_name, _), dtor_coinduct_info as {dtor_coinduct, ...}, ...})
  4.1948 +    lthy =
  4.1949 +  let
  4.1950 +    val thy = Proof_Context.theory_of lthy;
  4.1951 +    val phi = Proof_Context.export_morphism lthy (Local_Theory.target_of lthy);
  4.1952 +
  4.1953 +    val fpT = Morphism.typ phi fpT0;
  4.1954 +    val general_fpT = body_type (Sign.the_const_type thy corecUU_name);
  4.1955 +    val most_general = Sign.typ_instance thy (general_fpT, fpT);
  4.1956 +  in
  4.1957 +    (case (most_general, coinduct_extra_of lthy corecUU_name) of
  4.1958 +      (true, SOME extra) => ((false, extra), lthy)
  4.1959 +    | _ =>
  4.1960 +      let
  4.1961 +        val ctr_names = ctr_names_of_fp_name lthy fpT_name;
  4.1962 +        val friend_names = friend_names0 |> map Long_Name.base_name |> rev;
  4.1963 +        val cong_intro_tab = derive_cong_intros lthy ctr_names friend_names dtor_coinduct_info;
  4.1964 +        val (coinduct, coinduct_attrs) = derive_coinduct lthy fpT0 dtor_coinduct;
  4.1965 +        val ((_, [coinduct]), lthy) = (* TODO check: only if most_general?*)
  4.1966 +          Local_Theory.note ((Binding.empty, coinduct_attrs), [coinduct]) lthy;
  4.1967 +
  4.1968 +        val extra = {coinduct = coinduct, coinduct_attrs = coinduct_attrs,
  4.1969 +          cong_intro_tab = cong_intro_tab};
  4.1970 +      in
  4.1971 +        ((most_general, extra), lthy |> most_general ? register_coinduct_extra corecUU_name extra)
  4.1972 +      end)
  4.1973 +  end;
  4.1974 +
  4.1975 +fun update_coinduct_cong_intross_dynamic fpT_name lthy =
  4.1976 +  let
  4.1977 +    val all_corec_infos = corec_infos_of lthy fpT_name;
  4.1978 +  in
  4.1979 +    lthy
  4.1980 +    |> fold_map (apfst snd oo derive_coinduct_cong_intros) all_corec_infos
  4.1981 +    |> snd
  4.1982 +  end;
  4.1983 +
  4.1984 +fun derive_and_update_coinduct_cong_intross [] = pair (false, [])
  4.1985 +  | derive_and_update_coinduct_cong_intross (corec_infos as {fpT = Type (fpT_name, _), ...} :: _) =
  4.1986 +    fold_map derive_coinduct_cong_intros corec_infos
  4.1987 +    #>> split_list
  4.1988 +    #> (fn ((changeds, extras), lthy) =>
  4.1989 +      if exists I changeds then
  4.1990 +        ((true, extras), lthy |> update_coinduct_cong_intross_dynamic fpT_name)
  4.1991 +      else
  4.1992 +        ((false, extras), lthy));
  4.1993 +
  4.1994 +fun prepare_corec_ursive_cmd long_cmd opts (raw_fixes, raw_eq) lthy =
  4.1995 +  let
  4.1996 +    val _ = can the_single raw_fixes orelse
  4.1997 +      error "Mutually corecursive functions not supported";
  4.1998 +
  4.1999 +    val (plugins, friend, transfer) = get_options lthy opts;
  4.2000 +    val ([((b, fun_T), mx)], [(_, eq)]) =
  4.2001 +      fst (Specification.read_spec raw_fixes [(Attrib.empty_binding, raw_eq)] lthy);
  4.2002 +
  4.2003 +    val _ = Sign.of_sort (Proof_Context.theory_of lthy) (fun_T, @{sort type}) orelse
  4.2004 +      error ("Type of " ^ Binding.print b ^ " contains top sort");
  4.2005 +
  4.2006 +    val (arg_Ts, res_T) = strip_type fun_T;
  4.2007 +    val fpT_name = (case res_T of Type (s, _) => s | _ => not_codatatype lthy res_T);
  4.2008 +    val fun_free = Free (Binding.name_of b, fun_T);
  4.2009 +    val parsed_eq = parse_corec_equation lthy [fun_free] eq;
  4.2010 +
  4.2011 +    val fun_name = Local_Theory.full_name lthy b;
  4.2012 +    val fun_t = Const (fun_name, fun_T);
  4.2013 +      (* FIXME: does this work with locales that fix variables? *)
  4.2014 +
  4.2015 +    val no_base = has_no_corec_info lthy fpT_name;
  4.2016 +    val lthy = lthy |> no_base ? setup_base fpT_name;
  4.2017 +
  4.2018 +    fun extract_rho lthy =
  4.2019 +      let
  4.2020 +        val lthy = lthy |> Variable.declare_typ fun_T;
  4.2021 +        val (prepared as (_, _, version, Y, Z, preT, k_T, ssig_T, dead_pre_bnf, dead_k_bnf, _,
  4.2022 +               ssig_fp_sugar, buffer), lthy) =
  4.2023 +          prepare_friend_corec fun_name fun_T lthy;
  4.2024 +        val friend_parse_info = friend_parse_info_of lthy arg_Ts res_T buffer;
  4.2025 +
  4.2026 +        val parsed_eq' = parsed_eq ||> subst_atomic [(fun_free, fun_t)];
  4.2027 +      in
  4.2028 +        lthy
  4.2029 +        |> extract_rho_return_transfer_goals b version dead_pre_bnf dead_k_bnf Y Z preT fun_T k_T
  4.2030 +          ssig_T ssig_fp_sugar friend_parse_info fun_t parsed_eq'
  4.2031 +        |>> pair prepared
  4.2032 +      end;
  4.2033 +
  4.2034 +    val ((prepareds, (rho_datas, transfer_goal_datas)), lthy) =
  4.2035 +      if friend then extract_rho lthy |>> (apfst single ##> (apfst single #> apsnd single))
  4.2036 +      else (([], ([], [])), lthy);
  4.2037 +
  4.2038 +    val ((buffer, corec_infos), lthy) =
  4.2039 +      if friend then
  4.2040 +        ((#13 (the_single prepareds), []), lthy)
  4.2041 +      else
  4.2042 +        corec_info_of res_T lthy
  4.2043 +        ||> no_base ? update_coinduct_cong_intross_dynamic fpT_name
  4.2044 +        |>> (fn info as {buffer, ...} => (buffer, [info]));
  4.2045 +
  4.2046 +    val corec_parse_info = corec_parse_info_of lthy arg_Ts res_T buffer;
  4.2047 +
  4.2048 +    val explored_eq =
  4.2049 +      explore_corec_equation lthy true friend fun_name fun_free corec_parse_info res_T parsed_eq;
  4.2050 +
  4.2051 +    val (((inner_fp_triple, termin_goals), corecUU_arg), lthy) =
  4.2052 +      build_corecUU_arg_and_goals (not long_cmd) fun_free explored_eq lthy;
  4.2053 +
  4.2054 +    fun def_fun (inner_fp_elims0, inner_fp_inducts0, inner_fp_simps0) const_transfers
  4.2055 +        rho_transfers_foldeds lthy =
  4.2056 +      let
  4.2057 +        fun register_friend lthy =
  4.2058 +          let
  4.2059 +            val [(old_corec_info, fp_b, version, Y, Z, _, k_T, _, _, dead_k_bnf, sig_fp_sugar,
  4.2060 +                  ssig_fp_sugar, _)] = prepareds;
  4.2061 +            val [(rho, rho_def)] = rho_datas;
  4.2062 +            val [(_, rho_transfer_goal)] = transfer_goal_datas;
  4.2063 +            val Type (fpT_name, _) = res_T;
  4.2064 +
  4.2065 +            val rho_transfer_folded =
  4.2066 +              (case rho_transfers_foldeds of
  4.2067 +                [] =>
  4.2068 +                derive_rho_transfer_folded lthy fpT_name const_transfers rho_def rho_transfer_goal
  4.2069 +              | [thm] => thm);
  4.2070 +          in
  4.2071 +            lthy
  4.2072 +            |> register_coinduct_dynamic_friend fpT_name fun_name
  4.2073 +            |> register_friend_corec fun_name fp_b version Y Z k_T dead_k_bnf sig_fp_sugar
  4.2074 +              ssig_fp_sugar fun_t rho rho_transfer_folded old_corec_info
  4.2075 +          end;
  4.2076 +
  4.2077 +        val (friend_infos, lthy) = lthy |> (if friend then register_friend #>> single else pair []);
  4.2078 +        val (corec_info as {corecUU = corecUU0, ...}, lthy) =
  4.2079 +          (case corec_infos of
  4.2080 +            [] => corec_info_of res_T lthy
  4.2081 +          | [info] => (info, lthy));
  4.2082 +
  4.2083 +        val def_rhs = mk_corec_fun_def_rhs lthy arg_Ts corecUU0 corecUU_arg;
  4.2084 +        val def = ((b, mx), ((Binding.concealed (Thm.def_binding b), []), def_rhs));
  4.2085 +
  4.2086 +        val ((fun_t0, (_, fun_def0)), (lthy, lthy_old)) = lthy
  4.2087 +          |> Local_Theory.open_target |> snd
  4.2088 +          |> Local_Theory.define def
  4.2089 +          ||> `Local_Theory.close_target;
  4.2090 +
  4.2091 +        val parsed_eq = parse_corec_equation lthy [fun_free] eq;
  4.2092 +        val views0 = generate_views lthy eq fun_free parsed_eq;
  4.2093 +
  4.2094 +        val lthy' = lthy |> fold Variable.declare_typ (res_T :: arg_Ts);
  4.2095 +        val phi = Proof_Context.export_morphism lthy_old lthy';
  4.2096 +
  4.2097 +        val fun_t = Morphism.term phi fun_t0; (* FIXME: shadows "fun_t" -- identical? *)
  4.2098 +        val fun_def = Morphism.thm phi fun_def0;
  4.2099 +        val inner_fp_elims = map (Morphism.thm phi) inner_fp_elims0;
  4.2100 +        val inner_fp_inducts = map (Morphism.thm phi) inner_fp_inducts0;
  4.2101 +        val inner_fp_simps = map (Morphism.thm phi) inner_fp_simps0;
  4.2102 +        val (code_goal, _, _, _, _) = morph_views phi views0;
  4.2103 +
  4.2104 +        fun derive_and_note_friend_extra_theorems lthy =
  4.2105 +          let
  4.2106 +            val k_T = #7 (the_single prepareds);
  4.2107 +            val rho_def = snd (the_single rho_datas);
  4.2108 +
  4.2109 +            val (eq_algrho, algrho_eq) = derive_eq_algrho lthy corec_info (the_single friend_infos)
  4.2110 +              fun_t k_T code_goal const_transfers rho_def fun_def;
  4.2111 +
  4.2112 +            val notes =
  4.2113 +              (if Config.get lthy bnf_internals then
  4.2114 +                 [(eq_algrhoN, [eq_algrho])]
  4.2115 +               else
  4.2116 +                 [])
  4.2117 +              |> map (fn (thmN, thms) =>
  4.2118 +                ((Binding.qualify true (Binding.name_of b)
  4.2119 +                    (Binding.qualify false friendN (Binding.name thmN)), []),
  4.2120 +                 [(thms, [])]));
  4.2121 +          in
  4.2122 +            lthy
  4.2123 +            |> register_friend_extra fun_name eq_algrho algrho_eq
  4.2124 +            |> Local_Theory.notes notes |> snd
  4.2125 +          end;
  4.2126 +
  4.2127 +        val lthy = lthy |> friend ? derive_and_note_friend_extra_theorems;
  4.2128 +
  4.2129 +        val code_thm = derive_code lthy inner_fp_simps code_goal corec_info res_T fun_t fun_def;
  4.2130 +(* TODO:
  4.2131 +        val ctr_thmss = map mk_thm (#2 views);
  4.2132 +        val disc_thmss = map mk_thm (#3 views);
  4.2133 +        val disc_iff_thmss = map mk_thm (#4 views);
  4.2134 +        val sel_thmss = map mk_thm (#5 views);
  4.2135 +*)
  4.2136 +
  4.2137 +        val uniques =
  4.2138 +          if null inner_fp_simps then [derive_unique lthy phi (#1 views0) corec_info res_T fun_def]
  4.2139 +          else [];
  4.2140 +
  4.2141 +(* TODO:
  4.2142 +        val disc_iff_or_disc_thmss =
  4.2143 +          map2 (fn [] => I | disc_iffs => K disc_iffs) disc_iff_thmss disc_thmss;
  4.2144 +        val simp_thmss = map2 append disc_iff_or_disc_thmss sel_thmss;
  4.2145 +*)
  4.2146 +
  4.2147 +        val ((_, [{cong_intro_tab, coinduct, coinduct_attrs}]), lthy) = lthy
  4.2148 +          |> derive_and_update_coinduct_cong_intross [corec_info];
  4.2149 +        val cong_intros_pairs = Symtab.dest cong_intro_tab;
  4.2150 +
  4.2151 +        val code_attrs = if plugins code_plugin then [Code.add_default_eqn_attrib] else [];
  4.2152 +
  4.2153 +        val anonymous_notes = [];
  4.2154 +(* TODO:
  4.2155 +          [(flat disc_iff_or_disc_thmss, simp_attrs)]
  4.2156 +          |> map (fn (thms, attrs) => ((Binding.empty, attrs), [(thms, [])]));
  4.2157 +*)
  4.2158 +
  4.2159 +        val notes =
  4.2160 +          [(cong_introsN, maps snd cong_intros_pairs, []),
  4.2161 +           (codeN, [code_thm], code_attrs @ nitpicksimp_attrs),
  4.2162 +           (coinductN, [coinduct], coinduct_attrs),
  4.2163 +           (inner_inductN, inner_fp_inducts, []),
  4.2164 +           (uniqueN, uniques, [])] @
  4.2165 +           map (fn (thmN, thms) => (thmN, thms, [])) cong_intros_pairs @
  4.2166 +          (if Config.get lthy bnf_internals then
  4.2167 +             [(inner_elimN, inner_fp_elims, []),
  4.2168 +              (inner_simpN, inner_fp_simps, [])]
  4.2169 +           else
  4.2170 +             [])
  4.2171 +(* TODO:
  4.2172 +           (ctrN, ctr_thms, []),
  4.2173 +           (discN, disc_thms, []),
  4.2174 +           (disc_iffN, disc_iff_thms, []),
  4.2175 +           (selN, sel_thms, simp_attrs),
  4.2176 +           (simpsN, simp_thms, []),
  4.2177 +*)
  4.2178 +          |> map (fn (thmN, thms, attrs) =>
  4.2179 +              ((Binding.qualify true (Binding.name_of b)
  4.2180 +                  (Binding.qualify false corecN (Binding.name thmN)), attrs),
  4.2181 +               [(thms, [])]))
  4.2182 +          |> filter_out (null o fst o hd o snd);
  4.2183 +      in
  4.2184 +        lthy
  4.2185 +(* TODO:
  4.2186 +        |> Spec_Rules.add Spec_Rules.Equational ([fun_t0], flat sel_thmss)
  4.2187 +        |> Spec_Rules.add Spec_Rules.Equational ([fun_t0], flat ctr_thmss)
  4.2188 +*)
  4.2189 +        |> Spec_Rules.add Spec_Rules.Equational ([fun_t0], [code_thm])
  4.2190 +        |> Local_Theory.notes (anonymous_notes @ notes)
  4.2191 +        |> snd
  4.2192 +      end;
  4.2193 +
  4.2194 +    fun prove_transfer_goal ctxt goal =
  4.2195 +      Variable.add_free_names ctxt goal []
  4.2196 +      |> (fn vars => Goal.prove_sorry (*FIXME*) (*no sorry*) ctxt vars [] goal (fn {context = ctxt, prems = _} =>
  4.2197 +        HEADGOAL (Transfer.transfer_prover_tac ctxt)))
  4.2198 +      |> Thm.close_derivation;
  4.2199 +
  4.2200 +    fun maybe_prove_transfer_goal ctxt goal =
  4.2201 +      (case try (prove_transfer_goal ctxt) goal of
  4.2202 +        SOME thm => apfst (cons thm)
  4.2203 +      | NONE => apsnd (cons goal));
  4.2204 +
  4.2205 +    val const_transfer_goals = fold (union (op aconv) o fst) transfer_goal_datas [];
  4.2206 +    val (const_transfers, const_transfer_goals') =
  4.2207 +      if long_cmd then ([], const_transfer_goals)
  4.2208 +      else fold (maybe_prove_transfer_goal lthy) const_transfer_goals ([], []);
  4.2209 +  in
  4.2210 +    ((def_fun, (([res_T], prepareds, rho_datas, map snd transfer_goal_datas),
  4.2211 +        (inner_fp_triple, termin_goals), (const_transfers, const_transfer_goals'))), lthy)
  4.2212 +  end;
  4.2213 +
  4.2214 +fun corec_cmd opts (raw_fixes, raw_eq) lthy =
  4.2215 +  let
  4.2216 +    val ((def_fun, (_, (inner_fp_triple, termin_goals), (const_transfers, const_transfer_goals))),
  4.2217 +         lthy) =
  4.2218 +      prepare_corec_ursive_cmd false opts (raw_fixes, raw_eq) lthy;
  4.2219 +  in
  4.2220 +    if not (null termin_goals) then
  4.2221 +      error ("Termination prover failed (try " ^ quote (#1 @{command_keyword corecursive}) ^
  4.2222 +        " instead of " ^ quote (#1 @{command_keyword corec}) ^ ")")
  4.2223 +    else if not (null const_transfer_goals) then
  4.2224 +      error ("Transfer prover failed (try " ^ quote (#1 @{command_keyword corecursive}) ^
  4.2225 +        " instead of " ^ quote (#1 @{command_keyword corec}) ^ ")")
  4.2226 +    else
  4.2227 +      def_fun inner_fp_triple const_transfers [] lthy
  4.2228 +  end;
  4.2229 +
  4.2230 +fun corecursive_cmd opts (raw_fixes, raw_eq) lthy =
  4.2231 +  let
  4.2232 +    val ((def_fun, (([Type (fpT_name, _)], prepareds, rho_datas, rho_transfer_goals),
  4.2233 +            (inner_fp_triple, termin_goals), (const_transfers, const_transfer_goals))), lthy) =
  4.2234 +      prepare_corec_ursive_cmd true opts (raw_fixes, raw_eq) lthy;
  4.2235 +
  4.2236 +    val (rho_transfer_goals', unprime_rho_transfer_and_folds) =
  4.2237 +      @{map 3} (fn (_, _, _, _, _, _, _, _, _, _, _, _, _) => fn (_, rho_def) =>
  4.2238 +          prime_rho_transfer_goal lthy fpT_name rho_def)
  4.2239 +        prepareds rho_datas rho_transfer_goals
  4.2240 +      |> split_list;
  4.2241 +  in
  4.2242 +    Proof.theorem NONE (fn [termin_thms, const_transfers', rho_transfers'] =>
  4.2243 +      let
  4.2244 +        val remove_domain_condition =
  4.2245 +          full_simplify (put_simpset HOL_basic_ss lthy
  4.2246 +            addsimps (@{thm True_implies_equals} :: termin_thms));
  4.2247 +      in
  4.2248 +        def_fun (@{apply 3} (map remove_domain_condition) inner_fp_triple)
  4.2249 +          (const_transfers @ const_transfers')
  4.2250 +          (map2 (fn f => f) unprime_rho_transfer_and_folds rho_transfers')
  4.2251 +      end)
  4.2252 +      (map (map (rpair [])) [termin_goals, const_transfer_goals, rho_transfer_goals']) lthy
  4.2253 +  end;
  4.2254 +
  4.2255 +fun friend_of_corec_cmd ((raw_fun_name, raw_fun_T_opt), raw_eq) lthy =
  4.2256 +  let
  4.2257 +    val Const (fun_name, default_fun_T0) =
  4.2258 +      Proof_Context.read_const {proper = true, strict = false} lthy raw_fun_name;
  4.2259 +    val fun_T =
  4.2260 +      (case raw_fun_T_opt of
  4.2261 +        SOME raw_T => Syntax.read_typ lthy raw_T
  4.2262 +      | NONE => singleton (freeze_types lthy []) default_fun_T0);
  4.2263 +
  4.2264 +    val fun_t = Const (fun_name, fun_T);
  4.2265 +    val fun_b = Binding.name (Long_Name.base_name fun_name);
  4.2266 +
  4.2267 +    val fake_lthy = lthy |> Proof_Context.add_const_constraint (fun_name, SOME fun_T)
  4.2268 +      handle TYPE (msg, _, _) => error msg;
  4.2269 +
  4.2270 +    val code_goal = Syntax.read_prop fake_lthy raw_eq;
  4.2271 +
  4.2272 +    val (arg_Ts, res_T as Type (fpT_name, _)) = strip_type fun_T;
  4.2273 +
  4.2274 +    val no_base = has_no_corec_info lthy fpT_name;
  4.2275 +    val lthy = lthy |> no_base ? setup_base fpT_name;
  4.2276 +
  4.2277 +    val lthy = lthy |> Variable.declare_typ fun_T;
  4.2278 +    val ((old_corec_info, fp_b, version, Y, Z, preT, k_T, ssig_T, dead_pre_bnf, dead_k_bnf,
  4.2279 +          sig_fp_sugar, ssig_fp_sugar, buffer), lthy) =
  4.2280 +      prepare_friend_corec fun_name fun_T lthy;
  4.2281 +    val friend_parse_info = friend_parse_info_of lthy arg_Ts res_T buffer;
  4.2282 +
  4.2283 +    val parsed_eq = parse_corec_equation lthy [] code_goal;
  4.2284 +
  4.2285 +    val (((rho, rho_def), (const_transfer_goals, rho_transfer_goal)), lthy) =
  4.2286 +      extract_rho_return_transfer_goals fun_b version dead_pre_bnf dead_k_bnf Y Z preT fun_T k_T
  4.2287 +        ssig_T ssig_fp_sugar friend_parse_info fun_t parsed_eq lthy;
  4.2288 +
  4.2289 +    fun register_friend_extra_and_note_thms code_goal code_thm const_transfers k_T friend_info
  4.2290 +        lthy =
  4.2291 +      let
  4.2292 +        val (corec_info, lthy) = corec_info_of res_T lthy;
  4.2293 +
  4.2294 +        val fun_free = Free (Binding.name_of fun_b, fun_T);
  4.2295 +
  4.2296 +        fun freeze_fun (t as Const (s, _)) = if s = fun_name then fun_free else t
  4.2297 +          | freeze_fun t = t;
  4.2298 +
  4.2299 +        val eq = Term.map_aterms freeze_fun code_goal;
  4.2300 +        val parsed_eq = parse_corec_equation lthy [fun_free] eq;
  4.2301 +
  4.2302 +        val corec_parse_info = corec_parse_info_of lthy arg_Ts res_T buffer;
  4.2303 +        val explored_eq = explore_corec_equation lthy false false fun_name fun_free corec_parse_info
  4.2304 +          res_T parsed_eq;
  4.2305 +
  4.2306 +        val ((_, corecUU_arg), _) = build_corecUU_arg_and_goals false fun_free explored_eq lthy;
  4.2307 +
  4.2308 +        val eq_corecUU = derive_eq_corecUU lthy corec_info fun_t corecUU_arg code_thm;
  4.2309 +        val (eq_algrho, algrho_eq) = derive_eq_algrho lthy corec_info friend_info fun_t k_T
  4.2310 +          code_goal const_transfers rho_def eq_corecUU;
  4.2311 +
  4.2312 +        val ((_, [{cong_intro_tab, coinduct, coinduct_attrs}]), lthy) = lthy
  4.2313 +          |> register_friend_extra fun_name eq_algrho algrho_eq
  4.2314 +          |> register_coinduct_dynamic_friend fpT_name fun_name
  4.2315 +          |> derive_and_update_coinduct_cong_intross [corec_info];
  4.2316 +        val cong_intros_pairs = Symtab.dest cong_intro_tab;
  4.2317 +
  4.2318 +        val unique = derive_unique lthy Morphism.identity code_goal corec_info res_T eq_corecUU;
  4.2319 +
  4.2320 +        val notes =
  4.2321 +          [(cong_intros_friendN, maps snd cong_intros_pairs, []),
  4.2322 +           (codeN, [code_thm], []),
  4.2323 +           (coinductN, [coinduct], coinduct_attrs),
  4.2324 +           (uniqueN, [unique], [])] @
  4.2325 +           map (fn (thmN, thms) => (thmN, thms, [])) cong_intros_pairs @
  4.2326 +          (if Config.get lthy bnf_internals then
  4.2327 +             [(eq_algrhoN, [eq_algrho], []),
  4.2328 +              (eq_corecUUN, [eq_corecUU], [])]
  4.2329 +           else
  4.2330 +             [])
  4.2331 +          |> map (fn (thmN, thms, attrs) =>
  4.2332 +            ((Binding.qualify true (Binding.name_of fun_b)
  4.2333 +                (Binding.qualify false friendN (Binding.name thmN)), attrs),
  4.2334 +             [(thms, [])]));
  4.2335 +      in
  4.2336 +        lthy
  4.2337 +        |> Local_Theory.notes notes |> snd
  4.2338 +      end;
  4.2339 +
  4.2340 +    val (rho_transfer_goal', unprime_rho_transfer_and_fold) =
  4.2341 +      prime_rho_transfer_goal lthy fpT_name rho_def rho_transfer_goal;
  4.2342 +  in
  4.2343 +    lthy
  4.2344 +    |> Proof.theorem NONE (fn [[code_thm], const_transfers, [rho_transfer']] =>
  4.2345 +        register_friend_corec fun_name fp_b version Y Z k_T dead_k_bnf sig_fp_sugar ssig_fp_sugar
  4.2346 +          fun_t rho (unprime_rho_transfer_and_fold rho_transfer') old_corec_info
  4.2347 +        #-> register_friend_extra_and_note_thms code_goal code_thm const_transfers k_T)
  4.2348 +      (map (map (rpair [])) [[code_goal], const_transfer_goals, [rho_transfer_goal']])
  4.2349 +    |> Proof.refine_singleton (Method.primitive_text (K I))
  4.2350 +  end;
  4.2351 +
  4.2352 +fun coinduction_upto_cmd (base_name, raw_fpT) lthy =
  4.2353 +  let
  4.2354 +    val fpT as Type (fpT_name, _) = Syntax.read_typ lthy raw_fpT;
  4.2355 +
  4.2356 +    val no_base = has_no_corec_info lthy fpT_name;
  4.2357 +
  4.2358 +    val (corec_info as {version, ...}, lthy) = lthy
  4.2359 +      |> corec_info_of fpT;
  4.2360 +    val lthy = lthy |> no_base ? setup_base fpT_name;
  4.2361 +
  4.2362 +    val ((changed, [{cong_intro_tab, coinduct, coinduct_attrs}]), lthy) = lthy
  4.2363 +      |> derive_and_update_coinduct_cong_intross [corec_info];
  4.2364 +    val lthy = lthy |> (changed orelse no_base) ? update_coinduct_cong_intross_dynamic fpT_name;
  4.2365 +    val cong_intros_pairs = Symtab.dest cong_intro_tab;
  4.2366 +
  4.2367 +    val notes =
  4.2368 +      [(cong_introsN, maps snd cong_intros_pairs, []),
  4.2369 +       (coinduct_uptoN, [coinduct], coinduct_attrs)] @
  4.2370 +      map (fn (thmN, thms) => (thmN, thms, [])) cong_intros_pairs
  4.2371 +      |> map (fn (thmN, thms, attrs) =>
  4.2372 +        (((Binding.qualify true base_name
  4.2373 +            (Binding.qualify false ("v" ^ string_of_int version) (Binding.name thmN))), attrs),
  4.2374 +         [(thms, [])]));
  4.2375 +  in
  4.2376 +    lthy |> Local_Theory.notes notes |> snd
  4.2377 +  end;
  4.2378 +
  4.2379 +fun consolidate lthy =
  4.2380 +  let
  4.2381 +    val corec_infoss = map (corec_infos_of lthy o fst) (all_codatatype_extras_of lthy);
  4.2382 +    val (changeds, lthy) = lthy
  4.2383 +      |> fold_map (apfst fst oo derive_and_update_coinduct_cong_intross) corec_infoss;
  4.2384 +  in
  4.2385 +    if exists I changeds then lthy else raise Same.SAME
  4.2386 +  end;
  4.2387 +
  4.2388 +fun consolidate_global thy =
  4.2389 +  SOME (Named_Target.theory_map consolidate thy)
  4.2390 +  handle Same.SAME => NONE;
  4.2391 +
  4.2392 +val _ = Outer_Syntax.local_theory @{command_keyword corec}
  4.2393 +  "define nonprimitive corecursive functions"
  4.2394 +  ((Scan.optional (@{keyword "("} |-- Parse.!!! (Parse.list1 corec_option_parser)
  4.2395 +      --| @{keyword ")"}) []) -- (Parse.fixes --| Parse.where_ -- Parse.prop)
  4.2396 +   >> uncurry corec_cmd);
  4.2397 +
  4.2398 +val _ = Outer_Syntax.local_theory_to_proof @{command_keyword corecursive}
  4.2399 +  "define nonprimitive corecursive functions"
  4.2400 +  ((Scan.optional (@{keyword "("} |-- Parse.!!! (Parse.list1 corec_option_parser)
  4.2401 +      --| @{keyword ")"}) []) -- (Parse.fixes --| Parse.where_ -- Parse.prop)
  4.2402 +   >> uncurry corecursive_cmd);
  4.2403 +
  4.2404 +val _ = Outer_Syntax.local_theory_to_proof @{command_keyword friend_of_corec}
  4.2405 +  "register a function as a legal context for nonprimitive corecursion"
  4.2406 +  (Parse.const -- Scan.option (Parse.$$$ "::" |-- Parse.typ) --| Parse.where_ -- Parse.prop
  4.2407 +   >> friend_of_corec_cmd);
  4.2408 +
  4.2409 +val _ = Outer_Syntax.local_theory @{command_keyword coinduction_upto}
  4.2410 +  "derive a coinduction up-to principle and a corresponding congruence closure"
  4.2411 +  (Parse.name --| Parse.$$$ ":" -- Parse.typ >> coinduction_upto_cmd);
  4.2412 +
  4.2413 +val _ = Theory.setup (Theory.at_begin consolidate_global);
  4.2414 +
  4.2415 +end;
     5.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     5.2 +++ b/src/HOL/Tools/BNF/bnf_gfp_grec_sugar_tactics.ML	Tue Mar 22 12:39:37 2016 +0100
     5.3 @@ -0,0 +1,217 @@
     5.4 +(*  Title:      HOL/Tools/BNF/bnf_gfp_grec_tactics.ML
     5.5 +    Author:     Jasmin Blanchette, Inria, LORIA, MPII
     5.6 +    Copyright   2016
     5.7 +
     5.8 +Tactics for generalized corecursor sugar.
     5.9 +*)
    5.10 +
    5.11 +signature BNF_GFP_GREC_SUGAR_TACTICS =
    5.12 +sig
    5.13 +  val rho_transfer_simps: thm list
    5.14 +
    5.15 +  val mk_case_dtor_tac: Proof.context -> term -> thm -> thm -> thm list -> thm -> thm list -> tactic
    5.16 +  val mk_cong_intro_ctr_or_friend_tac: Proof.context -> thm -> thm list -> thm -> tactic
    5.17 +  val mk_code_tac: Proof.context -> int -> term list -> term -> term -> thm -> thm -> thm list ->
    5.18 +    thm list -> thm list -> thm list -> thm -> thm -> thm list -> thm list -> thm -> thm list ->
    5.19 +    thm list -> thm list -> thm list -> thm list -> thm list -> thm -> tactic
    5.20 +  val mk_eq_algrho_tac: Proof.context -> term list -> term -> term -> term -> term -> term -> thm ->
    5.21 +    thm -> thm list -> thm list -> thm list -> thm list -> thm -> thm -> thm -> thm list ->
    5.22 +    thm list -> thm list -> thm -> thm list -> thm list -> thm list -> thm -> thm -> thm -> thm ->
    5.23 +    thm list -> thm list -> thm list -> thm list -> thm list -> tactic
    5.24 +  val mk_eq_corecUU_tac: Proof.context -> int -> term list -> term -> term -> thm -> thm ->
    5.25 +    thm list -> thm list -> thm list -> thm list -> thm -> thm -> thm list -> thm list ->
    5.26 +    thm list -> thm list -> thm list -> thm list -> thm list -> thm -> thm -> tactic
    5.27 +  val mk_last_disc_tac: Proof.context -> term -> thm -> thm list -> tactic
    5.28 +  val mk_rho_transfer_tac: Proof.context -> bool -> thm -> thm list -> tactic
    5.29 +  val mk_unique_tac: Proof.context -> int -> term list -> term -> term -> thm -> thm -> thm list ->
    5.30 +    thm list -> thm list -> thm list -> thm -> thm -> thm list -> thm list -> thm list ->
    5.31 +    thm list -> thm list -> thm list -> thm list -> thm -> thm -> tactic
    5.32 +end;
    5.33 +
    5.34 +structure BNF_GFP_Grec_Sugar_Tactics : BNF_GFP_GREC_SUGAR_TACTICS =
    5.35 +struct
    5.36 +
    5.37 +open Ctr_Sugar
    5.38 +open BNF_Util
    5.39 +open BNF_Tactics
    5.40 +open BNF_FP_Def_Sugar_Tactics
    5.41 +open BNF_GFP_Grec_Tactics
    5.42 +open BNF_GFP_Grec_Sugar_Util
    5.43 +
    5.44 +fun apply_func f =
    5.45 +  let
    5.46 +    val arg_Ts = binder_fun_types (fastype_of f);
    5.47 +    val args = map_index (fn (j, T) => Var (("a" ^ string_of_int j, 0), T)) arg_Ts;
    5.48 +  in
    5.49 +    list_comb (f, args)
    5.50 +  end;
    5.51 +
    5.52 +fun instantiate_distrib thm ctxt t =
    5.53 +  Drule.infer_instantiate' ctxt [SOME (Thm.incr_indexes_cterm 1 (Thm.cterm_of ctxt t))] thm;
    5.54 +
    5.55 +(* TODO (here and elsewhere): Use metaequality in goal instead and keep uninstianted version of
    5.56 +   theorem? *)
    5.57 +val mk_if_distrib_of = instantiate_distrib @{thm if_distrib};
    5.58 +val mk_case_sum_distrib_of = instantiate_distrib @{thm sum.case_distrib};
    5.59 +
    5.60 +fun mk_case_dtor_tac ctxt u abs_inverse dtor_ctor ctr_defs exhaust cases =
    5.61 +  let val exhaust' = Drule.infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt u)] exhaust in
    5.62 +    HEADGOAL (rtac ctxt exhaust') THEN
    5.63 +    REPEAT_DETERM (HEADGOAL (etac ctxt ssubst THEN'
    5.64 +      SELECT_GOAL (unfold_thms_tac ctxt cases THEN
    5.65 +        unfold_thms_tac ctxt (abs_inverse :: dtor_ctor :: ctr_defs @
    5.66 +        @{thms prod.case sum.case})) THEN'
    5.67 +      rtac ctxt refl))
    5.68 +  end;
    5.69 +
    5.70 +fun mk_cong_intro_ctr_or_friend_tac ctxt ctr_or_friend_def extra_simps cong_alg_intro =
    5.71 +  HEADGOAL (REPEAT_DETERM_N 2 o subst_tac ctxt NONE [ctr_or_friend_def] THEN'
    5.72 +    rtac ctxt cong_alg_intro) THEN
    5.73 +  unfold_thms_tac ctxt (extra_simps @ sumprod_thms_rel @
    5.74 +    @{thms vimage2p_def prod.rel_eq sum.rel_eq}) THEN
    5.75 +  REPEAT_DETERM (HEADGOAL (rtac ctxt conjI ORELSE' assume_tac ctxt ORELSE' rtac ctxt refl));
    5.76 +
    5.77 +val shared_simps =
    5.78 +  @{thms map_prod_simp map_sum.simps sum.case prod.case_eq_if split_beta' prod.sel
    5.79 +      sum.disc(1)[THEN eq_True[THEN iffD2]] sum.disc(2)[THEN eq_False[THEN iffD2]] sum.sel
    5.80 +      isl_map_sum map_sum_sel if_True if_False if_True_False Let_def[abs_def] o_def[abs_def] id_def
    5.81 +      BNF_Composition.id_bnf_def};
    5.82 +
    5.83 +fun mk_code_tac ctxt num_args fpsig_nesting_maps ssig_map eval pre_map_def abs_inverse
    5.84 +    fpsig_nesting_map_ident0s fpsig_nesting_map_comps fpsig_nesting_map_thms
    5.85 +    live_nesting_map_ident0s fp_map_ident case_trivial ctr_defs case_eq_ifs corecUU all_sig_maps
    5.86 +    ssig_map_thms all_algLam_alg_pointfuls all_algrho_eqs eval_simps inner_fp_simps fun_def =
    5.87 +  let
    5.88 +    val fun_def' =
    5.89 +      if null inner_fp_simps andalso num_args > 0 then
    5.90 +        fun_def RS meta_eq_to_obj_eq RS (mk_curry_uncurryN_balanced ctxt num_args RS iffD2) RS sym
    5.91 +      else
    5.92 +        fun_def;
    5.93 +    val case_trivial' = unfold_thms ctxt (case_eq_ifs @ ctr_defs @ shared_simps) case_trivial;
    5.94 +    val case_eq_ifs' = map (Drule.abs_def o (fn thm => thm RS eq_reflection)) case_eq_ifs;
    5.95 +    val if_distribs = @{thm if_distrib_fun} :: map (mk_if_distrib_of ctxt)
    5.96 +      (eval :: map apply_func (ssig_map :: fpsig_nesting_maps));
    5.97 +
    5.98 +    val unfold_tac = unfold_thms_tac ctxt (case_trivial' :: pre_map_def :: abs_inverse ::
    5.99 +      fp_map_ident :: (if null inner_fp_simps then [] else [corecUU]) @ fpsig_nesting_map_ident0s @
   5.100 +      fpsig_nesting_map_comps @ fpsig_nesting_map_thms @ live_nesting_map_ident0s @ ctr_defs @
   5.101 +      case_eq_ifs' @ all_sig_maps @ ssig_map_thms @ all_algLam_alg_pointfuls @ all_algrho_eqs @
   5.102 +      eval_simps @ if_distribs @ shared_simps);
   5.103 +  in
   5.104 +    HEADGOAL (subst_tac ctxt NONE [fun_def] THEN' subst_tac ctxt NONE [corecUU] THEN'
   5.105 +      (if null inner_fp_simps then K all_tac else subst_tac ctxt NONE inner_fp_simps)) THEN
   5.106 +    unfold_thms_tac ctxt [fun_def'] THEN
   5.107 +    unfold_tac THEN HEADGOAL (CONVERSION Thm.eta_long_conversion) THEN unfold_tac THEN
   5.108 +    HEADGOAL (rtac ctxt refl)
   5.109 +  end;
   5.110 +
   5.111 +fun mk_eq_algrho_tac ctxt fpsig_nesting_maps abs rep ctor ssig_map eval pre_map_def abs_inverse
   5.112 +    fpsig_nesting_map_ident0s fpsig_nesting_map_comps fpsig_nesting_map_thms
   5.113 +    live_nesting_map_ident0s fp_map_ident dtor_ctor ctor_iff_dtor ctr_defs nullary_disc_defs
   5.114 +    disc_sel_eq_cases case_dtor case_eq_ifs const_pointful_naturals fp_nesting_k_map_disc_sels'
   5.115 +    rho_def dtor_algrho corecUU_unique eq_corecUU all_sig_maps ssig_map_thms
   5.116 +    all_algLam_alg_pointfuls all_algrho_eqs eval_simps =
   5.117 +  let
   5.118 +    fun mk_abs_def thm = Drule.abs_def (thm RS eq_reflection);
   5.119 +
   5.120 +    val nullary_disc_defs' = nullary_disc_defs
   5.121 +      |> map (fn thm => thm RS sym)
   5.122 +      |> maps (fn thm => [thm, thm RS @{thm subst[OF eq_commute, of "%e. e = z" for z]}]);
   5.123 +
   5.124 +    val case_dtor' = unfold_thms ctxt shared_simps case_dtor;
   5.125 +    val disc_sel_eq_cases' = map (mk_abs_def
   5.126 +      o unfold_thms ctxt (case_dtor' :: ctr_defs @ shared_simps)) disc_sel_eq_cases;
   5.127 +    val const_pointful_naturals' = map (unfold_thms ctxt shared_simps) const_pointful_naturals;
   5.128 +    val const_pointful_naturals_sym' = map (fn thm => thm RS sym) const_pointful_naturals';
   5.129 +    val case_eq_ifs' = map mk_abs_def (@{thm sum.case_eq_if} :: case_eq_ifs);
   5.130 +
   5.131 +    val distrib_consts =
   5.132 +      abs :: rep :: ctor :: eval :: map apply_func (ssig_map :: fpsig_nesting_maps);
   5.133 +    val if_distribs = @{thm if_distrib_fun} :: map (mk_if_distrib_of ctxt) distrib_consts;
   5.134 +    val case_sum_distribs = map (mk_case_sum_distrib_of ctxt) distrib_consts;
   5.135 +
   5.136 +    val simp_ctxt = (ctxt
   5.137 +        |> Context_Position.set_visible false
   5.138 +        |> put_simpset (simpset_of (Proof_Context.init_global @{theory Main}))
   5.139 +        |> Raw_Simplifier.add_cong @{thm if_cong})
   5.140 +      addsimps pre_map_def :: abs_inverse :: fp_map_ident :: dtor_ctor :: rho_def ::
   5.141 +        @{thm convol_def} :: fpsig_nesting_map_ident0s @ fpsig_nesting_map_comps @
   5.142 +        fpsig_nesting_map_thms @ live_nesting_map_ident0s @ ctr_defs @ disc_sel_eq_cases' @
   5.143 +        fp_nesting_k_map_disc_sels' @ case_eq_ifs' @ all_sig_maps @ ssig_map_thms @
   5.144 +        all_algLam_alg_pointfuls @ all_algrho_eqs @ eval_simps @ if_distribs @ case_sum_distribs @
   5.145 +        shared_simps;
   5.146 +
   5.147 +    fun mk_main_simp const_pointful_naturals_maybe_sym' =
   5.148 +      simp_tac (simp_ctxt addsimps const_pointful_naturals_maybe_sym');
   5.149 +  in
   5.150 +    unfold_thms_tac ctxt [eq_corecUU] THEN
   5.151 +    HEADGOAL (REPEAT_DETERM o rtac ctxt ext THEN'
   5.152 +      rtac ctxt (corecUU_unique RS sym RS fun_cong) THEN'
   5.153 +      subst_tac ctxt NONE [dtor_algrho RS (ctor_iff_dtor RS iffD2)] THEN' rtac ctxt ext) THEN
   5.154 +    unfold_thms_tac ctxt (nullary_disc_defs' @ shared_simps) THEN
   5.155 +    HEADGOAL (rtac ctxt meta_eq_to_obj_eq) THEN
   5.156 +    REPEAT_DETERM_N (length const_pointful_naturals' + 1)
   5.157 +      (ALLGOALS (mk_main_simp const_pointful_naturals_sym') THEN
   5.158 +       ALLGOALS (mk_main_simp const_pointful_naturals'))
   5.159 +  end;
   5.160 +
   5.161 +fun mk_eq_corecUU_tac ctxt num_args fpsig_nesting_maps ssig_map eval pre_map_def abs_inverse
   5.162 +    fpsig_nesting_map_ident0s fpsig_nesting_map_comps fpsig_nesting_map_thms
   5.163 +    live_nesting_map_ident0s fp_map_ident case_trivial ctr_defs case_eq_ifs all_sig_maps
   5.164 +    ssig_map_thms all_algLam_alg_pointfuls all_algrho_eqs eval_simps corecUU_unique fun_code =
   5.165 +  let
   5.166 +    val case_trivial' = unfold_thms ctxt (case_eq_ifs @ ctr_defs @ shared_simps) case_trivial;
   5.167 +    val case_eq_ifs' = map (Drule.abs_def o (fn thm => thm RS eq_reflection)) case_eq_ifs;
   5.168 +    val if_distribs = @{thm if_distrib_fun} :: map (mk_if_distrib_of ctxt)
   5.169 +      (eval :: map apply_func (ssig_map :: fpsig_nesting_maps));
   5.170 +
   5.171 +    val unfold_tac = unfold_thms_tac ctxt (case_trivial' :: pre_map_def :: abs_inverse ::
   5.172 +      fp_map_ident :: fpsig_nesting_map_ident0s @ fpsig_nesting_map_comps @ fpsig_nesting_map_thms @
   5.173 +      live_nesting_map_ident0s @ ctr_defs @ case_eq_ifs' @ all_sig_maps @ ssig_map_thms @
   5.174 +      all_algLam_alg_pointfuls @ all_algrho_eqs @ eval_simps @ if_distribs @ shared_simps);
   5.175 +  in
   5.176 +    HEADGOAL (rtac ctxt (mk_curry_uncurryN_balanced ctxt num_args RS iffD1) THEN'
   5.177 +      rtac ctxt corecUU_unique THEN' rtac ctxt ext) THEN
   5.178 +    unfold_thms_tac ctxt @{thms prod.case_eq_if} THEN
   5.179 +    HEADGOAL (rtac ctxt (fun_code RS trans)) THEN
   5.180 +    unfold_tac THEN HEADGOAL (CONVERSION Thm.eta_long_conversion) THEN unfold_tac THEN
   5.181 +    HEADGOAL (rtac ctxt refl)
   5.182 +  end;
   5.183 +
   5.184 +fun mk_last_disc_tac ctxt u exhaust discs' =
   5.185 +  let val exhaust' = Drule.infer_instantiate' ctxt [SOME (Thm.cterm_of ctxt u)] exhaust in
   5.186 +    HEADGOAL (rtac ctxt exhaust') THEN
   5.187 +    REPEAT_DETERM (HEADGOAL (etac ctxt ssubst THEN'
   5.188 +      simp_tac (ss_only (distinct Thm.eq_thm discs' @ @{thms simp_thms}) ctxt)))
   5.189 +  end;
   5.190 +
   5.191 +val rho_transfer_simps = @{thms BNF_Def.vimage2p_def[abs_def] BNF_Composition.id_bnf_def};
   5.192 +
   5.193 +fun mk_rho_transfer_tac ctxt unfold rel_def const_transfers =
   5.194 +  (if unfold then unfold_thms_tac ctxt (rel_def :: rho_transfer_simps) else all_tac) THEN
   5.195 +  HEADGOAL (transfer_prover_add_tac ctxt [] const_transfers);
   5.196 +
   5.197 +fun mk_unique_tac ctxt num_args fpsig_nesting_maps ssig_map eval pre_map_def abs_inverse
   5.198 +    fpsig_nesting_map_ident0s fpsig_nesting_map_comps fpsig_nesting_map_thms
   5.199 +    live_nesting_map_ident0s fp_map_ident case_trivial ctr_defs case_eq_ifs all_sig_maps
   5.200 +    ssig_map_thms all_algLam_alg_pointfuls all_algrho_eqs eval_simps corecUU_unique eq_corecUU =
   5.201 +  let
   5.202 +    val case_trivial' = unfold_thms ctxt (case_eq_ifs @ ctr_defs @ shared_simps) case_trivial;
   5.203 +    val case_eq_ifs' = map (Drule.abs_def o (fn thm => thm RS eq_reflection)) case_eq_ifs;
   5.204 +    val if_distribs = @{thm if_distrib_fun} :: map (mk_if_distrib_of ctxt)
   5.205 +      (eval :: map apply_func (ssig_map :: fpsig_nesting_maps));
   5.206 +
   5.207 +    val unfold_tac = unfold_thms_tac ctxt (case_trivial' :: pre_map_def :: abs_inverse ::
   5.208 +      fp_map_ident :: fpsig_nesting_map_ident0s @ fpsig_nesting_map_comps @ fpsig_nesting_map_thms @
   5.209 +      live_nesting_map_ident0s @ ctr_defs @ case_eq_ifs' @ all_sig_maps @ ssig_map_thms @
   5.210 +      all_algLam_alg_pointfuls @ all_algrho_eqs @ eval_simps @ if_distribs @ shared_simps);
   5.211 +  in
   5.212 +    HEADGOAL (subst_tac ctxt NONE [eq_corecUU] THEN'
   5.213 +      rtac ctxt (mk_curry_uncurryN_balanced ctxt num_args RS iffD1) THEN'
   5.214 +      rtac ctxt corecUU_unique THEN' rtac ctxt ext THEN'
   5.215 +      etac ctxt @{thm ssubst[of _ _ "\<lambda>x. f x = u" for f u]}) THEN
   5.216 +    unfold_tac THEN HEADGOAL (CONVERSION Thm.eta_long_conversion) THEN unfold_tac THEN
   5.217 +    HEADGOAL (rtac ctxt refl)
   5.218 +  end;
   5.219 +
   5.220 +end;
     6.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     6.2 +++ b/src/HOL/Tools/BNF/bnf_gfp_grec_sugar_util.ML	Tue Mar 22 12:39:37 2016 +0100
     6.3 @@ -0,0 +1,481 @@
     6.4 +(*  Title:      HOL/Tools/BNF/bnf_gfp_grec_sugar_util.ML
     6.5 +    Author:     Aymeric Bouzy, Ecole polytechnique
     6.6 +    Author:     Jasmin Blanchette, Inria, LORIA, MPII
     6.7 +    Copyright   2015, 2016
     6.8 +
     6.9 +Library for generalized corecursor sugar.
    6.10 +*)
    6.11 +
    6.12 +signature BNF_GFP_GREC_SUGAR_UTIL =
    6.13 +sig
    6.14 +  type s_parse_info =
    6.15 +    {outer_buffer: BNF_GFP_Grec.buffer,
    6.16 +     ctr_guards: term Symtab.table,
    6.17 +     inner_buffer: BNF_GFP_Grec.buffer}
    6.18 +
    6.19 +  type rho_parse_info =
    6.20 +    {pattern_ctrs: (term * term list) Symtab.table,
    6.21 +     discs: term Symtab.table,
    6.22 +     sels: term Symtab.table,
    6.23 +     it: term,
    6.24 +     mk_case: typ -> term}
    6.25 +
    6.26 +  exception UNNATURAL of unit
    6.27 +
    6.28 +  val generalize_types: int -> typ -> typ -> typ
    6.29 +  val mk_curry_uncurryN_balanced: Proof.context -> int -> thm
    6.30 +  val mk_const_transfer_goal: Proof.context -> string * typ -> term
    6.31 +  val mk_abs_transfer: Proof.context -> string -> thm
    6.32 +  val mk_rep_transfer: Proof.context -> string -> thm
    6.33 +  val mk_pointful_natural_from_transfer: Proof.context -> thm -> thm
    6.34 +
    6.35 +  val corec_parse_info_of: Proof.context -> typ list -> typ -> BNF_GFP_Grec.buffer -> s_parse_info
    6.36 +  val friend_parse_info_of: Proof.context -> typ list -> typ -> BNF_GFP_Grec.buffer ->
    6.37 +    s_parse_info * rho_parse_info
    6.38 +end;
    6.39 +
    6.40 +structure BNF_GFP_Grec_Sugar_Util : BNF_GFP_GREC_SUGAR_UTIL =
    6.41 +struct
    6.42 +
    6.43 +open Ctr_Sugar
    6.44 +open BNF_Util
    6.45 +open BNF_Tactics
    6.46 +open BNF_Def
    6.47 +open BNF_Comp
    6.48 +open BNF_FP_Util
    6.49 +open BNF_FP_Def_Sugar
    6.50 +open BNF_GFP_Grec
    6.51 +open BNF_GFP_Grec_Tactics
    6.52 +
    6.53 +val mk_case_sumN_balanced = Balanced_Tree.make mk_case_sum;
    6.54 +
    6.55 +fun not_codatatype ctxt T =
    6.56 +  error ("Not a codatatype: " ^ Syntax.string_of_typ ctxt T);
    6.57 +
    6.58 +fun generalize_types max_j T U =
    6.59 +  let
    6.60 +    val vars = Unsynchronized.ref [];
    6.61 +
    6.62 +    fun var_of T U =
    6.63 +      (case AList.lookup (op =) (!vars) (T, U) of
    6.64 +        SOME V => V
    6.65 +      | NONE =>
    6.66 +        let val V = TVar ((Name.aT, length (!vars) + max_j), @{sort type}) in
    6.67 +          vars := ((T, U), V) :: !vars; V
    6.68 +        end);
    6.69 +
    6.70 +    fun gen (T as Type (s, Ts)) (U as Type (s', Us)) =
    6.71 +        if s = s' then Type (s, map2 gen Ts Us) else var_of T U
    6.72 +      | gen T U = if T = U then T else var_of T U;
    6.73 +  in
    6.74 +    gen T U
    6.75 +  end;
    6.76 +
    6.77 +fun mk_curry_uncurryN_balanced_raw ctxt n =
    6.78 +  let
    6.79 +    val ((As, B), names_ctxt) = ctxt
    6.80 +      |> mk_TFrees (n + 1)
    6.81 +      |>> split_last;
    6.82 +
    6.83 +    val tupled_As = mk_tupleT_balanced As;
    6.84 +
    6.85 +    val f_T = As ---> B;
    6.86 +    val g_T = tupled_As --> B;
    6.87 +
    6.88 +    val (((f, g), xs), _) = names_ctxt
    6.89 +      |> yield_singleton (mk_Frees "f") f_T
    6.90 +      ||>> yield_singleton (mk_Frees "g") g_T
    6.91 +      ||>> mk_Frees "x" As;
    6.92 +
    6.93 +    val tupled_xs = mk_tuple1_balanced As xs;
    6.94 +
    6.95 +    val uncurried_f = mk_tupled_fun f tupled_xs xs;
    6.96 +    val curried_g = abs_curried_balanced As g;
    6.97 +
    6.98 +    val lhs = HOLogic.mk_eq (uncurried_f, g);
    6.99 +    val rhs =  HOLogic.mk_eq (f, curried_g);
   6.100 +    val goal = fold_rev Logic.all [f, g] (mk_Trueprop_eq (lhs, rhs));
   6.101 +
   6.102 +    fun mk_tac ctxt =
   6.103 +      HEADGOAL (rtac ctxt iffI THEN' dtac ctxt sym THEN' hyp_subst_tac ctxt) THEN
   6.104 +      unfold_thms_tac ctxt @{thms prod.case} THEN
   6.105 +      HEADGOAL (rtac ctxt refl THEN' hyp_subst_tac ctxt THEN'
   6.106 +        REPEAT_DETERM o subst_tac ctxt NONE @{thms unit_abs_eta_conv case_prod_eta} THEN'
   6.107 +        rtac ctxt refl);
   6.108 +  in
   6.109 +    Goal.prove_sorry ctxt [] [] goal (fn {context = ctxt, ...} => mk_tac ctxt)
   6.110 +    |> Thm.close_derivation
   6.111 +  end;
   6.112 +
   6.113 +val num_curry_uncurryN_balanced_precomp = 8;
   6.114 +val curry_uncurryN_balanced_precomp =
   6.115 +  map (mk_curry_uncurryN_balanced_raw @{context}) (0 upto num_curry_uncurryN_balanced_precomp);
   6.116 +
   6.117 +fun mk_curry_uncurryN_balanced ctxt n =
   6.118 +  if n <= num_curry_uncurryN_balanced_precomp then nth curry_uncurryN_balanced_precomp n
   6.119 +  else mk_curry_uncurryN_balanced_raw ctxt n;
   6.120 +
   6.121 +fun mk_const_transfer_goal ctxt (s, var_T) =
   6.122 +  let
   6.123 +    val var_As = Term.add_tvarsT var_T [];
   6.124 +
   6.125 +    val ((As, Bs), names_ctxt) = ctxt
   6.126 +      |> Variable.declare_typ var_T
   6.127 +      |> mk_TFrees' (map snd var_As)
   6.128 +      ||>> mk_TFrees' (map snd var_As);
   6.129 +
   6.130 +    val (Rs, _) = names_ctxt
   6.131 +      |> mk_Frees "R" (map2 mk_pred2T As Bs);
   6.132 +
   6.133 +    val T = Term.typ_subst_TVars (map fst var_As ~~ As) var_T;
   6.134 +    val U = Term.typ_subst_TVars (map fst var_As ~~ Bs) var_T;
   6.135 +  in
   6.136 +    mk_parametricity_goal ctxt Rs (Const (s, T)) (Const (s, U))
   6.137 +    |> tap (fn goal => can type_of goal orelse
   6.138 +      error ("Cannot transfer constant " ^ quote (Syntax.string_of_term ctxt (Const (s, T))) ^
   6.139 +        " from type " ^ quote (Syntax.string_of_typ ctxt T) ^ " to " ^
   6.140 +        quote (Syntax.string_of_typ ctxt U)))
   6.141 +  end;
   6.142 +
   6.143 +fun mk_abs_transfer ctxt fpT_name =
   6.144 +  let
   6.145 +    val SOME {pre_bnf, absT_info = {absT, repT, abs, type_definition, ...}, ...} =
   6.146 +      fp_sugar_of ctxt fpT_name;
   6.147 +  in
   6.148 +    if absT = repT then
   6.149 +      raise Fail "no abs/rep"
   6.150 +    else
   6.151 +      let
   6.152 +        val rel_def = rel_def_of_bnf pre_bnf;
   6.153 +
   6.154 +        val absT = T_of_bnf pre_bnf
   6.155 +          |> singleton (freeze_types ctxt (map dest_TVar (lives_of_bnf pre_bnf)));
   6.156 +
   6.157 +        val goal = mk_const_transfer_goal ctxt (dest_Const (mk_abs absT abs))
   6.158 +      in
   6.159 +        Variable.add_free_names ctxt goal []
   6.160 +        |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
   6.161 +          unfold_thms_tac ctxt [rel_def] THEN
   6.162 +          HEADGOAL (rtac ctxt (@{thm Abs_transfer} OF [type_definition, type_definition]))))
   6.163 +      end
   6.164 +  end;
   6.165 +
   6.166 +fun mk_rep_transfer ctxt fpT_name =
   6.167 +  let
   6.168 +    val SOME {pre_bnf, absT_info = {absT, repT, rep, ...}, ...} = fp_sugar_of ctxt fpT_name;
   6.169 +  in
   6.170 +    if absT = repT then
   6.171 +      raise Fail "no abs/rep"
   6.172 +    else
   6.173 +      let
   6.174 +        val rel_def = rel_def_of_bnf pre_bnf;
   6.175 +
   6.176 +        val absT = T_of_bnf pre_bnf
   6.177 +          |> singleton (freeze_types ctxt (map dest_TVar (lives_of_bnf pre_bnf)));
   6.178 +
   6.179 +        val goal = mk_const_transfer_goal ctxt (dest_Const (mk_rep absT rep))
   6.180 +      in
   6.181 +        Variable.add_free_names ctxt goal []
   6.182 +        |> (fn vars => Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
   6.183 +          unfold_thms_tac ctxt [rel_def] THEN
   6.184 +          HEADGOAL (rtac ctxt @{thm vimage2p_rel_fun})))
   6.185 +      end
   6.186 +  end;
   6.187 +
   6.188 +exception UNNATURAL of unit;
   6.189 +
   6.190 +fun mk_pointful_natural_from_transfer ctxt transfer =
   6.191 +  let
   6.192 +    val _ $ (_ $ Const (s, T0) $ Const (_, U0)) = Thm.prop_of transfer;
   6.193 +    val [T, U] = freeze_types ctxt [] [T0, U0];
   6.194 +    val var_T = generalize_types 0 T U;
   6.195 +
   6.196 +    val var_As = map TVar (rev (Term.add_tvarsT var_T []));
   6.197 +
   6.198 +    val ((As, Bs), names_ctxt) = ctxt
   6.199 +      |> mk_TFrees' (map Type.sort_of_atyp var_As)
   6.200 +      ||>> mk_TFrees' (map Type.sort_of_atyp var_As);
   6.201 +
   6.202 +    val TA = typ_subst_atomic (var_As ~~ As) var_T;
   6.203 +
   6.204 +    val ((xs, fs), _) = names_ctxt
   6.205 +      |> mk_Frees "x" (binder_types TA)
   6.206 +      ||>> mk_Frees "f" (map2 (curry (op -->)) As Bs);
   6.207 +
   6.208 +    val AB_fs = (As ~~ Bs) ~~ fs;
   6.209 +
   6.210 +    fun build_applied_map TU t =
   6.211 +      if op = TU then
   6.212 +        t
   6.213 +      else
   6.214 +        (case try (build_map ctxt [] (the o AList.lookup (op =) AB_fs)) TU of
   6.215 +          SOME mapx => mapx $ t
   6.216 +        | NONE => raise UNNATURAL ());
   6.217 +
   6.218 +    fun unextensionalize (f $ (x as Free _), rhs) = unextensionalize (f, lambda x rhs)
   6.219 +      | unextensionalize tu = tu;
   6.220 +
   6.221 +    val TB = typ_subst_atomic (var_As ~~ Bs) var_T;
   6.222 +
   6.223 +    val (binder_TAs, body_TA) = strip_type TA;
   6.224 +    val (binder_TBs, body_TB) = strip_type TB;
   6.225 +
   6.226 +    val n = length var_As;
   6.227 +    val m = length binder_TAs;
   6.228 +
   6.229 +    val A_nesting_bnfs = nesting_bnfs ctxt [[body_TA :: binder_TAs]] As;
   6.230 +    val A_nesting_map_ids = map map_id_of_bnf A_nesting_bnfs;
   6.231 +    val A_nesting_rel_Grps = map rel_Grp_of_bnf A_nesting_bnfs;
   6.232 +
   6.233 +    val ta = Const (s, TA);
   6.234 +    val tb = Const (s, TB);
   6.235 +    val xfs = @{map 3} (curry build_applied_map) binder_TAs binder_TBs xs;
   6.236 +
   6.237 +    val goal = (list_comb (tb, xfs), build_applied_map (body_TA, body_TB) (list_comb (ta, xs)))
   6.238 +      |> unextensionalize |> mk_Trueprop_eq;
   6.239 +
   6.240 +    val _ = if can type_of goal then () else raise UNNATURAL ();
   6.241 +
   6.242 +    val vars = map (fst o dest_Free) (xs @ fs);
   6.243 +  in
   6.244 +    Goal.prove_sorry ctxt vars [] goal (fn {context = ctxt, prems = _} =>
   6.245 +      mk_natural_from_transfer_tac ctxt m (replicate n true) transfer A_nesting_map_ids
   6.246 +        A_nesting_rel_Grps [])
   6.247 +    |> Thm.close_derivation
   6.248 +  end;
   6.249 +
   6.250 +type s_parse_info =
   6.251 +  {outer_buffer: BNF_GFP_Grec.buffer,
   6.252 +   ctr_guards: term Symtab.table,
   6.253 +   inner_buffer: BNF_GFP_Grec.buffer};
   6.254 +
   6.255 +type rho_parse_info =
   6.256 +  {pattern_ctrs: (term * term list) Symtab.table,
   6.257 +   discs: term Symtab.table,
   6.258 +   sels: term Symtab.table,
   6.259 +   it: term,
   6.260 +   mk_case: typ -> term};
   6.261 +
   6.262 +fun curry_friend (T, t) =
   6.263 +  let
   6.264 +    val prod_T = domain_type (fastype_of t);
   6.265 +    val Ts = dest_tupleT_balanced (num_binder_types T) prod_T;
   6.266 +    val xs = map_index (fn (i, T) => Free ("x" ^ string_of_int i, T)) Ts;
   6.267 +    val body = mk_tuple_balanced xs;
   6.268 +  in
   6.269 +    (T, fold_rev Term.lambda xs (t $ body))
   6.270 +  end;
   6.271 +
   6.272 +fun curry_friends ({Oper, VLeaf, CLeaf, ctr_wrapper, friends} : buffer) =
   6.273 +  {Oper = Oper, VLeaf = VLeaf, CLeaf = CLeaf, ctr_wrapper = ctr_wrapper,
   6.274 +   friends = Symtab.map (K curry_friend) friends};
   6.275 +
   6.276 +fun checked_gfp_sugar_of lthy (T as Type (T_name, _)) =
   6.277 +    (case fp_sugar_of lthy T_name of
   6.278 +      SOME (sugar as {fp = Greatest_FP, ...}) => sugar
   6.279 +    | _ => not_codatatype lthy T)
   6.280 +  | checked_gfp_sugar_of lthy T = not_codatatype lthy T;
   6.281 +
   6.282 +fun generic_spec_of friend ctxt arg_Ts res_T (raw_buffer0 as {VLeaf = VLeaf0, ...}) =
   6.283 +  let
   6.284 +    val thy = Proof_Context.theory_of ctxt;
   6.285 +
   6.286 +    val tupled_arg_T = mk_tupleT_balanced arg_Ts;
   6.287 +
   6.288 +    val {T = fpT, X, fp_res_index, fp_res = {ctors = ctors0, ...},
   6.289 +         absT_info = {abs = abs0, rep = rep0, ...},
   6.290 +         fp_ctr_sugar = {ctrXs_Tss, ctr_sugar = {ctrs = ctrs0, casex = case0, discs = discs0,
   6.291 +           selss = selss0, sel_defs, ...}, ...}, ...} =
   6.292 +      checked_gfp_sugar_of ctxt res_T;
   6.293 +
   6.294 +    val VLeaf0_T = fastype_of VLeaf0;
   6.295 +    val Y = domain_type VLeaf0_T;
   6.296 +
   6.297 +    val raw_buffer = specialize_buffer_types raw_buffer0;
   6.298 +
   6.299 +    val As_rho = tvar_subst thy [fpT] [res_T];
   6.300 +
   6.301 +    val substAT = Term.typ_subst_TVars As_rho;
   6.302 +    val substA = Term.subst_TVars As_rho;
   6.303 +    val substYT = Tsubst Y tupled_arg_T;
   6.304 +    val substY = substT Y tupled_arg_T;
   6.305 +
   6.306 +    val Ys_rho_inner = if friend then [] else [(Y, tupled_arg_T)];
   6.307 +    val substYT_inner = substAT o Term.typ_subst_atomic Ys_rho_inner;
   6.308 +    val substY_inner = substA o Term.subst_atomic_types Ys_rho_inner;
   6.309 +
   6.310 +    val mid_T = substYT_inner (range_type VLeaf0_T);
   6.311 +
   6.312 +    val substXT_mid = Tsubst X mid_T;
   6.313 +
   6.314 +    val XifyT = typ_subst_nonatomic [(res_T, X)];
   6.315 +    val YifyT = typ_subst_nonatomic [(res_T, Y)];
   6.316 +
   6.317 +    val substXYT = Tsubst X Y;
   6.318 +
   6.319 +    val ctor0 = nth ctors0 fp_res_index;
   6.320 +    val ctor = enforce_type ctxt range_type res_T ctor0;
   6.321 +    val preT = YifyT (domain_type (fastype_of ctor));
   6.322 +
   6.323 +    val n = length ctrs0;
   6.324 +    val ks = 1 upto n;
   6.325 +
   6.326 +    fun mk_ctr_guards () =
   6.327 +      let
   6.328 +        val ctr_Tss = map (map (substXT_mid o substAT)) ctrXs_Tss;
   6.329 +        val preT = XifyT (domain_type (fastype_of ctor));
   6.330 +        val mid_preT = substXT_mid preT;
   6.331 +        val abs = enforce_type ctxt range_type mid_preT abs0;
   6.332 +        val absT = range_type (fastype_of abs);
   6.333 +
   6.334 +        fun mk_ctr_guard k ctr_Ts (Const (s, _)) =
   6.335 +          let
   6.336 +            val xs = map_index (fn (i, T) => Free ("x" ^ string_of_int i, T)) ctr_Ts;
   6.337 +            val body = mk_absumprod absT abs n k xs;
   6.338 +          in
   6.339 +            (s, fold_rev Term.lambda xs body)
   6.340 +          end;
   6.341 +      in
   6.342 +        Symtab.make (@{map 3} mk_ctr_guard ks ctr_Tss ctrs0)
   6.343 +      end;
   6.344 +
   6.345 +    val substYT_mid = substYT o Tsubst Y mid_T;
   6.346 +
   6.347 +    val outer_T = substYT_mid preT;
   6.348 +
   6.349 +    val substY_outer = substY o substT Y outer_T;
   6.350 +
   6.351 +    val outer_buffer = curry_friends (map_buffer substY_outer raw_buffer);
   6.352 +    val ctr_guards = mk_ctr_guards ();
   6.353 +    val inner_buffer = curry_friends (map_buffer substY_inner raw_buffer);
   6.354 +
   6.355 +    val s_parse_info =
   6.356 +      {outer_buffer = outer_buffer, ctr_guards = ctr_guards, inner_buffer = inner_buffer};
   6.357 +
   6.358 +    fun mk_friend_spec () =
   6.359 +      let
   6.360 +        fun encapsulate_nested U T free =
   6.361 +          betapply (build_map ctxt [] (fn (T, _) =>
   6.362 +              if T = domain_type VLeaf0_T then Abs (Name.uu, T, VLeaf0 $ Bound 0)
   6.363 +              else Abs (Name.uu, T, Bound 0)) (T, U),
   6.364 +            free);
   6.365 +
   6.366 +        val preT = YifyT (domain_type (fastype_of ctor));
   6.367 +        val YpreT = HOLogic.mk_prodT (Y, preT);
   6.368 +
   6.369 +        val rep = rep0 |> enforce_type ctxt domain_type (substXT_mid (XifyT preT));
   6.370 +
   6.371 +        fun mk_disc k =
   6.372 +          ctrXs_Tss
   6.373 +          |> map_index (fn (i, Ts) =>
   6.374 +            Abs (Name.uu, mk_tupleT_balanced Ts,
   6.375 +              if i + 1 = k then @{const HOL.True} else @{const HOL.False}))
   6.376 +          |> mk_case_sumN_balanced
   6.377 +          |> map_types substXYT
   6.378 +          |> (fn tm => Library.foldl1 HOLogic.mk_comp [tm, rep, snd_const YpreT])
   6.379 +          |> map_types substAT;
   6.380 +
   6.381 +        val all_discs = map mk_disc ks;
   6.382 +
   6.383 +        fun mk_pair (Const (disc_name, _)) disc = SOME (disc_name, disc)
   6.384 +          | mk_pair _ _ = NONE;
   6.385 +
   6.386 +        val discs = @{map 2} mk_pair discs0 all_discs
   6.387 +          |> map_filter I |> Symtab.make;
   6.388 +
   6.389 +        fun mk_sel sel_def =
   6.390 +          let
   6.391 +            val (sel_name, case_functions) =
   6.392 +              sel_def
   6.393 +              |> Object_Logic.rulify ctxt
   6.394 +              |> Thm.concl_of
   6.395 +              |> perhaps (try drop_all)
   6.396 +              |> perhaps (try HOLogic.dest_Trueprop)
   6.397 +              |> HOLogic.dest_eq
   6.398 +              |>> fst o strip_comb
   6.399 +              |>> fst o dest_Const
   6.400 +              ||> fst o dest_comb
   6.401 +              ||> snd o strip_comb
   6.402 +              ||> map (map_types (XifyT o substAT));
   6.403 +
   6.404 +            fun encapsulate_case_function case_function =
   6.405 +              let
   6.406 +                fun encapsulate bound_Ts [] case_function =
   6.407 +                    let val T = fastype_of1 (bound_Ts, case_function) in
   6.408 +                      encapsulate_nested (substXT_mid T) (substXYT T) case_function
   6.409 +                    end
   6.410 +                  | encapsulate bound_Ts (T :: Ts) case_function =
   6.411 +                    Abs (Name.uu, T,
   6.412 +                      encapsulate (T :: bound_Ts) Ts
   6.413 +                        (betapply (incr_boundvars 1 case_function, Bound 0)));
   6.414 +              in
   6.415 +                encapsulate [] (binder_types (fastype_of case_function)) case_function
   6.416 +              end;
   6.417 +          in
   6.418 +            (sel_name, ctrXs_Tss
   6.419 +              |> map (map_index (fn (i, T) => Free ("x" ^ string_of_int (i + 1), T)))
   6.420 +              |> `(map mk_tuple_balanced)
   6.421 +              |> uncurry (@{map 3} mk_tupled_fun (map encapsulate_case_function case_functions))
   6.422 +              |> mk_case_sumN_balanced
   6.423 +              |> map_types substXYT
   6.424 +              |> (fn tm => Library.foldl1 HOLogic.mk_comp [tm, rep, snd_const YpreT])
   6.425 +              |> map_types substAT)
   6.426 +          end;
   6.427 +
   6.428 +        val sels = Symtab.make (map mk_sel sel_defs);
   6.429 +
   6.430 +        fun mk_disc_sels_pair disc sels =
   6.431 +          if forall is_some sels then SOME (disc, map the sels) else NONE;
   6.432 +
   6.433 +        val pattern_ctrs = (ctrs0, selss0)
   6.434 +          ||> map (map (try dest_Const #> Option.mapPartial (fst #> Symtab.lookup sels)))
   6.435 +          ||> @{map 2} mk_disc_sels_pair all_discs
   6.436 +          |>> map (dest_Const #> fst)
   6.437 +          |> op ~~
   6.438 +          |> map_filter (fn (s, opt) => if is_some opt then SOME (s, the opt) else NONE)
   6.439 +          |> Symtab.make;
   6.440 +
   6.441 +        val it = HOLogic.mk_comp (VLeaf0, fst_const YpreT);
   6.442 +
   6.443 +        val mk_case =
   6.444 +          let
   6.445 +            val abs_fun_tms = case0
   6.446 +              |> fastype_of
   6.447 +              |> substAT
   6.448 +              |> XifyT
   6.449 +              |> binder_fun_types
   6.450 +              |> map_index (fn (i, T) => Free ("f" ^ string_of_int (i + 1), T));
   6.451 +            val arg_Uss = abs_fun_tms
   6.452 +              |> map fastype_of
   6.453 +              |> map binder_types;
   6.454 +            val arg_Tss = arg_Uss
   6.455 +              |> map (map substXYT);
   6.456 +            val case0 =
   6.457 +              arg_Tss
   6.458 +              |> map (map_index (fn (i, T) => Free ("x" ^ string_of_int (i + 1), T)))
   6.459 +              |> `(map mk_tuple_balanced)
   6.460 +              ||> @{map 3} (@{map 3} encapsulate_nested) arg_Uss arg_Tss
   6.461 +              |> uncurry (@{map 3} mk_tupled_fun abs_fun_tms)
   6.462 +              |> mk_case_sumN_balanced
   6.463 +              |> (fn tm => Library.foldl1 HOLogic.mk_comp [tm, rep, snd_const YpreT])
   6.464 +              |> fold_rev lambda abs_fun_tms
   6.465 +              |> map_types (substAT o substXT_mid);
   6.466 +          in
   6.467 +            fn U => case0
   6.468 +              |> substT (body_type (fastype_of case0)) U
   6.469 +              |> Syntax.check_term ctxt
   6.470 +          end;
   6.471 +      in
   6.472 +        {pattern_ctrs = pattern_ctrs, discs = discs, sels = sels, it = it, mk_case = mk_case}
   6.473 +      end;
   6.474 +  in
   6.475 +    (s_parse_info, mk_friend_spec)
   6.476 +  end;
   6.477 +
   6.478 +fun corec_parse_info_of ctxt =
   6.479 +  fst ooo generic_spec_of false ctxt;
   6.480 +
   6.481 +fun friend_parse_info_of ctxt =
   6.482 +  apsnd (fn f => f ()) ooo generic_spec_of true ctxt;
   6.483 +
   6.484 +end;
     7.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     7.2 +++ b/src/HOL/Tools/BNF/bnf_gfp_grec_tactics.ML	Tue Mar 22 12:39:37 2016 +0100
     7.3 @@ -0,0 +1,420 @@
     7.4 +(*  Title:      HOL/Tools/BNF/bnf_gfp_grec_tactics.ML
     7.5 +    Author:     Jasmin Blanchette, Inria, LORIA, MPII
     7.6 +    Author:     Dmitriy Traytel, ETH Zurich
     7.7 +    Copyright   2015, 2016
     7.8 +
     7.9 +Tactics for generalized corecursor construction.
    7.10 +*)
    7.11 +
    7.12 +signature BNF_GFP_GREC_TACTICS =
    7.13 +sig
    7.14 +  val transfer_prover_add_tac: Proof.context -> thm list -> thm list -> int -> tactic
    7.15 +
    7.16 +  val mk_algLam_algLam_tac: Proof.context -> thm -> thm -> thm -> thm -> thm -> thm -> thm -> thm ->
    7.17 +    tactic
    7.18 +  val mk_algLam_algrho_tac: Proof.context -> thm -> thm -> tactic
    7.19 +  val mk_algLam_base_tac: Proof.context -> term -> thm -> thm -> thm -> thm -> thm -> thm -> thm ->
    7.20 +    thm list -> thm -> thm list -> thm list -> thm -> thm -> tactic
    7.21 +  val mk_algLam_step_tac: Proof.context -> thm -> thm -> thm -> tactic
    7.22 +  val mk_cong_locale_tac: Proof.context -> thm -> thm list -> thm -> thm -> thm list -> thm ->
    7.23 +    thm -> tactic
    7.24 +  val mk_corecU_pointfree_tac: Proof.context -> thm -> thm -> thm list -> thm -> thm list -> thm ->
    7.25 +    thm list -> thm -> thm -> thm -> tactic
    7.26 +  val mk_corecUU_pointfree_tac: Proof.context -> thm -> thm -> thm -> thm -> thm -> thm -> thm ->
    7.27 +    thm -> thm -> thm -> thm -> thm -> thm -> tactic
    7.28 +  val mk_corecUU_unique_tac: Proof.context -> thm -> thm -> thm -> thm -> thm -> thm -> thm ->
    7.29 +    thm -> thm -> thm -> thm -> thm -> thm -> tactic
    7.30 +  val mk_corecUU_Inl_tac: Proof.context -> term -> thm -> thm -> thm -> thm -> thm list -> thm ->
    7.31 +    thm list -> thm -> thm -> thm -> thm -> tactic
    7.32 +  val mk_dtor_algLam_tac: Proof.context -> thm -> thm -> thm -> thm -> thm -> thm -> thm list ->
    7.33 +    thm -> thm -> thm list -> thm -> thm -> thm -> thm -> tactic
    7.34 +  val mk_dtor_algrho_tac: Proof.context -> thm -> thm -> thm -> thm -> tactic
    7.35 +  val mk_dtor_transfer_tac: Proof.context -> thm -> tactic
    7.36 +  val mk_equivp_Retr_tac: Proof.context -> thm -> thm -> thm -> thm -> tactic
    7.37 +  val mk_eval_core_embL_tac: Proof.context -> thm -> thm -> thm -> thm -> thm -> thm -> thm ->
    7.38 +    thm -> thm -> thm -> thm list -> thm list -> thm list -> thm -> tactic
    7.39 +  val mk_eval_core_flat_tac: Proof.context -> thm -> thm -> thm -> thm -> thm -> thm -> thm ->
    7.40 +    thm list -> thm -> thm list -> thm -> thm -> thm -> thm list -> tactic
    7.41 +  val mk_eval_core_k_as_ssig_tac: Proof.context -> thm -> thm -> thm -> thm list -> thm -> thm ->
    7.42 +    thm -> thm list -> tactic
    7.43 +  val mk_eval_embL_tac: Proof.context -> thm -> thm -> thm -> thm -> thm -> thm -> tactic
    7.44 +  val mk_eval_flat_tac: Proof.context -> thm -> thm -> thm -> thm -> thm -> thm -> thm -> thm ->
    7.45 +    tactic
    7.46 +  val mk_eval_sctr_tac: Proof.context -> thm -> thm -> thm -> thm -> tactic
    7.47 +  val mk_eval_Oper_tac: Proof.context -> int -> thm -> thm -> thm -> thm -> thm -> thm list ->
    7.48 +    thm -> thm -> tactic
    7.49 +  val mk_eval_V_or_CLeaf_tac: Proof.context -> thm -> thm -> thm -> thm -> thm -> thm list -> thm ->
    7.50 +    tactic
    7.51 +  val mk_extdd_mor_tac: Proof.context -> thm -> thm -> thm -> thm -> thm -> thm -> thm -> thm ->
    7.52 +    thm -> thm -> thm -> tactic
    7.53 +  val mk_extdd_o_VLeaf_tac: Proof.context -> thm -> thm -> thm -> thm list -> thm list -> thm ->
    7.54 +    thm -> thm -> tactic
    7.55 +  val mk_flat_embL_tac: Proof.context -> thm -> thm -> thm -> thm -> thm -> thm list -> thm list ->
    7.56 +    thm list -> thm list -> tactic
    7.57 +  val mk_flat_VLeaf_or_flat_tac: Proof.context -> thm -> thm -> thm list -> tactic
    7.58 +  val mk_Lam_Inl_Inr_tac: Proof.context -> thm -> thm -> tactic
    7.59 +  val mk_mor_cutSsig_flat_tac: Proof.context -> term -> thm -> thm -> thm -> thm -> thm -> thm ->
    7.60 +    thm list -> thm -> thm -> thm -> thm -> thm -> thm -> thm -> thm -> thm -> tactic
    7.61 +  val mk_natural_from_transfer_tac: Proof.context -> int -> bool list -> thm -> thm list ->
    7.62 +    thm list -> thm list -> tactic
    7.63 +  val mk_natural_by_unfolding_tac: Proof.context -> thm list -> tactic
    7.64 +  val mk_Retr_coinduct_tac: Proof.context -> thm -> thm -> tactic
    7.65 +  val mk_sig_transfer_tac: Proof.context -> thm -> thm list -> thm -> tactic
    7.66 +  val mk_transfer_by_transfer_prover_tac: Proof.context -> thm list -> thm list -> thm list ->
    7.67 +    tactic
    7.68 +end;
    7.69 +
    7.70 +structure BNF_GFP_Grec_Tactics : BNF_GFP_GREC_TACTICS =
    7.71 +struct
    7.72 +
    7.73 +open BNF_Util
    7.74 +open BNF_Tactics
    7.75 +open BNF_FP_Util
    7.76 +
    7.77 +val o_assoc = @{thm o_assoc};
    7.78 +val o_def = @{thm o_def};
    7.79 +
    7.80 +fun ss_only_silent thms ctxt =
    7.81 +  ss_only thms (ctxt |> Context_Position.set_visible false);
    7.82 +
    7.83 +fun context_relator_eq_add rel_eqs ctxt =
    7.84 +  fold (snd oo Thm.proof_attributes (map (Attrib.attribute ctxt) @{attributes [relator_eq]}))
    7.85 +    rel_eqs ctxt;
    7.86 +val context_transfer_rule_add = fold (snd oo Thm.proof_attributes [Transfer.transfer_add]);
    7.87 +
    7.88 +fun transfer_prover_add_tac ctxt rel_eqs transfers =
    7.89 +  Transfer.transfer_prover_tac (ctxt
    7.90 +    |> context_relator_eq_add rel_eqs
    7.91 +    |> context_transfer_rule_add transfers);
    7.92 +
    7.93 +fun instantiate_natural_rule_with_id ctxt live =
    7.94 +  Rule_Insts.of_rule ctxt ([], NONE :: replicate live (SOME @{const_name id})) [];
    7.95 +
    7.96 +fun instantiate_transfer_rule_with_Grp_UNIV ctxt alives thm =
    7.97 +  let
    7.98 +    val n = length alives;
    7.99 +    val fs = map (prefix "f" o string_of_int) (1 upto n);
   7.100 +    val ss = map2 (fn live => fn f => SOME (@{const_name BNF_Def.Grp} ^ " " ^ @{const_name top} ^
   7.101 +        " " ^ (if live then f else @{const_name id}))) alives fs;
   7.102 +    val bs = map_filter (fn (live, f) => if live then SOME (Binding.name f, NONE, NoSyn) else NONE)
   7.103 +      (alives ~~ fs);
   7.104 +  in
   7.105 +    Rule_Insts.of_rule ctxt ([], ss) bs thm
   7.106 +  end;
   7.107 +
   7.108 +fun mk_algLam_algLam_tac ctxt dead_pre_map_comp dtor_inject unsig sig_map Lam_def eval_embL
   7.109 +    old_dtor_algLam dtor_algLam =
   7.110 +  HEADGOAL (rtac ctxt ext THEN' rtac ctxt (dtor_inject RS iffD1)) THEN
   7.111 +  unfold_thms_tac ctxt (dead_pre_map_comp :: unsig :: sig_map :: Lam_def :: eval_embL ::
   7.112 +    old_dtor_algLam :: dtor_algLam :: @{thms o_apply id_o map_sum.simps sum.case}) THEN
   7.113 +  HEADGOAL (rtac ctxt refl);
   7.114 +
   7.115 +fun mk_algLam_algrho_tac ctxt algLam_def algrho_def =
   7.116 +  HEADGOAL (rtac ctxt ext) THEN unfold_thms_tac ctxt [algLam_def, algrho_def, o_apply] THEN
   7.117 +  HEADGOAL (rtac ctxt refl);
   7.118 +
   7.119 +fun mk_algLam_base_tac ctxt dead_pre_map_dtor dead_pre_map_id dead_pre_map_comp ctor_dtor dtor_ctor
   7.120 +    dtor_unfold_unique unsig Sig_pointful_natural ssig_maps Lam_def flat_simps eval_core_simps eval
   7.121 +    algLam_def =
   7.122 +  HEADGOAL (rtac ctxt (infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt dead_pre_map_dtor)]
   7.123 +    (trans OF [dtor_unfold_unique, dtor_unfold_unique RS sym]) OF [ext, ext])) THEN
   7.124 +  ALLGOALS (asm_simp_tac (ss_only_silent (dead_pre_map_id :: ctor_dtor :: dtor_ctor :: unsig ::
   7.125 +    Sig_pointful_natural :: Lam_def :: eval :: algLam_def ::
   7.126 +    unfold_thms ctxt [o_def] dead_pre_map_comp :: ssig_maps @ flat_simps @ eval_core_simps @
   7.127 +    @{thms o_apply id_apply id_def[symmetric] snd_conv convol_apply}) ctxt));
   7.128 +
   7.129 +fun mk_algLam_step_tac ctxt proto_sctr_def old_algLam_pointful algLam_algLam_pointful =
   7.130 +  HEADGOAL (rtac ctxt ext) THEN
   7.131 +  unfold_thms_tac ctxt [proto_sctr_def, old_algLam_pointful, algLam_algLam_pointful, o_apply] THEN
   7.132 +  HEADGOAL (rtac ctxt refl);
   7.133 +
   7.134 +fun mk_cong_locale_tac ctxt dead_pre_rel_mono dead_pre_rel_maps equivp_Retr
   7.135 +    ssig_rel_mono ssig_rel_maps eval eval_core_transfer =
   7.136 +  HEADGOAL (resolve_tac ctxt (Locale.get_unfolds @{context}) THEN'
   7.137 +    etac ctxt ssig_rel_mono THEN' etac ctxt equivp_Retr) THEN
   7.138 +  unfold_thms_tac ctxt (eval :: dead_pre_rel_maps @ @{thms id_apply}) THEN
   7.139 +  HEADGOAL (rtac ctxt (@{thm predicate2I} RS (dead_pre_rel_mono RS @{thm predicate2D})) THEN'
   7.140 +    etac ctxt @{thm rel_funD} THEN' assume_tac ctxt THEN'
   7.141 +    rtac ctxt (eval_core_transfer RS @{thm rel_funD})) THEN
   7.142 +  unfold_thms_tac ctxt (ssig_rel_maps @ @{thms vimage2p_rel_prod vimage2p_id}) THEN
   7.143 +  unfold_thms_tac ctxt @{thms vimage2p_def} THEN HEADGOAL (assume_tac ctxt);
   7.144 +
   7.145 +fun mk_corecU_pointfree_tac ctxt dead_pre_map_comp dtor_unfold ssig_maps dead_ssig_map_comp0
   7.146 +    flat_simps flat_VLeaf eval_core_simps cutSsig_def mor_cutSsig_flat corecU_def =
   7.147 +  unfold_thms_tac ctxt [corecU_def, dead_ssig_map_comp0, o_assoc] THEN
   7.148 +  HEADGOAL (subst_tac ctxt NONE [ext RS mor_cutSsig_flat] THEN'
   7.149 +    asm_simp_tac (ss_only_silent [dtor_unfold, o_apply] ctxt) THEN'
   7.150 +    asm_simp_tac (ss_only_silent (dtor_unfold :: flat_VLeaf :: cutSsig_def :: ssig_maps @
   7.151 +      flat_simps @ eval_core_simps @ unfold_thms ctxt [o_def] dead_pre_map_comp ::
   7.152 +      @{thms o_def id_apply id_def[symmetric] snd_conv convol_apply}) ctxt));
   7.153 +
   7.154 +fun mk_corecUU_tail_tac ctxt dead_pre_map_comp0 dead_pre_map_comp dtor_ctor ssig_map_comp
   7.155 +    flat_pointful_natural eval_core_pointful_natural eval eval_flat sctr_pointful_natural
   7.156 +    eval_sctr_pointful =
   7.157 +  asm_simp_tac (ss_only_silent (dtor_ctor :: flat_pointful_natural :: eval :: eval_flat ::
   7.158 +    map (unfold_thms ctxt [o_def]) [dead_pre_map_comp, ssig_map_comp] @
   7.159 +    @{thms o_apply id_apply id_def[symmetric] convol_apply}) ctxt) THEN'
   7.160 +  asm_simp_tac (ss_only_silent (eval_core_pointful_natural :: sctr_pointful_natural ::
   7.161 +    eval_sctr_pointful :: map (unfold_thms ctxt [o_def]) [dead_pre_map_comp0, ssig_map_comp] @
   7.162 +    @{thms id_apply id_def[symmetric] convol_apply map_prod_simp}) ctxt);
   7.163 +
   7.164 +fun mk_corecUU_pointfree_tac ctxt dead_pre_map_comp0 dead_pre_map_comp dtor_ctor dtor_inject
   7.165 +    ssig_map_comp flat_pointful_natural eval_core_pointful_natural eval eval_flat corecU_ctor
   7.166 +    sctr_pointful_natural eval_sctr_pointful corecUU_def =
   7.167 +  unfold_thms_tac ctxt [corecUU_def] THEN
   7.168 +  HEADGOAL (rtac ctxt ext THEN' subst_tac ctxt NONE [corecU_ctor RS sym]) THEN
   7.169 +  unfold_thms_tac ctxt [corecUU_def RS Drule.symmetric_thm] THEN
   7.170 +  HEADGOAL (rtac ctxt (dtor_inject RS iffD1) THEN'
   7.171 +    mk_corecUU_tail_tac ctxt dead_pre_map_comp0 dead_pre_map_comp dtor_ctor ssig_map_comp
   7.172 +      flat_pointful_natural eval_core_pointful_natural eval eval_flat sctr_pointful_natural
   7.173 +      eval_sctr_pointful);
   7.174 +
   7.175 +fun mk_corecUU_unique_tac ctxt dead_pre_map_comp0 dead_pre_map_comp dtor_ctor ssig_map_comp
   7.176 +    flat_pointful_natural eval_core_pointful_natural eval eval_flat corecU_unique
   7.177 +    sctr_pointful_natural eval_sctr_pointful corecUU_def prem =
   7.178 +  unfold_thms_tac ctxt [corecUU_def] THEN
   7.179 +  HEADGOAL (rtac ctxt corecU_unique THEN' rtac ctxt sym THEN' subst_tac ctxt NONE [prem] THEN'
   7.180 +    rtac ctxt ext THEN'
   7.181 +    mk_corecUU_tail_tac ctxt dead_pre_map_comp0 dead_pre_map_comp dtor_ctor ssig_map_comp
   7.182 +      flat_pointful_natural eval_core_pointful_natural eval eval_flat sctr_pointful_natural
   7.183 +      eval_sctr_pointful);
   7.184 +
   7.185 +fun mk_corecUU_Inl_tac ctxt inl_case' pre_map_comp dead_pre_map_ident dead_pre_map_comp0 ctor_dtor
   7.186 +    ssig_maps ssig_map_id0 eval_core_simps eval_core_pointful_natural eval_VLeaf corecUU_pointfree
   7.187 +    corecUU_unique =
   7.188 +  HEADGOAL (rtac ctxt (infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt inl_case')]
   7.189 +      (trans OF [corecUU_unique, corecUU_unique RS sym]) OF [ext, ext]) THEN'
   7.190 +    subst_tac ctxt NONE [corecUU_pointfree] THEN'
   7.191 +    asm_simp_tac (ss_only_silent (dead_pre_map_comp0 :: eval_core_pointful_natural :: ssig_maps @
   7.192 +      @{thms o_apply sum.case convol_apply id_apply map_prod_simp}) ctxt) THEN'
   7.193 +    asm_simp_tac (ss_only_silent (dead_pre_map_ident :: ctor_dtor :: ssig_map_id0 ::
   7.194 +        eval_core_pointful_natural :: eval_VLeaf :: unfold_thms ctxt [o_def] pre_map_comp ::
   7.195 +        ssig_maps @ eval_core_simps @ @{thms o_apply prod.map_id convol_apply snd_conv id_apply})
   7.196 +      ctxt));
   7.197 +
   7.198 +fun mk_dtor_algLam_tac ctxt pre_map_comp dead_pre_map_id dead_pre_map_comp0 dead_pre_map_comp
   7.199 +    sig_map_comp Oper_pointful_natural ssig_maps dead_ssig_map_comp0 Lam_pointful_natural
   7.200 +    eval_core_simps eval eval_flat eval_VLeaf algLam_def =
   7.201 +  unfold_thms_tac ctxt [dead_ssig_map_comp0, o_assoc] THEN
   7.202 +  HEADGOAL (asm_simp_tac (ss_only_silent (sig_map_comp :: Oper_pointful_natural :: eval ::
   7.203 +      eval_flat :: algLam_def :: unfold_thms ctxt [o_def] dead_pre_map_comp :: eval_core_simps @
   7.204 +      @{thms o_apply id_apply id_def[symmetric]}) ctxt) THEN'
   7.205 +    asm_simp_tac (ss_only_silent (Lam_pointful_natural :: eval_VLeaf ::
   7.206 +      map (unfold_thms ctxt [o_def]) [dead_pre_map_comp0, sig_map_comp] @ ssig_maps @
   7.207 +      eval_core_simps @
   7.208 +      @{thms o_apply convol_apply snd_conv fst_conv id_apply map_prod_simp}) ctxt) THEN'
   7.209 +    asm_simp_tac (ss_only_silent (dead_pre_map_id :: eval_VLeaf ::
   7.210 +      unfold_thms ctxt [o_def] pre_map_comp ::
   7.211 +      @{thms id_apply id_def[symmetric] convol_def}) ctxt));
   7.212 +
   7.213 +fun mk_dtor_algrho_tac ctxt eval k_as_ssig_natural_pointful eval_core_k_as_ssig algrho_def =
   7.214 +  HEADGOAL (asm_simp_tac (ss_only_silent [eval, k_as_ssig_natural_pointful, algrho_def,
   7.215 +    eval_core_k_as_ssig RS sym, o_apply] ctxt));
   7.216 +
   7.217 +fun mk_dtor_transfer_tac ctxt dtor_rel =
   7.218 +  HEADGOAL (rtac ctxt refl ORELSE'
   7.219 +    rtac ctxt @{thm rel_funI} THEN' rtac ctxt (dtor_rel RS iffD1) THEN' assume_tac ctxt);
   7.220 +
   7.221 +fun mk_equivp_Retr_tac ctxt dead_pre_rel_refl dead_pre_rel_flip dead_pre_rel_mono
   7.222 +    dead_pre_rel_compp =
   7.223 +  HEADGOAL (EVERY' [etac ctxt @{thm equivpE}, rtac ctxt @{thm equivpI},
   7.224 +    rtac ctxt @{thm reflpI}, rtac ctxt dead_pre_rel_refl, etac ctxt @{thm reflpD},
   7.225 +    SELECT_GOAL (unfold_thms_tac ctxt @{thms symp_iff}),
   7.226 +      REPEAT_DETERM o rtac ctxt ext, rtac ctxt (dead_pre_rel_flip RS sym RS trans),
   7.227 +      rtac ctxt ((@{thm conversep_iff} RS sym) RSN (2, trans)),
   7.228 +      asm_simp_tac (ss_only_silent @{thms conversep_eq} ctxt),
   7.229 +    SELECT_GOAL (unfold_thms_tac ctxt @{thms transp_relcompp}),
   7.230 +      rtac ctxt @{thm predicate2I}, etac ctxt @{thm relcomppE},
   7.231 +      etac ctxt (dead_pre_rel_mono RS @{thm rev_predicate2D[rotated -1]}),
   7.232 +      SELECT_GOAL (unfold_thms_tac ctxt
   7.233 +        (unfold_thms ctxt [@{thm eq_OO}] dead_pre_rel_compp :: @{thms relcompp_apply})),
   7.234 +      REPEAT_DETERM o resolve_tac ctxt [exI, conjI], assume_tac ctxt, assume_tac ctxt]);
   7.235 +
   7.236 +fun mk_eval_core_k_as_ssig_tac ctxt pre_map_comp dead_pre_map_id sig_map_comp ssig_maps
   7.237 +    Lam_natural_pointful Lam_Inr flat_VLeaf eval_core_simps =
   7.238 +  HEADGOAL (asm_simp_tac (ss_only_silent (dead_pre_map_id :: flat_VLeaf :: (Lam_Inr RS sym) ::
   7.239 +    o_apply :: id_apply :: @{thm id_def[symmetric]} ::
   7.240 +    unfold_thms ctxt @{thms map_prod_def split_def} Lam_natural_pointful :: ssig_maps @
   7.241 +    eval_core_simps @ map (unfold_thms ctxt [o_def]) [pre_map_comp, sig_map_comp]) ctxt));
   7.242 +
   7.243 +fun mk_eval_embL_tac ctxt dead_pre_map_comp0 dtor_unfold_unique embL_pointful_natural eval_core_embL
   7.244 +    old_eval eval =
   7.245 +  HEADGOAL (rtac ctxt (unfold_thms ctxt [o_apply]
   7.246 +      (trans OF [dtor_unfold_unique, dtor_unfold_unique RS sym] OF [ext, ext])
   7.247 +    OF [Drule.asm_rl, old_eval RS sym])) THEN
   7.248 +  unfold_thms_tac ctxt [dead_pre_map_comp0, embL_pointful_natural, eval_core_embL, eval,
   7.249 +    o_apply] THEN
   7.250 +  HEADGOAL (rtac ctxt refl);
   7.251 +
   7.252 +fun mk_eval_flat_tac ctxt dead_pre_map_comp0 ssig_map_id ssig_map_comp flat_pointful_natural
   7.253 +    eval_core_pointful_natural eval_core_flat eval cond_eval_o_flat =
   7.254 +  HEADGOAL (rtac ctxt (unfold_thms ctxt [o_apply] cond_eval_o_flat)) THEN
   7.255 +  unfold_thms_tac ctxt [dead_pre_map_comp0, flat_pointful_natural, eval_core_flat, eval,
   7.256 +    o_apply] THEN
   7.257 +  HEADGOAL (rtac ctxt refl THEN'
   7.258 +    asm_simp_tac (ss_only_silent (ssig_map_id :: eval_core_pointful_natural :: eval ::
   7.259 +        map (unfold_thms ctxt [o_def]) [dead_pre_map_comp0, ssig_map_comp] @
   7.260 +        @{thms id_apply id_def[symmetric] fst_conv map_prod_simp convol_apply})
   7.261 +      ctxt));
   7.262 +
   7.263 +fun instantiate_map_comp_with_f_g ctxt =
   7.264 +  Rule_Insts.of_rule ctxt ([], [NONE, SOME ("%x. f (g x)")])
   7.265 +    [(Binding.name "f", NONE, NoSyn), (Binding.name "g", NONE, NoSyn)];
   7.266 +
   7.267 +fun mk_eval_core_embL_tac ctxt old_ssig_induct dead_pre_map_comp0 dead_pre_map_comp
   7.268 +    Sig_pointful_natural unsig_thm old_sig_map_comp old_sig_map_cong old_Lam_pointful_natural
   7.269 +    Lam_def flat_embL old_eval_core_simps eval_core_simps embL_simps embL_pointful_natural =
   7.270 +  HEADGOAL (rtac ctxt old_ssig_induct) THEN
   7.271 +  ALLGOALS (asm_simp_tac (ss_only_silent (Sig_pointful_natural :: unsig_thm :: Lam_def ::
   7.272 +    (flat_embL RS sym) :: unfold_thms ctxt [o_def] dead_pre_map_comp :: embL_simps @
   7.273 +    old_eval_core_simps @ eval_core_simps @
   7.274 +    @{thms id_apply id_def[symmetric] o_apply map_sum.simps sum.case}) ctxt)) THEN
   7.275 +  HEADGOAL (asm_simp_tac (Simplifier.add_cong old_sig_map_cong (ss_only_silent
   7.276 +    (old_Lam_pointful_natural :: embL_pointful_natural ::
   7.277 +     map (unfold_thms ctxt [o_def]) [dead_pre_map_comp0, instantiate_map_comp_with_f_g ctxt
   7.278 +       dead_pre_map_comp0, old_sig_map_comp] @ @{thms map_prod_simp}) ctxt)));
   7.279 +
   7.280 +fun mk_eval_core_flat_tac ctxt ssig_induct dead_pre_map_id dead_pre_map_comp0 dead_pre_map_comp
   7.281 +    fp_map_id sig_map_comp sig_map_cong ssig_maps ssig_map_comp flat_simps flat_natural flat_flat
   7.282 +    Lam_natural_sym eval_core_simps =
   7.283 +  HEADGOAL (rtac ctxt ssig_induct) THEN
   7.284 +  ALLGOALS (full_simp_tac (ss_only_silent ((flat_flat RS sym) :: dead_pre_map_id ::
   7.285 +    dead_pre_map_comp :: fp_map_id :: sig_map_comp :: ssig_map_comp :: ssig_maps @ flat_simps @
   7.286 +    eval_core_simps @ @{thms o_def id_def[symmetric] convol_apply id_apply snd_conv}) ctxt)) THEN
   7.287 +  HEADGOAL (asm_simp_tac (Simplifier.add_cong sig_map_cong (ss_only_silent
   7.288 +      (map (unfold_thms ctxt [o_def]) [dead_pre_map_comp0, sig_map_comp] @
   7.289 +       flat_natural :: Lam_natural_sym :: @{thms id_apply fst_conv map_prod_simp})
   7.290 +    ctxt)));
   7.291 +
   7.292 +fun mk_eval_sctr_tac ctxt proto_sctr_pointful_natural eval_Oper algLam sctr_def =
   7.293 +  HEADGOAL (rtac ctxt ext) THEN
   7.294 +  unfold_thms_tac ctxt [proto_sctr_pointful_natural, eval_Oper, algLam RS sym, sctr_def,
   7.295 +    o_apply] THEN
   7.296 +  HEADGOAL (rtac ctxt refl);
   7.297 +
   7.298 +fun mk_eval_V_or_CLeaf_tac ctxt dead_pre_map_id dead_pre_map_comp fp_map_id dtor_unfold_unique
   7.299 +    V_or_CLeaf_map eval_core_simps eval =
   7.300 +  HEADGOAL (rtac ctxt (trans OF [dtor_unfold_unique, dtor_unfold_unique RS sym] RS fun_cong
   7.301 +    OF [ext, ext])) THEN
   7.302 +  ALLGOALS (asm_simp_tac (ss_only_silent (dead_pre_map_id :: fp_map_id ::
   7.303 +    unfold_thms ctxt @{thms o_def} dead_pre_map_comp :: V_or_CLeaf_map :: eval :: eval_core_simps @
   7.304 +    @{thms o_apply id_def[symmetric] id_apply snd_conv convol_apply}) ctxt));
   7.305 +
   7.306 +fun mk_eval_Oper_tac ctxt live sig_map_ident sig_map_comp0 sig_map_comp Oper_natural_pointful
   7.307 +    VLeaf_natural flat_simps eval_flat algLam_def =
   7.308 +  let val VLeaf_natural' = instantiate_natural_rule_with_id ctxt live VLeaf_natural in
   7.309 +    unfold_thms_tac ctxt [sig_map_comp, VLeaf_natural', algLam_def, o_apply] THEN
   7.310 +    unfold_thms_tac ctxt (sig_map_comp0 :: Oper_natural_pointful :: (eval_flat RS sym) :: o_apply ::
   7.311 +      flat_simps) THEN
   7.312 +    unfold_thms_tac ctxt (@{thm id_apply} :: sig_map_ident :: unfold_thms ctxt [o_def] sig_map_comp ::
   7.313 +      flat_simps) THEN
   7.314 +    HEADGOAL (rtac ctxt refl)
   7.315 +  end;
   7.316 +
   7.317 +fun mk_extdd_mor_tac ctxt dead_pre_map_comp0 dead_pre_map_comp VLeaf_map ssig_map_comp
   7.318 +    flat_pointful_natural eval_core_pointful_natural eval eval_flat eval_VLeaf cutSsig_def prem =
   7.319 +  HEADGOAL (rtac ctxt ext) THEN
   7.320 +  unfold_thms_tac ctxt (ssig_map_comp :: unfold_thms ctxt [o_def] dead_pre_map_comp ::
   7.321 +    flat_pointful_natural :: eval :: eval_flat :: cutSsig_def ::
   7.322 +    @{thms o_apply convol_o id_o id_apply id_def[symmetric]}) THEN
   7.323 +  unfold_thms_tac ctxt (unfold_thms ctxt [dead_pre_map_comp0] prem :: dead_pre_map_comp0 ::
   7.324 +    ssig_map_comp :: eval_core_pointful_natural ::
   7.325 +    @{thms o_def[symmetric] o_apply map_prod_o_convol}) THEN
   7.326 +  unfold_thms_tac ctxt (VLeaf_map :: eval_VLeaf :: @{thms o_def id_apply id_def[symmetric]}) THEN
   7.327 +  HEADGOAL (rtac ctxt refl);
   7.328 +
   7.329 +fun mk_extdd_o_VLeaf_tac ctxt dead_pre_map_comp0 dead_pre_map_comp dtor_inject ssig_maps
   7.330 +    eval_core_simps eval eval_VLeaf prem =
   7.331 +  HEADGOAL (rtac ctxt ext THEN' rtac ctxt (dtor_inject RS iffD1) THEN'
   7.332 +    asm_simp_tac (ss_only_silent (dead_pre_map_comp0 :: ssig_maps @ eval_core_simps @ eval ::
   7.333 +      eval_VLeaf :: (mk_pointful ctxt prem RS sym) :: unfold_thms ctxt [o_def] dead_pre_map_comp ::
   7.334 +      @{thms o_apply convol_apply snd_conv id_apply}) ctxt));
   7.335 +
   7.336 +fun mk_flat_embL_tac ctxt old_ssig_induct fp_map_id Sig_pointful_natural old_sig_map_comp
   7.337 +    old_sig_map_cong old_ssig_maps old_flat_simps flat_simps embL_simps =
   7.338 +  HEADGOAL (rtac ctxt old_ssig_induct) THEN
   7.339 +  ALLGOALS (asm_simp_tac (Simplifier.add_cong old_sig_map_cong (ss_only_silent
   7.340 +    (fp_map_id :: Sig_pointful_natural :: unfold_thms ctxt [o_def] old_sig_map_comp ::
   7.341 +     old_ssig_maps @ old_flat_simps @ flat_simps @ embL_simps @
   7.342 +     @{thms id_apply id_def[symmetric] map_sum.simps}) ctxt)));
   7.343 +
   7.344 +fun mk_flat_VLeaf_or_flat_tac ctxt ssig_induct cong simps =
   7.345 +  HEADGOAL (rtac ctxt ssig_induct) THEN
   7.346 +  ALLGOALS (asm_simp_tac (Simplifier.add_cong cong (ss_only_silent simps ctxt)));
   7.347 +
   7.348 +fun mk_Lam_Inl_Inr_tac ctxt unsig Lam_def =
   7.349 +  TRYALL Goal.conjunction_tac THEN ALLGOALS (rtac ctxt ext) THEN
   7.350 +  unfold_thms_tac ctxt (o_apply :: Lam_def :: unsig :: @{thms sum.case}) THEN
   7.351 +  ALLGOALS (rtac ctxt refl);
   7.352 +
   7.353 +fun mk_mor_cutSsig_flat_tac ctxt eval_core_o_map dead_pre_map_comp0 dead_pre_map_comp
   7.354 +    dead_pre_map_cong dtor_unfold_unique dead_ssig_map_comp0 ssig_map_comp flat_simps
   7.355 +    flat_pointful_natural eval_core_pointful_natural flat_flat flat_VLeaf eval_core_flat cutSsig_def
   7.356 +    cutSsig_def_pointful_natural eval_thm prem =
   7.357 +  HEADGOAL (rtac ctxt (infer_instantiate' ctxt [NONE, SOME (Thm.cterm_of ctxt eval_core_o_map)]
   7.358 +    (trans OF [dtor_unfold_unique, dtor_unfold_unique RS sym]) OF [ext, ext]) THEN'
   7.359 +  asm_simp_tac (ss_only_silent ((prem RS sym) :: dead_pre_map_comp0 :: ssig_map_comp ::
   7.360 +    eval_core_pointful_natural :: eval_thm ::
   7.361 +    @{thms o_apply map_prod_o_convol o_id convol_o id_o}) ctxt) THEN'
   7.362 +  asm_simp_tac (ss_only_silent ((mk_pointful ctxt prem RS sym) :: dead_pre_map_comp0 ::
   7.363 +    cutSsig_def_pointful_natural :: flat_simps @
   7.364 +    @{thms o_apply convol_apply map_prod_simp id_apply}) ctxt) THEN'
   7.365 +  rtac ctxt (dead_pre_map_cong OF [Drule.asm_rl, refl]) THEN'
   7.366 +  asm_simp_tac (ss_only_silent (ssig_map_comp :: cutSsig_def :: flat_pointful_natural ::
   7.367 +    eval_core_flat :: unfold_thms ctxt [o_def] dead_pre_map_comp :: (dead_ssig_map_comp0 RS sym) ::
   7.368 +    (flat_flat RS sym) ::
   7.369 +    @{thms o_apply convol_o fst_convol id_apply id_def[symmetric]}) ctxt) THEN'
   7.370 +  asm_simp_tac (ss_only_silent (eval_core_pointful_natural :: flat_VLeaf ::
   7.371 +    map (unfold_thms ctxt [o_def]) [dead_pre_map_comp0, ssig_map_comp] @
   7.372 +    @{thms o_apply id_apply id_def[symmetric] map_prod_simp convol_def}) ctxt));
   7.373 +
   7.374 +fun mk_natural_from_transfer_tac ctxt m alives transfer map_ids rel_Grps subst_rel_Grps =
   7.375 +  let
   7.376 +    val unfold_eq = unfold_thms ctxt @{thms Grp_UNIV_id[symmetric]};
   7.377 +    val (rel_Grps', subst_rel_Grps') =
   7.378 +      apply2 (map (fn thm => unfold_eq (thm RS eq_reflection))) (rel_Grps, subst_rel_Grps);
   7.379 +    val transfer' = instantiate_transfer_rule_with_Grp_UNIV ctxt alives (unfold_eq transfer)
   7.380 +      |> unfold_thms ctxt rel_Grps';
   7.381 +  in
   7.382 +    HEADGOAL (Method.insert_tac ctxt [transfer'] THEN'
   7.383 +      EVERY' (map (subst_asm_tac ctxt NONE o single) subst_rel_Grps')) THEN
   7.384 +    unfold_thms_tac ctxt (map_ids @ @{thms Grp_def rel_fun_def}) THEN
   7.385 +    HEADGOAL (REPEAT_DETERM_N m o rtac ctxt ext THEN'
   7.386 +      asm_full_simp_tac (ss_only_silent @{thms simp_thms id_apply o_apply mem_Collect_eq
   7.387 +        top_greatest UNIV_I subset_UNIV[unfolded UNIV_def]} ctxt)) THEN
   7.388 +    ALLGOALS (REPEAT_DETERM o etac ctxt @{thm meta_allE} THEN' REPEAT_DETERM o etac ctxt allE THEN'
   7.389 +      forward_tac ctxt [sym] THEN' assume_tac ctxt)
   7.390 +  end;
   7.391 +
   7.392 +fun mk_natural_by_unfolding_tac ctxt maps =
   7.393 +  HEADGOAL (rtac ctxt ext) THEN
   7.394 +  unfold_thms_tac ctxt (@{thms o_def[abs_def] id_apply id_def[symmetric]} @ maps) THEN
   7.395 +  HEADGOAL (rtac ctxt refl);
   7.396 +
   7.397 +fun mk_Retr_coinduct_tac ctxt dtor_rel_coinduct rel_eq =
   7.398 +  HEADGOAL (EVERY' [rtac ctxt allI, rtac ctxt impI,
   7.399 +    rtac ctxt (@{thm ord_le_eq_trans} OF [dtor_rel_coinduct, rel_eq]),
   7.400 +    etac ctxt @{thm predicate2D}, assume_tac ctxt]);
   7.401 +
   7.402 +fun mk_sig_transfer_tac ctxt pre_rel_def rel_eqs0 transfer =
   7.403 +  let
   7.404 +    val rel_eqs = no_refl rel_eqs0;
   7.405 +    val rel_eq_syms = map (fn thm => thm RS sym) rel_eqs;
   7.406 +    val transfer' = unfold_thms ctxt rel_eq_syms transfer
   7.407 +  in
   7.408 +    HEADGOAL (rtac ctxt transfer') ORELSE
   7.409 +    unfold_thms_tac ctxt (pre_rel_def :: rel_eq_syms @
   7.410 +      @{thms BNF_Def.vimage2p_def BNF_Composition.id_bnf_def}) THEN
   7.411 +    HEADGOAL (rtac ctxt transfer')
   7.412 +  end;
   7.413 +
   7.414 +fun mk_transfer_by_transfer_prover_tac ctxt defs rel_eqs0 transfers =
   7.415 +  let
   7.416 +    val rel_eqs = no_refl rel_eqs0;
   7.417 +    val rel_eq_syms = map (fn thm => thm RS sym) rel_eqs;
   7.418 +  in
   7.419 +    unfold_thms_tac ctxt (defs @ rel_eq_syms) THEN
   7.420 +    HEADGOAL (transfer_prover_add_tac ctxt rel_eqs transfers)
   7.421 +  end;
   7.422 +
   7.423 +end;
     8.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     8.2 +++ b/src/HOL/Tools/BNF/bnf_gfp_grec_unique_sugar.ML	Tue Mar 22 12:39:37 2016 +0100
     8.3 @@ -0,0 +1,73 @@
     8.4 +(*  Title:      HOL/Tools/BNF/bnf_gfp_grec_unique_sugar.ML
     8.5 +    Author:     Jasmin Blanchette, Inria, LORIA, MPII
     8.6 +    Copyright   2016
     8.7 +
     8.8 +Proof method for proving uniqueness of corecursive equations ("corec_unique").
     8.9 +*)
    8.10 +
    8.11 +signature BNF_GFP_GREC_UNIQUE_SUGAR =
    8.12 +sig
    8.13 +  val corec_unique_tac: Proof.context -> int -> tactic
    8.14 +end;
    8.15 +
    8.16 +structure BNF_GFP_Grec_Unique_Sugar : BNF_GFP_GREC_UNIQUE_SUGAR =
    8.17 +struct
    8.18 +
    8.19 +open BNF_Util
    8.20 +open BNF_GFP_Grec
    8.21 +open BNF_GFP_Grec_Sugar_Util
    8.22 +open BNF_GFP_Grec_Sugar
    8.23 +
    8.24 +fun corec_unique_tac ctxt =
    8.25 +  Subgoal.FOCUS (fn {context = ctxt, prems, concl, ...} =>
    8.26 +    let
    8.27 +      (* Workaround for odd name clash for goals with "x" in their context *)
    8.28 +      val (_, ctxt) = ctxt
    8.29 +        |> yield_singleton (mk_Frees "x") @{typ unit};
    8.30 +
    8.31 +      val code_thm = (if null prems then error "No premise" else hd prems)
    8.32 +        |> Object_Logic.rulify ctxt;
    8.33 +      val code_goal = Thm.prop_of code_thm;
    8.34 +
    8.35 +      val (fun_t, args) = strip_comb (fst (HOLogic.dest_eq (HOLogic.dest_Trueprop code_goal)))
    8.36 +        handle TERM _ => error "Wrong format for first premise";
    8.37 +
    8.38 +      val _ = is_Free fun_t orelse
    8.39 +        error ("Expected free variable as function in premise, found " ^
    8.40 +          Syntax.string_of_term ctxt fun_t);
    8.41 +      val _ =
    8.42 +        (case filter_out is_Var args of
    8.43 +          [] => ()
    8.44 +        | arg :: _ =>
    8.45 +          error ("Expected universal variable as argument to function in premise, found " ^
    8.46 +            Syntax.string_of_term ctxt arg));
    8.47 +
    8.48 +      val fun_T = fastype_of fun_t;
    8.49 +      val (arg_Ts, res_T) = strip_type fun_T;
    8.50 +
    8.51 +      val num_args_in_concl = length (snd (strip_comb (fst (HOLogic.dest_eq
    8.52 +          (HOLogic.dest_Trueprop (Thm.term_of concl))))))
    8.53 +        handle TERM _ => error "Wrong format for conclusion";
    8.54 +
    8.55 +      val (corec_info, corec_parse_info) =
    8.56 +        (case maybe_corec_info_of ctxt res_T of
    8.57 +          SOME (info as {buffer, ...}) => (info, corec_parse_info_of ctxt arg_Ts res_T buffer)
    8.58 +        | NONE => error ("No corecursor for " ^ quote (Syntax.string_of_typ ctxt res_T) ^
    8.59 +          " (use " ^ quote (#1 @{command_keyword coinduction_upto}) ^ " to derive it)"));
    8.60 +
    8.61 +      val parsed_eq = parse_corec_equation ctxt [fun_t] code_goal;
    8.62 +      val explored_eq =
    8.63 +        explore_corec_equation ctxt false false "" fun_t corec_parse_info res_T parsed_eq;
    8.64 +
    8.65 +      val ((_, corecUU_arg), _) = build_corecUU_arg_and_goals false fun_t explored_eq ctxt;
    8.66 +      val eq_corecUU = derive_eq_corecUU ctxt corec_info fun_t corecUU_arg code_thm;
    8.67 +
    8.68 +      val unique' = derive_unique ctxt Morphism.identity code_goal corec_info res_T eq_corecUU
    8.69 +        |> funpow num_args_in_concl (fn thm => thm RS fun_cong);
    8.70 +    in
    8.71 +      HEADGOAL ((K all_tac APPEND' rtac ctxt sym) THEN' rtac ctxt unique' THEN'
    8.72 +        REPEAT_DETERM_N num_args_in_concl o rtac ctxt ext)
    8.73 +    end) ctxt THEN'
    8.74 +  etac ctxt thin_rl;
    8.75 +
    8.76 +end;