make predicator a first-class bnf citizen
authortraytel
Tue Feb 16 22:28:19 2016 +0100 (2016-02-16)
changeset 62324ae44f16dcea5
parent 62323 8c3eec5812d8
child 62325 7e4d31eefe60
make predicator a first-class bnf citizen
src/Doc/Datatypes/Datatypes.thy
src/HOL/BNF_Composition.thy
src/HOL/BNF_Def.thy
src/HOL/Basic_BNFs.thy
src/HOL/Cardinals/Bounded_Set.thy
src/HOL/Library/Countable_Set_Type.thy
src/HOL/Library/Dlist.thy
src/HOL/Library/FSet.thy
src/HOL/Library/Multiset.thy
src/HOL/Library/bnf_axiomatization.ML
src/HOL/Probability/Probability_Mass_Function.thy
src/HOL/Tools/BNF/bnf_comp.ML
src/HOL/Tools/BNF/bnf_comp_tactics.ML
src/HOL/Tools/BNF/bnf_def.ML
src/HOL/Tools/BNF/bnf_def_tactics.ML
src/HOL/Tools/BNF/bnf_fp_def_sugar.ML
src/HOL/Tools/BNF/bnf_gfp.ML
src/HOL/Tools/BNF/bnf_lfp.ML
src/HOL/Tools/BNF/bnf_lfp_compat.ML
src/HOL/Tools/BNF/bnf_lift.ML
src/HOL/Tools/BNF/bnf_util.ML
src/HOL/Tools/Lifting/lifting_bnf.ML
src/HOL/Tools/Transfer/transfer_bnf.ML
src/HOL/Transfer.thy
     1.1 --- a/src/Doc/Datatypes/Datatypes.thy	Tue Feb 16 17:01:40 2016 +0100
     1.2 +++ b/src/Doc/Datatypes/Datatypes.thy	Tue Feb 16 22:28:19 2016 +0100
     1.3 @@ -2795,13 +2795,9 @@
     1.4          by (rule, transfer) (auto simp add: rel_fun_def)
     1.5      next
     1.6        fix R :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
     1.7 -      show "rel_fn R =
     1.8 -            (BNF_Def.Grp {x. set_fn x \<subseteq> {(x, y). R x y}} (map_fn fst))\<inverse>\<inverse> OO
     1.9 -             BNF_Def.Grp {x. set_fn x \<subseteq> {(x, y). R x y}} (map_fn snd)"
    1.10 -        unfolding Grp_def fun_eq_iff relcompp.simps conversep.simps
    1.11 -        apply transfer
    1.12 -        unfolding rel_fun_def subset_iff image_iff
    1.13 -        by auto (force, metis prod.collapse)
    1.14 +      show "rel_fn R = (\<lambda>x y. \<exists>z. set_fn z \<subseteq> {(x, y). R x y} \<and> map_fn fst z = x \<and> map_fn snd z = y)"
    1.15 +        unfolding fun_eq_iff relcompp.simps conversep.simps
    1.16 +        by transfer (force simp: rel_fun_def subset_iff)
    1.17      qed
    1.18  
    1.19  text \<open> \blankline \<close>
     2.1 --- a/src/HOL/BNF_Composition.thy	Tue Feb 16 17:01:40 2016 +0100
     2.2 +++ b/src/HOL/BNF_Composition.thy	Tue Feb 16 22:28:19 2016 +0100
     2.3 @@ -78,9 +78,11 @@
     2.4  lemma comp_set_bd_Union_o_collect: "|\<Union>\<Union>((\<lambda>f. f x) ` X)| \<le>o hbd \<Longrightarrow> |(Union \<circ> collect X) x| \<le>o hbd"
     2.5    by (unfold comp_apply collect_def) simp
     2.6  
     2.7 -lemma wpull_cong:
     2.8 -  "\<lbrakk>A' = A; B1' = B1; B2' = B2; wpull A B1 B2 f1 f2 p1 p2\<rbrakk> \<Longrightarrow> wpull A' B1' B2' f1 f2 p1 p2"
     2.9 -  by simp
    2.10 +lemma Collect_inj: "Collect P = Collect Q \<Longrightarrow> P = Q"
    2.11 +  by blast
    2.12 +
    2.13 +lemma Ball_Collect: "Ball A P = (A \<subseteq> (Collect P))"
    2.14 +by auto
    2.15  
    2.16  lemma Grp_fst_snd: "(Grp (Collect (case_prod R)) fst)^--1 OO Grp (Collect (case_prod R)) snd = R"
    2.17    unfolding Grp_def fun_eq_iff relcompp.simps by auto
    2.18 @@ -101,6 +103,12 @@
    2.19  lemma vimage2p_cong: "R = S \<Longrightarrow> vimage2p f g R = vimage2p f g S"
    2.20    by simp
    2.21  
    2.22 +lemma Ball_comp_iff: "(\<lambda>x. Ball (A x) f) o g = (\<lambda>x. Ball ((A o g) x) f)"
    2.23 +  unfolding o_def by auto
    2.24 +
    2.25 +lemma conj_comp_iff: "(\<lambda>x. P x \<and> Q x) o g = (\<lambda>x. (P o g) x \<and> (Q o g) x)"
    2.26 +  unfolding o_def by auto
    2.27 +
    2.28  context
    2.29    fixes Rep Abs
    2.30    assumes type_copy: "type_definition Rep Abs UNIV"
    2.31 @@ -150,7 +158,7 @@
    2.32    map: "id :: 'a \<Rightarrow> 'a"
    2.33    bd: natLeq
    2.34    rel: "op = :: 'a \<Rightarrow> 'a \<Rightarrow> bool"
    2.35 -  by (auto simp add: Grp_def natLeq_card_order natLeq_cinfinite)
    2.36 +  by (auto simp add: natLeq_card_order natLeq_cinfinite)
    2.37  
    2.38  definition id_bnf :: "'a \<Rightarrow> 'a" where
    2.39    "id_bnf \<equiv> (\<lambda>x. x)"
    2.40 @@ -163,6 +171,7 @@
    2.41    sets: "\<lambda>x. {x}"
    2.42    bd: natLeq
    2.43    rel: "id_bnf :: ('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> bool"
    2.44 +  pred: "id_bnf :: ('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> bool"
    2.45    unfolding id_bnf_def
    2.46    apply (auto simp: Grp_def fun_eq_iff relcompp.simps natLeq_card_order natLeq_cinfinite)
    2.47    apply (rule ordLess_imp_ordLeq[OF finite_ordLess_infinite[OF _ natLeq_Well_order]])
     3.1 --- a/src/HOL/BNF_Def.thy	Tue Feb 16 17:01:40 2016 +0100
     3.2 +++ b/src/HOL/BNF_Def.thy	Tue Feb 16 22:28:19 2016 +0100
     3.3 @@ -235,6 +235,36 @@
     3.4  lemma diag_imp_eq_le: "(\<And>x. x \<in> A \<Longrightarrow> R x x) \<Longrightarrow> \<forall>x y. x \<in> A \<longrightarrow> y \<in> A \<longrightarrow> x = y \<longrightarrow> R x y"
     3.5    by blast
     3.6  
     3.7 +definition eq_onp :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
     3.8 +  where "eq_onp R = (\<lambda>x y. R x \<and> x = y)"
     3.9 +
    3.10 +lemma eq_onp_Grp: "eq_onp P = BNF_Def.Grp (Collect P) id"
    3.11 +  unfolding eq_onp_def Grp_def by auto
    3.12 +
    3.13 +lemma eq_onp_to_eq: "eq_onp P x y \<Longrightarrow> x = y"
    3.14 +  by (simp add: eq_onp_def)
    3.15 +
    3.16 +lemma eq_onp_top_eq_eq: "eq_onp top = op ="
    3.17 +  by (simp add: eq_onp_def)
    3.18 +
    3.19 +lemma eq_onp_same_args: "eq_onp P x x = P x"
    3.20 +  using assms by (auto simp add: eq_onp_def)
    3.21 +
    3.22 +lemma eq_onp_eqD: "eq_onp P = Q \<Longrightarrow> P x = Q x x"
    3.23 +  unfolding eq_onp_def by blast
    3.24 +
    3.25 +lemma Ball_Collect: "Ball A P = (A \<subseteq> (Collect P))"
    3.26 +  by auto
    3.27 +
    3.28 +lemma eq_onp_mono0: "\<forall>x\<in>A. P x \<longrightarrow> Q x \<Longrightarrow> \<forall>x\<in>A. \<forall>y\<in>A. eq_onp P x y \<longrightarrow> eq_onp Q x y"
    3.29 +  unfolding eq_onp_def by auto
    3.30 +
    3.31 +lemma eq_onp_True: "eq_onp (\<lambda>_. True) = (op =)"
    3.32 +  unfolding eq_onp_def by simp
    3.33 +
    3.34 +lemma Ball_image_comp: "Ball (f ` A) g = Ball A (g o f)"
    3.35 +  by auto
    3.36 +
    3.37  ML_file "Tools/BNF/bnf_util.ML"
    3.38  ML_file "Tools/BNF/bnf_tactics.ML"
    3.39  ML_file "Tools/BNF/bnf_def_tactics.ML"
     4.1 --- a/src/HOL/Basic_BNFs.thy	Tue Feb 16 17:01:40 2016 +0100
     4.2 +++ b/src/HOL/Basic_BNFs.thy	Tue Feb 16 22:28:19 2016 +0100
     4.3 @@ -30,12 +30,19 @@
     4.4    "rel_sum R1 R2 (Inr a2) (Inr b2) = R2 a2 b2"
     4.5    by (auto intro: rel_sum.intros elim: rel_sum.cases)
     4.6  
     4.7 +inductive
     4.8 +   pred_sum :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'a + 'b \<Rightarrow> bool" for P1 P2
     4.9 +where
    4.10 +  "P1 a \<Longrightarrow> pred_sum P1 P2 (Inl a)"
    4.11 +| "P2 b \<Longrightarrow> pred_sum P1 P2 (Inr b)"
    4.12 +
    4.13  bnf "'a + 'b"
    4.14    map: map_sum
    4.15    sets: setl setr
    4.16    bd: natLeq
    4.17    wits: Inl Inr
    4.18    rel: rel_sum
    4.19 +  pred: pred_sum
    4.20  proof -
    4.21    show "map_sum id id = id" by (rule map_sum.id)
    4.22  next
    4.23 @@ -82,12 +89,12 @@
    4.24      by (force elim: rel_sum.cases)
    4.25  next
    4.26    fix R S
    4.27 -  show "rel_sum R S =
    4.28 -        (Grp {x. setl x \<subseteq> Collect (case_prod R) \<and> setr x \<subseteq> Collect (case_prod S)} (map_sum fst fst))\<inverse>\<inverse> OO
    4.29 -        Grp {x. setl x \<subseteq> Collect (case_prod R) \<and> setr x \<subseteq> Collect (case_prod S)} (map_sum snd snd)"
    4.30 -  unfolding sum_set_defs Grp_def relcompp.simps conversep.simps fun_eq_iff
    4.31 +  show "rel_sum R S = (\<lambda>x y.
    4.32 +    \<exists>z. (setl z \<subseteq> {(x, y). R x y} \<and> setr z \<subseteq> {(x, y). S x y}) \<and>
    4.33 +    map_sum fst fst z = x \<and> map_sum snd snd z = y)"
    4.34 +  unfolding sum_set_defs relcompp.simps conversep.simps fun_eq_iff
    4.35    by (fastforce elim: rel_sum.cases split: sum.splits)
    4.36 -qed (auto simp: sum_set_defs)
    4.37 +qed (auto simp: sum_set_defs fun_eq_iff pred_sum.simps split: sum.splits)
    4.38  
    4.39  inductive_set fsts :: "'a \<times> 'b \<Rightarrow> 'a set" for p :: "'a \<times> 'b" where
    4.40    "fst p \<in> fsts p"
    4.41 @@ -102,19 +109,37 @@
    4.42  where
    4.43    "\<lbrakk>R1 a b; R2 c d\<rbrakk> \<Longrightarrow> rel_prod R1 R2 (a, c) (b, d)"
    4.44  
    4.45 +inductive
    4.46 +  pred_prod :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'a \<times> 'b \<Rightarrow> bool" for P1 P2
    4.47 +where
    4.48 +  "\<lbrakk>P1 a; P2 b\<rbrakk> \<Longrightarrow> pred_prod P1 P2 (a, b)"
    4.49 +
    4.50  lemma rel_prod_apply [code, simp]:
    4.51    "rel_prod R1 R2 (a, b) (c, d) \<longleftrightarrow> R1 a c \<and> R2 b d"
    4.52    by (auto intro: rel_prod.intros elim: rel_prod.cases)
    4.53  
    4.54 +lemma pred_prod_apply [code, simp]:
    4.55 +  "pred_prod P1 P2 (a, b) \<longleftrightarrow> P1 a \<and> P2 b"
    4.56 +  by (auto intro: pred_prod.intros elim: pred_prod.cases)
    4.57 +
    4.58  lemma rel_prod_conv:
    4.59    "rel_prod R1 R2 = (\<lambda>(a, b) (c, d). R1 a c \<and> R2 b d)"
    4.60    by (rule ext, rule ext) auto
    4.61  
    4.62 +definition
    4.63 +  pred_fun :: "('a \<Rightarrow> bool) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> bool"
    4.64 +where
    4.65 +  "pred_fun A B = (\<lambda>f. \<forall>x. A x \<longrightarrow> B (f x))"
    4.66 +
    4.67 +lemma pred_funI: "(\<And>x. A x \<Longrightarrow> B (f x)) \<Longrightarrow> pred_fun A B f"
    4.68 +  unfolding pred_fun_def by simp
    4.69 +
    4.70  bnf "'a \<times> 'b"
    4.71    map: map_prod
    4.72    sets: fsts snds
    4.73    bd: natLeq
    4.74    rel: rel_prod
    4.75 +  pred: pred_prod
    4.76  proof (unfold prod_set_defs)
    4.77    show "map_prod id id = id" by (rule map_prod.id)
    4.78  next
    4.79 @@ -150,18 +175,19 @@
    4.80    show "rel_prod R1 R2 OO rel_prod S1 S2 \<le> rel_prod (R1 OO S1) (R2 OO S2)" by auto
    4.81  next
    4.82    fix R S
    4.83 -  show "rel_prod R S =
    4.84 -        (Grp {x. {fst x} \<subseteq> Collect (case_prod R) \<and> {snd x} \<subseteq> Collect (case_prod S)} (map_prod fst fst))\<inverse>\<inverse> OO
    4.85 -        Grp {x. {fst x} \<subseteq> Collect (case_prod R) \<and> {snd x} \<subseteq> Collect (case_prod S)} (map_prod snd snd)"
    4.86 -  unfolding prod_set_defs rel_prod_apply Grp_def relcompp.simps conversep.simps fun_eq_iff
    4.87 +  show "rel_prod R S = (\<lambda>x y.
    4.88 +    \<exists>z. ({fst z} \<subseteq> {(x, y). R x y} \<and> {snd z} \<subseteq> {(x, y). S x y}) \<and>
    4.89 +      map_prod fst fst z = x \<and> map_prod snd snd z = y)"
    4.90 +  unfolding prod_set_defs rel_prod_apply relcompp.simps conversep.simps fun_eq_iff
    4.91    by auto
    4.92 -qed
    4.93 +qed auto
    4.94  
    4.95  bnf "'a \<Rightarrow> 'b"
    4.96    map: "op \<circ>"
    4.97    sets: range
    4.98    bd: "natLeq +c |UNIV :: 'a set|"
    4.99    rel: "rel_fun op ="
   4.100 +  pred: "pred_fun (\<lambda>_. True)"
   4.101  proof
   4.102    fix f show "id \<circ> f = id f" by simp
   4.103  next
   4.104 @@ -194,17 +220,9 @@
   4.105    show "rel_fun op = R OO rel_fun op = S \<le> rel_fun op = (R OO S)" by (auto simp: rel_fun_def)
   4.106  next
   4.107    fix R
   4.108 -  show "rel_fun op = R =
   4.109 -        (Grp {x. range x \<subseteq> Collect (case_prod R)} (op \<circ> fst))\<inverse>\<inverse> OO
   4.110 -         Grp {x. range x \<subseteq> Collect (case_prod R)} (op \<circ> snd)"
   4.111 -  unfolding rel_fun_def Grp_def fun_eq_iff relcompp.simps conversep.simps subset_iff image_iff
   4.112 -    comp_apply mem_Collect_eq split_beta bex_UNIV
   4.113 -  proof (safe, unfold fun_eq_iff[symmetric])
   4.114 -    fix x xa a b c xb y aa ba
   4.115 -    assume *: "x = a" "xa = c" "a = ba" "b = aa" "c = (\<lambda>x. snd (b x))" "ba = (\<lambda>x. fst (aa x))" and
   4.116 -       **: "\<forall>t. (\<exists>x. t = aa x) \<longrightarrow> R (fst t) (snd t)"
   4.117 -    show "R (x y) (xa y)" unfolding * by (rule mp[OF spec[OF **]]) blast
   4.118 -  qed force
   4.119 -qed
   4.120 +  show "rel_fun op = R = (\<lambda>x y.
   4.121 +    \<exists>z. range z \<subseteq> {(x, y). R x y} \<and> fst \<circ> z = x \<and> snd \<circ> z = y)"
   4.122 +  unfolding rel_fun_def subset_iff by (force simp: fun_eq_iff[symmetric])
   4.123 +qed (auto simp: pred_fun_def)
   4.124  
   4.125  end
     5.1 --- a/src/HOL/Cardinals/Bounded_Set.thy	Tue Feb 16 17:01:40 2016 +0100
     5.2 +++ b/src/HOL/Cardinals/Bounded_Set.thy	Tue Feb 16 22:28:19 2016 +0100
     5.3 @@ -98,10 +98,10 @@
     5.4      by (rule predicate2I, transfer) (auto simp: rel_set_OO[symmetric])
     5.5  next
     5.6    fix R :: "'a \<Rightarrow> 'b \<Rightarrow> bool"
     5.7 -  show "rel_bset R = ((BNF_Def.Grp {x. set_bset x \<subseteq> {(x, y). R x y}} (map_bset fst))\<inverse>\<inverse> OO
     5.8 -         BNF_Def.Grp {x. set_bset x \<subseteq> {(x, y). R x y}} (map_bset snd) ::
     5.9 -         'a set['k] \<Rightarrow> 'b set['k] \<Rightarrow> bool)"
    5.10 -    by (simp add: rel_bset_def map_fun_def o_def rel_set_def rel_bset_aux_infinite)
    5.11 +  show "rel_bset R = ((\<lambda>x y. \<exists>z. set_bset z \<subseteq> {(x, y). R x y} \<and>
    5.12 +    map_bset fst z = x \<and> map_bset snd z = y) :: 'a set['k] \<Rightarrow> 'b set['k] \<Rightarrow> bool)"
    5.13 +    by (simp add: rel_bset_def map_fun_def o_def rel_set_def
    5.14 +      rel_bset_aux_infinite[unfolded OO_Grp_alt])
    5.15  next
    5.16    fix x
    5.17    assume "x \<in> set_bset bempty"
     6.1 --- a/src/HOL/Library/Countable_Set_Type.thy	Tue Feb 16 17:01:40 2016 +0100
     6.2 +++ b/src/HOL/Library/Countable_Set_Type.thy	Tue Feb 16 22:28:19 2016 +0100
     6.3 @@ -606,10 +606,9 @@
     6.4      unfolding rel_cset_alt_def[abs_def] by fast
     6.5  next
     6.6    fix R
     6.7 -  show "rel_cset R =
     6.8 -        (BNF_Def.Grp {x. rcset x \<subseteq> Collect (case_prod R)} (cimage fst))\<inverse>\<inverse> OO
     6.9 -         BNF_Def.Grp {x. rcset x \<subseteq> Collect (case_prod R)} (cimage snd)"
    6.10 -  unfolding rel_cset_alt_def[abs_def] rel_cset_aux by simp
    6.11 +  show "rel_cset R = (\<lambda>x y. \<exists>z. rcset z \<subseteq> {(x, y). R x y} \<and>
    6.12 +    cimage fst z = x \<and> cimage snd z = y)"
    6.13 +  unfolding rel_cset_alt_def[abs_def] rel_cset_aux[unfolded OO_Grp_alt] by simp
    6.14  qed(simp add: bot_cset.rep_eq)
    6.15  
    6.16  end
     7.1 --- a/src/HOL/Library/Dlist.thy	Tue Feb 16 17:01:40 2016 +0100
     7.2 +++ b/src/HOL/Library/Dlist.thy	Tue Feb 16 22:28:19 2016 +0100
     7.3 @@ -326,7 +326,6 @@
     7.4  subgoal by(simp add: natLeq_cinfinite)
     7.5  subgoal by(rule ordLess_imp_ordLeq)(simp add: finite_iff_ordLess_natLeq[symmetric] set_def)
     7.6  subgoal by(rule predicate2I)(transfer; auto simp add: wpull)
     7.7 -subgoal by(rule refl)
     7.8  subgoal by(simp add: set_def)
     7.9  done
    7.10  
     8.1 --- a/src/HOL/Library/FSet.thy	Tue Feb 16 17:01:40 2016 +0100
     8.2 +++ b/src/HOL/Library/FSet.thy	Tue Feb 16 22:28:19 2016 +0100
     8.3 @@ -972,7 +972,8 @@
     8.4       apply (rule natLeq_cinfinite)
     8.5      apply transfer apply (metis ordLess_imp_ordLeq finite_iff_ordLess_natLeq)
     8.6     apply (fastforce simp: rel_fset_alt)
     8.7 - apply (simp add: Grp_def relcompp.simps conversep.simps fun_eq_iff rel_fset_alt rel_fset_aux) 
     8.8 + apply (simp add: Grp_def relcompp.simps conversep.simps fun_eq_iff rel_fset_alt
     8.9 +   rel_fset_aux[unfolded OO_Grp_alt]) 
    8.10  apply transfer apply simp
    8.11  done
    8.12  
     9.1 --- a/src/HOL/Library/Multiset.thy	Tue Feb 16 17:01:40 2016 +0100
     9.2 +++ b/src/HOL/Library/Multiset.thy	Tue Feb 16 22:28:19 2016 +0100
     9.3 @@ -2302,12 +2302,18 @@
     9.4  lemma ex_mset: "\<exists>xs. mset xs = X"
     9.5    by (induct X) (simp, metis mset.simps(2))
     9.6  
     9.7 +inductive pred_mset :: "('a \<Rightarrow> bool) \<Rightarrow> 'a multiset \<Rightarrow> bool"
     9.8 +where
     9.9 +  "pred_mset P {#}"
    9.10 +| "\<lbrakk>P a; pred_mset P M\<rbrakk> \<Longrightarrow> pred_mset P (M + {#a#})"
    9.11 +
    9.12  bnf "'a multiset"
    9.13    map: image_mset
    9.14    sets: set_mset
    9.15    bd: natLeq
    9.16    wits: "{#}"
    9.17    rel: rel_mset
    9.18 +  pred: pred_mset
    9.19  proof -
    9.20    show "image_mset id = id"
    9.21      by (rule image_mset.id)
    9.22 @@ -2334,16 +2340,13 @@
    9.23        done
    9.24      done
    9.25    show "rel_mset R =
    9.26 -    (BNF_Def.Grp {x. set_mset x \<subseteq> {(x, y). R x y}} (image_mset fst))\<inverse>\<inverse> OO
    9.27 -    BNF_Def.Grp {x. set_mset x \<subseteq> {(x, y). R x y}} (image_mset snd)" for R
    9.28 -    unfolding rel_mset_def[abs_def] BNF_Def.Grp_def OO_def
    9.29 +    (\<lambda>x y. \<exists>z. set_mset z \<subseteq> {(x, y). R x y} \<and>
    9.30 +    image_mset fst z = x \<and> image_mset snd z = y)" for R
    9.31 +    unfolding rel_mset_def[abs_def]
    9.32      apply (rule ext)+
    9.33 -    apply auto
    9.34 -     apply (rule_tac x = "mset (zip xs ys)" in exI; auto)
    9.35 -        apply (metis list_all2_lengthD map_fst_zip mset_map)
    9.36 -       apply (auto simp: list_all2_iff)[1]
    9.37 -      apply (metis list_all2_lengthD map_snd_zip mset_map)
    9.38 -     apply (auto simp: list_all2_iff)[1]
    9.39 +    apply safe
    9.40 +     apply (rule_tac x = "mset (zip xs ys)" in exI;
    9.41 +       auto simp: in_set_zip list_all2_iff mset_map[symmetric])
    9.42      apply (rename_tac XY)
    9.43      apply (cut_tac X = XY in ex_mset)
    9.44      apply (erule exE)
    9.45 @@ -2355,6 +2358,16 @@
    9.46      done
    9.47    show "z \<in> set_mset {#} \<Longrightarrow> False" for z
    9.48      by auto
    9.49 +  show "pred_mset P = (\<lambda>x. Ball (set_mset x) P)" for P
    9.50 +  proof (intro ext iffI)
    9.51 +    fix x
    9.52 +    assume "pred_mset P x"
    9.53 +    then show "Ball (set_mset x) P" by (induct pred: pred_mset; simp)
    9.54 +  next
    9.55 +    fix x
    9.56 +    assume "Ball (set_mset x) P"
    9.57 +    then show "pred_mset P x" by (induct x; auto intro: pred_mset.intros)
    9.58 +  qed
    9.59  qed
    9.60  
    9.61  inductive rel_mset'
    10.1 --- a/src/HOL/Library/bnf_axiomatization.ML	Tue Feb 16 17:01:40 2016 +0100
    10.2 +++ b/src/HOL/Library/bnf_axiomatization.ML	Tue Feb 16 22:28:19 2016 +0100
    10.3 @@ -8,7 +8,8 @@
    10.4  signature BNF_AXIOMATIZATION =
    10.5  sig
    10.6    val bnf_axiomatization: (string -> bool) -> (binding option * (typ * sort)) list -> binding ->
    10.7 -    mixfix -> binding -> binding -> typ list -> local_theory -> BNF_Def.bnf * local_theory
    10.8 +    mixfix -> binding -> binding -> binding -> typ list -> local_theory ->
    10.9 +    BNF_Def.bnf * local_theory
   10.10  end
   10.11  
   10.12  structure BNF_Axiomatization : BNF_AXIOMATIZATION =
   10.13 @@ -18,7 +19,7 @@
   10.14  open BNF_Def
   10.15  
   10.16  fun prepare_decl prepare_plugins prepare_constraint prepare_typ
   10.17 -    raw_plugins raw_vars b mx user_mapb user_relb user_witTs lthy =
   10.18 +    raw_plugins raw_vars b mx user_mapb user_relb user_predb user_witTs lthy =
   10.19    let
   10.20     val plugins = prepare_plugins lthy raw_plugins;
   10.21  
   10.22 @@ -72,7 +73,8 @@
   10.23        Const (Local_Theory.full_name lthy witb, witT)) witbs witTs;
   10.24      val (key, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, _) =
   10.25        prepare_def Do_Inline (user_policy Note_Some) false I (K I) (K I) (SOME (map TFree deads))
   10.26 -      user_mapb user_relb user_setbs ((((((Binding.empty, T), Fmap), Fsets), Fbd), Fwits), NONE)
   10.27 +      user_mapb user_relb user_predb user_setbs
   10.28 +      (((((((Binding.empty, T), Fmap), Fsets), Fbd), Fwits), NONE), NONE)
   10.29        lthy;
   10.30  
   10.31      fun mk_wits_tac ctxt set_maps = TRYALL Goal.conjunction_tac THEN the triv_tac_opt ctxt set_maps;
   10.32 @@ -116,12 +118,12 @@
   10.33  
   10.34  val parse_bnf_axiomatization =
   10.35    parse_bnf_axiomatization_options -- parse_type_args_named_constrained -- Parse.binding --
   10.36 -  parse_witTs -- Parse.opt_mixfix -- parse_map_rel_bindings;
   10.37 +  parse_witTs -- Parse.opt_mixfix -- parse_map_rel_pred_bindings;
   10.38  
   10.39  val _ =
   10.40    Outer_Syntax.local_theory @{command_keyword bnf_axiomatization} "bnf declaration"
   10.41      (parse_bnf_axiomatization >> 
   10.42 -      (fn (((((plugins, bsTs), b), witTs), mx), (mapb, relb)) =>
   10.43 -         bnf_axiomatization_cmd plugins bsTs b mx mapb relb witTs #> snd));
   10.44 +      (fn (((((plugins, bsTs), b), witTs), mx), (mapb, relb, predb)) =>
   10.45 +         bnf_axiomatization_cmd plugins bsTs b mx mapb relb predb witTs #> snd));
   10.46  
   10.47  end;
    11.1 --- a/src/HOL/Probability/Probability_Mass_Function.thy	Tue Feb 16 17:01:40 2016 +0100
    11.2 +++ b/src/HOL/Probability/Probability_Mass_Function.thy	Tue Feb 16 22:28:19 2016 +0100
    11.3 @@ -1097,10 +1097,9 @@
    11.4      finally show ?thesis .
    11.5    qed
    11.6  
    11.7 -  show "\<And>R. rel_pmf R =
    11.8 -         (BNF_Def.Grp {x. set_pmf x \<subseteq> {(x, y). R x y}} (map_pmf fst))\<inverse>\<inverse> OO
    11.9 -         BNF_Def.Grp {x. set_pmf x \<subseteq> {(x, y). R x y}} (map_pmf snd)"
   11.10 -     by (auto simp add: fun_eq_iff BNF_Def.Grp_def OO_def rel_pmf.simps)
   11.11 +  show "\<And>R. rel_pmf R = (\<lambda>x y. \<exists>z. set_pmf z \<subseteq> {(x, y). R x y} \<and>
   11.12 +    map_pmf fst z = x \<and> map_pmf snd z = y)"
   11.13 +     by (auto simp add: fun_eq_iff rel_pmf.simps)
   11.14  
   11.15    show "rel_pmf R OO rel_pmf S \<le> rel_pmf (R OO S)"
   11.16      for R :: "'a \<Rightarrow> 'b \<Rightarrow> bool" and S :: "'b \<Rightarrow> 'c \<Rightarrow> bool"
    12.1 --- a/src/HOL/Tools/BNF/bnf_comp.ML	Tue Feb 16 17:01:40 2016 +0100
    12.2 +++ b/src/HOL/Tools/BNF/bnf_comp.ML	Tue Feb 16 22:28:19 2016 +0100
    12.3 @@ -171,9 +171,10 @@
    12.4        (Variable.invent_types (replicate ilive @{sort type}) lthy3);
    12.5      val Bss_repl = replicate olive Bs;
    12.6  
    12.7 -    val ((((fs', Qs'), Asets), xs), _) = names_lthy
    12.8 +    val (((((fs', Qs'), Ps'), Asets), xs), _) = names_lthy
    12.9        |> apfst snd o mk_Frees' "f" (map2 (curry op -->) As Bs)
   12.10        ||>> apfst snd o mk_Frees' "Q" (map2 mk_pred2T As Bs)
   12.11 +      ||>> apfst snd o mk_Frees' "P" (map mk_pred1T As)
   12.12        ||>> mk_Frees "A" (map HOLogic.mk_setT As)
   12.13        ||>> mk_Frees "x" As;
   12.14  
   12.15 @@ -196,6 +197,11 @@
   12.16        (Term.list_comb (mk_rel_of_bnf oDs CAs CBs outer,
   12.17          map2 (fn Ds => (fn f => Term.list_comb (f, map Bound (ilive - 1 downto 0))) o
   12.18            mk_rel_of_bnf Ds As Bs) Dss inners));
   12.19 +    (*%P1 ... Pn. outer.pred (inner_1.pred P1 ... Pn) ... (inner_m.pred P1 ... Pn)*)
   12.20 +    val pred = fold_rev Term.abs Ps'
   12.21 +      (Term.list_comb (mk_pred_of_bnf oDs CAs outer,
   12.22 +        map2 (fn Ds => (fn f => Term.list_comb (f, map Bound (ilive - 1 downto 0))) o
   12.23 +          mk_pred_of_bnf Ds As) Dss inners));
   12.24  
   12.25      (*Union o collect {outer.set_1 ... outer.set_m} o outer.map inner_1.set_i ... inner_m.set_i*)
   12.26      (*Union o collect {image inner_1.set_i o outer.set_1 ... image inner_m.set_i o outer.set_m}*)
   12.27 @@ -327,18 +333,28 @@
   12.28        let
   12.29          val outer_rel_Grp = rel_Grp_of_bnf outer RS sym;
   12.30          val thm =
   12.31 -          (trans OF [in_alt_thm RS @{thm OO_Grp_cong},
   12.32 +          trans OF [in_alt_thm RS @{thm OO_Grp_cong},
   12.33               trans OF [@{thm arg_cong2[of _ _ _ _ relcompp]} OF
   12.34                 [trans OF [outer_rel_Grp RS @{thm arg_cong[of _ _ conversep]},
   12.35                   rel_conversep_of_bnf outer RS sym], outer_rel_Grp],
   12.36                 trans OF [rel_OO_of_bnf outer RS sym, rel_cong0_of_bnf outer OF
   12.37 -                 (map (fn bnf => rel_OO_Grp_of_bnf bnf RS sym) inners)]]] RS sym);
   12.38 +                 (map (fn bnf => rel_OO_Grp_of_bnf bnf RS sym) inners)]]] RS sym;
   12.39        in
   12.40          unfold_thms_tac ctxt set'_eq_sets THEN rtac ctxt thm 1
   12.41        end;
   12.42  
   12.43 +    fun pred_set_tac ctxt =
   12.44 +      let
   12.45 +        val pred_alt = unfold_thms ctxt @{thms Ball_Collect}
   12.46 +          (trans OF [pred_cong0_of_bnf outer OF map pred_set_of_bnf inners, pred_set_of_bnf outer]);
   12.47 +        val in_alt = in_alt_thm RS @{thm Collect_inj} RS sym;
   12.48 +      in
   12.49 +        unfold_thms_tac ctxt (@{thm Ball_Collect} :: set'_eq_sets) THEN
   12.50 +        HEADGOAL (rtac ctxt (trans OF [pred_alt, in_alt]))
   12.51 +      end
   12.52 +
   12.53      val tacs = zip_axioms map_id0_tac map_comp0_tac map_cong0_tac set_map0_tacs bd_card_order_tac
   12.54 -      bd_cinfinite_tac set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac;
   12.55 +      bd_cinfinite_tac set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac pred_set_tac;
   12.56  
   12.57      val outer_wits = mk_wits_of_bnf (replicate onwits oDs) (replicate onwits CAs) outer;
   12.58  
   12.59 @@ -361,7 +377,8 @@
   12.60  
   12.61      val (bnf', lthy') =
   12.62        bnf_def const_policy (K Dont_Note) true qualify tacs wit_tac (SOME (oDs @ flat Dss))
   12.63 -        Binding.empty Binding.empty [] ((((((b, CCA), mapx), sets'), bd'), wits), SOME rel) lthy;
   12.64 +        Binding.empty Binding.empty Binding.empty []
   12.65 +        (((((((b, CCA), mapx), sets'), bd'), wits), SOME rel), SOME pred) lthy;
   12.66  
   12.67      val phi =
   12.68        Morphism.thm_morphism "BNF" (unfold_thms lthy' [id_bnf_def])
   12.69 @@ -402,6 +419,9 @@
   12.70      val mapx = Term.list_comb (mk_map_of_bnf Ds As Bs bnf, map HOLogic.id_const killedAs);
   12.71      (*bnf.rel (op =) ... (op =)*)
   12.72      val rel = Term.list_comb (mk_rel_of_bnf Ds As Bs bnf, map HOLogic.eq_const killedAs);
   12.73 +    (*bnf.pred (%_. True) ... (%_ True)*)
   12.74 +    val pred = Term.list_comb (mk_pred_of_bnf Ds As bnf,
   12.75 +      map (fn T => Term.absdummy T @{term True}) killedAs);
   12.76  
   12.77      val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
   12.78      val sets = drop n bnf_sets;
   12.79 @@ -448,8 +468,10 @@
   12.80          rtac ctxt thm 1
   12.81        end;
   12.82  
   12.83 +    fun pred_set_tac ctxt = mk_simple_pred_set_tac ctxt (pred_set_of_bnf bnf) in_alt_thm;
   12.84 +
   12.85      val tacs = zip_axioms map_id0_tac map_comp0_tac map_cong0_tac set_map0_tacs bd_card_order_tac
   12.86 -      bd_cinfinite_tac set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac;
   12.87 +      bd_cinfinite_tac set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac pred_set_tac;
   12.88  
   12.89      val bnf_wits = mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf;
   12.90  
   12.91 @@ -460,7 +482,8 @@
   12.92  
   12.93      val (bnf', lthy') =
   12.94        bnf_def Smart_Inline (K Dont_Note) true qualify tacs wit_tac (SOME (Ds @ killedAs))
   12.95 -        Binding.empty Binding.empty [] ((((((b, T), mapx), sets), bd), wits), SOME rel) lthy;
   12.96 +        Binding.empty Binding.empty Binding.empty []
   12.97 +        (((((((b, T), mapx), sets), bd), wits), SOME rel), SOME pred) lthy;
   12.98    in
   12.99      (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
  12.100    end;
  12.101 @@ -501,6 +524,8 @@
  12.102        fold_rev Term.absdummy (map2 (curry op -->) newAs newBs) (mk_map_of_bnf Ds As Bs bnf);
  12.103      (*%Q1 ... Qn. bnf.rel*)
  12.104      val rel = fold_rev Term.absdummy (map2 mk_pred2T newAs newBs) (mk_rel_of_bnf Ds As Bs bnf);
  12.105 +    (*%P1 ... Pn. bnf.pred*)
  12.106 +    val pred = fold_rev Term.absdummy (map mk_pred1T newAs) (mk_pred_of_bnf Ds As bnf);
  12.107  
  12.108      val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
  12.109      val sets = map (fn A => absdummy T (HOLogic.mk_set A [])) newAs @ bnf_sets;
  12.110 @@ -542,8 +567,10 @@
  12.111  
  12.112      fun rel_OO_Grp_tac ctxt = mk_simple_rel_OO_Grp_tac ctxt (rel_OO_Grp_of_bnf bnf) in_alt_thm;
  12.113  
  12.114 +    fun pred_set_tac ctxt = mk_simple_pred_set_tac ctxt (pred_set_of_bnf bnf) in_alt_thm;
  12.115 +
  12.116      val tacs = zip_axioms map_id0_tac map_comp0_tac map_cong0_tac set_map0_tacs bd_card_order_tac
  12.117 -      bd_cinfinite_tac set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac;
  12.118 +      bd_cinfinite_tac set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac pred_set_tac;
  12.119  
  12.120      val wits = map snd (mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf);
  12.121  
  12.122 @@ -551,7 +578,8 @@
  12.123  
  12.124      val (bnf', lthy') =
  12.125        bnf_def Smart_Inline (K Dont_Note) true qualify tacs wit_tac (SOME Ds) Binding.empty
  12.126 -        Binding.empty [] ((((((b, T), mapx), sets), bd), wits), SOME rel) lthy;
  12.127 +        Binding.empty Binding.empty []
  12.128 +        (((((((b, T), mapx), sets), bd), wits), SOME rel), SOME pred) lthy;
  12.129    in
  12.130      (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
  12.131    end;
  12.132 @@ -594,6 +622,9 @@
  12.133      (*%Q(1) ... Q(n). bnf.rel Q\<sigma>(1) ... Q\<sigma>(n)*)
  12.134      val rel = fold_rev Term.absdummy (permute (map2 mk_pred2T As Bs))
  12.135        (Term.list_comb (mk_rel_of_bnf Ds As Bs bnf, unpermute (map Bound (live - 1 downto 0))));
  12.136 +    (*%P(1) ... P(n). bnf.pred P\<sigma>(1) ... P\<sigma>(n)*)
  12.137 +    val pred = fold_rev Term.absdummy (permute (map mk_pred1T As))
  12.138 +      (Term.list_comb (mk_pred_of_bnf Ds As bnf, unpermute (map Bound (live - 1 downto 0))));
  12.139  
  12.140      val bnf_sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf;
  12.141      val sets = permute bnf_sets;
  12.142 @@ -624,8 +655,10 @@
  12.143  
  12.144      fun rel_OO_Grp_tac ctxt = mk_simple_rel_OO_Grp_tac ctxt (rel_OO_Grp_of_bnf bnf) in_alt_thm;
  12.145  
  12.146 +    fun pred_set_tac ctxt = mk_simple_pred_set_tac ctxt (pred_set_of_bnf bnf) in_alt_thm;
  12.147 +
  12.148      val tacs = zip_axioms map_id0_tac map_comp0_tac map_cong0_tac set_map0_tacs bd_card_order_tac
  12.149 -      bd_cinfinite_tac set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac;
  12.150 +      bd_cinfinite_tac set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac pred_set_tac;
  12.151  
  12.152      val wits = map snd (mk_wits_of_bnf (replicate nwits Ds) (replicate nwits As) bnf);
  12.153  
  12.154 @@ -633,7 +666,8 @@
  12.155  
  12.156      val (bnf', lthy') =
  12.157        bnf_def Smart_Inline (K Dont_Note) true qualify tacs wit_tac (SOME Ds) Binding.empty
  12.158 -        Binding.empty [] ((((((b, T), mapx), sets), bd), wits), SOME rel) lthy;
  12.159 +        Binding.empty Binding.empty []
  12.160 +        (((((((b, T), mapx), sets), bd), wits), SOME rel), SOME pred) lthy;
  12.161    in
  12.162      (bnf', (add_bnf_to_unfolds bnf' unfold_set, lthy'))
  12.163    end;
  12.164 @@ -788,9 +822,10 @@
  12.165        (Variable.invent_types (replicate live @{sort type}) (fold Variable.declare_typ Ds lthy));
  12.166      val (Bs, _) = apfst (map TFree) (Variable.invent_types (replicate live @{sort type}) lthy1);
  12.167  
  12.168 -    val (((fs, fs'), (Rs, Rs')), _(*names_lthy*)) = lthy
  12.169 +    val ((((fs, fs'), (Rs, Rs')), (Ps, Ps')), _(*names_lthy*)) = lthy
  12.170        |> mk_Frees' "f" (map2 (curry op -->) As Bs)
  12.171 -      ||>> mk_Frees' "R" (map2 mk_pred2T As Bs);
  12.172 +      ||>> mk_Frees' "R" (map2 mk_pred2T As Bs)
  12.173 +      ||>> mk_Frees' "P" (map mk_pred1T As);
  12.174  
  12.175      val repTA = mk_T_of_bnf Ds As bnf;
  12.176      val T_bind = qualify b;
  12.177 @@ -821,6 +856,8 @@
  12.178      val bnf_bd = mk_bd_of_bnf Ds As bnf;
  12.179      val bnf_rel = fold_rev Term.absfree Rs' (mk_vimage2p RepA RepB $
  12.180        (Term.list_comb (mk_rel_of_bnf Ds As Bs bnf, Rs)));
  12.181 +    val bnf_pred = fold_rev Term.absfree Ps' (HOLogic.mk_comp
  12.182 +      (Term.list_comb (mk_pred_of_bnf Ds As bnf, Ps), RepA));
  12.183  
  12.184      (*bd may depend only on dead type variables*)
  12.185      val bd_repT = fst (dest_relT (fastype_of bnf_bd));
  12.186 @@ -873,11 +910,15 @@
  12.187           type_definition RS @{thm type_copy_vimage2p_Grp_Rep},
  12.188           type_definition RS @{thm vimage2p_relcompp_converse}]) THEN'
  12.189         rtac ctxt refl) 1;
  12.190 +    fun pred_set_tac ctxt =
  12.191 +      HEADGOAL (EVERY'
  12.192 +        [rtac ctxt (pred_set_of_bnf bnf RS @{thm arg_cong[of _ _ "\<lambda>f. f o _"]} RS trans),
  12.193 +        SELECT_GOAL (unfold_thms_tac ctxt (@{thms Ball_comp_iff conj_comp_iff})), rtac ctxt refl]);
  12.194  
  12.195      val tacs = zip_axioms map_id0_tac map_comp0_tac map_cong0_tac
  12.196        (map set_map0_tac (set_map0_of_bnf bnf))
  12.197        (fn ctxt => rtac ctxt bd_card_order 1) (fn ctxt => rtac ctxt bd_cinfinite 1)
  12.198 -      set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac;
  12.199 +      set_bd_tacs le_rel_OO_tac rel_OO_Grp_tac pred_set_tac;
  12.200  
  12.201      val bnf_wits = map (fn (I, t) =>
  12.202          fold Term.absdummy (map (nth As) I)
  12.203 @@ -890,8 +931,8 @@
  12.204  
  12.205      val (bnf', lthy') =
  12.206        bnf_def Hardly_Inline (user_policy Dont_Note) true qualify tacs wit_tac (SOME all_deads)
  12.207 -        Binding.empty Binding.empty []
  12.208 -        ((((((b, TA), bnf_map), bnf_sets), bnf_bd'), bnf_wits), SOME bnf_rel) lthy;
  12.209 +        Binding.empty Binding.empty Binding.empty []
  12.210 +        (((((((b, TA), bnf_map), bnf_sets), bnf_bd'), bnf_wits), SOME bnf_rel), SOME bnf_pred) lthy;
  12.211  
  12.212      val unfolds = @{thm id_bnf_apply} ::
  12.213        (#map_unfolds unfold_set @ flat (#set_unfoldss unfold_set) @ #rel_unfolds unfold_set);
    13.1 --- a/src/HOL/Tools/BNF/bnf_comp_tactics.ML	Tue Feb 16 17:01:40 2016 +0100
    13.2 +++ b/src/HOL/Tools/BNF/bnf_comp_tactics.ML	Tue Feb 16 22:28:19 2016 +0100
    13.3 @@ -30,6 +30,7 @@
    13.4  
    13.5    val mk_le_rel_OO_tac: Proof.context -> thm -> thm -> thm list -> tactic
    13.6    val mk_simple_rel_OO_Grp_tac: Proof.context -> thm -> thm -> tactic
    13.7 +  val mk_simple_pred_set_tac: Proof.context -> thm -> thm -> tactic
    13.8    val mk_simple_wit_tac: Proof.context -> thm list -> tactic
    13.9    val mk_simplified_set_tac: Proof.context -> thm -> tactic
   13.10    val bd_ordIso_natLeq_tac: Proof.context -> tactic
   13.11 @@ -229,11 +230,16 @@
   13.12  (* Miscellaneous *)
   13.13  
   13.14  fun mk_le_rel_OO_tac ctxt outer_le_rel_OO outer_rel_mono inner_le_rel_OOs =
   13.15 -  EVERY' (map (rtac ctxt) (@{thm order_trans} :: outer_le_rel_OO :: outer_rel_mono ::
   13.16 -    inner_le_rel_OOs)) 1;
   13.17 +  HEADGOAL (EVERY' (map (rtac ctxt) (@{thm order_trans} :: outer_le_rel_OO :: outer_rel_mono ::
   13.18 +    inner_le_rel_OOs)));
   13.19  
   13.20  fun mk_simple_rel_OO_Grp_tac ctxt rel_OO_Grp in_alt_thm =
   13.21 -  rtac ctxt (trans OF [rel_OO_Grp, in_alt_thm RS @{thm OO_Grp_cong} RS sym]) 1;
   13.22 +  HEADGOAL (rtac ctxt (trans OF [rel_OO_Grp, in_alt_thm RS @{thm OO_Grp_cong} RS sym]));
   13.23 +
   13.24 +fun mk_simple_pred_set_tac ctxt pred_set in_alt_thm =
   13.25 +  HEADGOAL (rtac ctxt (pred_set RS trans)) THEN
   13.26 +  unfold_thms_tac ctxt @{thms Ball_Collect UNIV_def} THEN
   13.27 +  HEADGOAL (rtac ctxt (unfold_thms ctxt @{thms UNIV_def} in_alt_thm RS @{thm Collect_inj} RS sym));
   13.28  
   13.29  fun mk_simple_wit_tac ctxt wit_thms =
   13.30    ALLGOALS (assume_tac ctxt ORELSE' eresolve_tac ctxt (@{thm emptyE} :: wit_thms));
    14.1 --- a/src/HOL/Tools/BNF/bnf_def.ML	Tue Feb 16 17:01:40 2016 +0100
    14.2 +++ b/src/HOL/Tools/BNF/bnf_def.ML	Tue Feb 16 22:28:19 2016 +0100
    14.3 @@ -32,18 +32,21 @@
    14.4    val nwits_of_bnf: bnf -> int
    14.5  
    14.6    val mapN: string
    14.7 +  val predN: string
    14.8    val relN: string
    14.9    val setN: string
   14.10    val mk_setN: int -> string
   14.11    val mk_witN: int -> string
   14.12  
   14.13    val map_of_bnf: bnf -> term
   14.14 +  val pred_of_bnf: bnf -> term
   14.15 +  val rel_of_bnf: bnf -> term
   14.16    val sets_of_bnf: bnf -> term list
   14.17 -  val rel_of_bnf: bnf -> term
   14.18  
   14.19    val mk_T_of_bnf: typ list -> typ list -> bnf -> typ
   14.20    val mk_bd_of_bnf: typ list -> typ list -> bnf -> term
   14.21    val mk_map_of_bnf: typ list -> typ list -> typ list -> bnf -> term
   14.22 +  val mk_pred_of_bnf: typ list -> typ list -> bnf -> term
   14.23    val mk_rel_of_bnf: typ list -> typ list -> typ list -> bnf -> term
   14.24    val mk_sets_of_bnf: typ list list -> typ list list -> bnf -> term list
   14.25    val mk_wits_of_bnf: typ list list -> typ list list -> bnf -> (int list * term) list
   14.26 @@ -60,10 +63,12 @@
   14.27    val in_rel_of_bnf: bnf -> thm
   14.28    val inj_map_of_bnf: bnf -> thm
   14.29    val inj_map_strong_of_bnf: bnf -> thm
   14.30 +  val le_rel_OO_of_bnf: bnf -> thm
   14.31    val map_comp0_of_bnf: bnf -> thm
   14.32    val map_comp_of_bnf: bnf -> thm
   14.33    val map_cong0_of_bnf: bnf -> thm
   14.34    val map_cong_of_bnf: bnf -> thm
   14.35 +  val map_cong_pred_of_bnf: bnf -> thm
   14.36    val map_cong_simp_of_bnf: bnf -> thm
   14.37    val map_def_of_bnf: bnf -> thm
   14.38    val map_id0_of_bnf: bnf -> thm
   14.39 @@ -71,27 +76,36 @@
   14.40    val map_ident0_of_bnf: bnf -> thm
   14.41    val map_ident_of_bnf: bnf -> thm
   14.42    val map_transfer_of_bnf: bnf -> thm
   14.43 -  val le_rel_OO_of_bnf: bnf -> thm
   14.44 -  val rel_def_of_bnf: bnf -> thm
   14.45 +  val pred_cong0_of_bnf: bnf -> thm
   14.46 +  val pred_cong_of_bnf: bnf -> thm
   14.47 +  val pred_cong_simp_of_bnf: bnf -> thm
   14.48 +  val pred_def_of_bnf: bnf -> thm
   14.49 +  val pred_map_of_bnf: bnf -> thm
   14.50 +  val pred_mono_strong0_of_bnf: bnf -> thm
   14.51 +  val pred_mono_strong_of_bnf: bnf -> thm
   14.52 +  val pred_set_of_bnf: bnf -> thm
   14.53 +  val pred_rel_of_bnf: bnf -> thm
   14.54    val rel_Grp_of_bnf: bnf -> thm
   14.55 +  val rel_OO_Grp_of_bnf: bnf -> thm
   14.56    val rel_OO_of_bnf: bnf -> thm
   14.57 -  val rel_OO_Grp_of_bnf: bnf -> thm
   14.58    val rel_cong0_of_bnf: bnf -> thm
   14.59    val rel_cong_of_bnf: bnf -> thm
   14.60    val rel_cong_simp_of_bnf: bnf -> thm
   14.61    val rel_conversep_of_bnf: bnf -> thm
   14.62 +  val rel_def_of_bnf: bnf -> thm
   14.63 +  val rel_eq_of_bnf: bnf -> thm
   14.64 +  val rel_flip_of_bnf: bnf -> thm
   14.65 +  val rel_map_of_bnf: bnf -> thm list
   14.66    val rel_mono_of_bnf: bnf -> thm
   14.67    val rel_mono_strong0_of_bnf: bnf -> thm
   14.68    val rel_mono_strong_of_bnf: bnf -> thm
   14.69 +  val rel_eq_onp_of_bnf: bnf -> thm
   14.70    val rel_refl_of_bnf: bnf -> thm
   14.71    val rel_refl_strong_of_bnf: bnf -> thm
   14.72    val rel_reflp_of_bnf: bnf -> thm
   14.73    val rel_symp_of_bnf: bnf -> thm
   14.74 +  val rel_transfer_of_bnf: bnf -> thm
   14.75    val rel_transp_of_bnf: bnf -> thm
   14.76 -  val rel_map_of_bnf: bnf -> thm list
   14.77 -  val rel_transfer_of_bnf: bnf -> thm
   14.78 -  val rel_eq_of_bnf: bnf -> thm
   14.79 -  val rel_flip_of_bnf: bnf -> thm
   14.80    val set_bd_of_bnf: bnf -> thm list
   14.81    val set_defs_of_bnf: bnf -> thm list
   14.82    val set_map0_of_bnf: bnf -> thm list
   14.83 @@ -114,7 +128,7 @@
   14.84    val minimize_wits: (''a list * 'b) list -> (''a list * 'b) list
   14.85    val wits_of_bnf: bnf -> nonemptiness_witness list
   14.86  
   14.87 -  val zip_axioms: 'a -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list
   14.88 +  val zip_axioms: 'a -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a list -> 'a -> 'a -> 'a -> 'a list
   14.89  
   14.90    datatype inline_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline
   14.91    datatype fact_policy = Dont_Note | Note_Some | Note_All
   14.92 @@ -128,30 +142,34 @@
   14.93    val print_bnfs: Proof.context -> unit
   14.94    val prepare_def: inline_policy -> (Proof.context -> fact_policy) -> bool ->
   14.95      (binding -> binding) -> (Proof.context -> 'a -> typ) -> (Proof.context -> 'b -> term) ->
   14.96 -    typ list option -> binding -> binding -> binding list ->
   14.97 -    (((((binding * 'a) * 'b) * 'b list) * 'b) * 'b list) * 'b option -> Proof.context ->
   14.98 +    typ list option -> binding -> binding -> binding -> binding list ->
   14.99 +    ((((((binding * 'a) * 'b) * 'b list) * 'b) * 'b list) * 'b option) * 'b option ->
  14.100 +    Proof.context ->
  14.101      string * term list * ((Proof.context -> thm list -> tactic) option * term list list) *
  14.102      ((thm list -> thm list list) -> thm list list -> Proof.context -> bnf * local_theory) *
  14.103      local_theory * thm list
  14.104    val define_bnf_consts: inline_policy -> fact_policy -> bool -> typ list option ->
  14.105 -    binding -> binding -> binding list ->
  14.106 -    (((((binding * typ) * term) * term list) * term) * term list) * term option -> local_theory ->
  14.107 +    binding -> binding -> binding -> binding list ->
  14.108 +    ((((((binding * typ) * term) * term list) * term) * term list) * term option) * term option ->
  14.109 +    local_theory ->
  14.110        ((typ list * typ list * typ list * typ) *
  14.111 -       (term * term list * term * (int list * term) list * term) *
  14.112 -       (thm * thm list * thm * thm list * thm) *
  14.113 +       (term * term list * term * (int list * term) list * term * term) *
  14.114 +       (thm * thm list * thm * thm list * thm * thm) *
  14.115         ((typ list -> typ list -> typ list -> term) *
  14.116          (typ list -> typ list -> term -> term) *
  14.117          (typ list -> typ list -> typ -> typ) *
  14.118          (typ list -> typ list -> typ list -> term) *
  14.119 -        (typ list -> typ list -> typ list -> term))) * local_theory
  14.120 +        (typ list -> typ list -> term) *
  14.121 +        (typ list -> typ list -> typ list -> term) *
  14.122 +        (typ list -> typ list -> term))) * local_theory
  14.123  
  14.124    val bnf_def: inline_policy -> (Proof.context -> fact_policy) -> bool -> (binding -> binding) ->
  14.125      (Proof.context -> tactic) list -> (Proof.context -> tactic) -> typ list option -> binding ->
  14.126 -    binding -> binding list ->
  14.127 -    (((((binding * typ) * term) * term list) * term) * term list) * term option -> local_theory ->
  14.128 -    bnf * local_theory
  14.129 -  val bnf_cmd: ((((((binding * string) * string) * string list) * string) * string list)
  14.130 -      * string option) * (Proof.context -> Plugin_Name.filter) ->
  14.131 +    binding -> binding -> binding list ->
  14.132 +    ((((((binding * typ) * term) * term list) * term) * term list) * term option) * term option ->
  14.133 +    local_theory -> bnf * local_theory
  14.134 +  val bnf_cmd: (((((((binding * string) * string) * string list) * string) * string list)
  14.135 +      * string option) * string option) * (Proof.context -> Plugin_Name.filter) ->
  14.136      Proof.context -> Proof.state
  14.137  end;
  14.138  
  14.139 @@ -174,12 +192,13 @@
  14.140    bd_cinfinite: thm,
  14.141    set_bd: thm list,
  14.142    le_rel_OO: thm,
  14.143 -  rel_OO_Grp: thm
  14.144 +  rel_OO_Grp: thm,
  14.145 +  pred_set: thm
  14.146  };
  14.147  
  14.148 -fun mk_axioms' ((((((((id, comp), cong), map), c_o), cinf), set_bd), le_rel_OO), rel) =
  14.149 +fun mk_axioms' (((((((((id, comp), cong), map), c_o), cinf), set_bd), le_rel_OO), rel), pred) =
  14.150    {map_id0 = id, map_comp0 = comp, map_cong0 = cong, set_map0 = map, bd_card_order = c_o,
  14.151 -   bd_cinfinite = cinf, set_bd = set_bd, le_rel_OO = le_rel_OO, rel_OO_Grp = rel};
  14.152 +   bd_cinfinite = cinf, set_bd = set_bd, le_rel_OO = le_rel_OO, rel_OO_Grp = rel, pred_set = pred};
  14.153  
  14.154  fun dest_cons [] = raise List.Empty
  14.155    | dest_cons (x :: xs) = (x, xs);
  14.156 @@ -194,19 +213,15 @@
  14.157    ||>> dest_cons
  14.158    ||>> chop n
  14.159    ||>> dest_cons
  14.160 +  ||>> dest_cons
  14.161    ||> the_single
  14.162    |> mk_axioms';
  14.163  
  14.164 -fun zip_axioms mid mcomp mcong smap bdco bdinf sbd le_rel_OO rel =
  14.165 -  [mid, mcomp, mcong] @ smap @ [bdco, bdinf] @ sbd @ [le_rel_OO, rel];
  14.166 -
  14.167 -fun dest_axioms {map_id0, map_comp0, map_cong0, set_map0, bd_card_order, bd_cinfinite, set_bd,
  14.168 -  le_rel_OO, rel_OO_Grp} =
  14.169 -  zip_axioms map_id0 map_comp0 map_cong0 set_map0 bd_card_order bd_cinfinite set_bd le_rel_OO
  14.170 -    rel_OO_Grp;
  14.171 +fun zip_axioms mid mcomp mcong smap bdco bdinf sbd le_rel_OO rel pred =
  14.172 +  [mid, mcomp, mcong] @ smap @ [bdco, bdinf] @ sbd @ [le_rel_OO, rel, pred];
  14.173  
  14.174  fun map_axioms f {map_id0, map_comp0, map_cong0, set_map0, bd_card_order, bd_cinfinite, set_bd,
  14.175 -  le_rel_OO, rel_OO_Grp} =
  14.176 +  le_rel_OO, rel_OO_Grp,pred_set} =
  14.177    {map_id0 = f map_id0,
  14.178      map_comp0 = f map_comp0,
  14.179      map_cong0 = f map_cong0,
  14.180 @@ -215,20 +230,22 @@
  14.181      bd_cinfinite = f bd_cinfinite,
  14.182      set_bd = map f set_bd,
  14.183      le_rel_OO = f le_rel_OO,
  14.184 -    rel_OO_Grp = f rel_OO_Grp};
  14.185 +    rel_OO_Grp = f rel_OO_Grp,
  14.186 +    pred_set = f pred_set};
  14.187  
  14.188  val morph_axioms = map_axioms o Morphism.thm;
  14.189  
  14.190  type defs = {
  14.191    map_def: thm,
  14.192    set_defs: thm list,
  14.193 -  rel_def: thm
  14.194 +  rel_def: thm,
  14.195 +  pred_def: thm
  14.196  }
  14.197  
  14.198 -fun mk_defs map sets rel = {map_def = map, set_defs = sets, rel_def = rel};
  14.199 +fun mk_defs map sets rel pred = {map_def = map, set_defs = sets, rel_def = rel, pred_def = pred};
  14.200  
  14.201 -fun map_defs f {map_def, set_defs, rel_def} =
  14.202 -  {map_def = f map_def, set_defs = map f set_defs, rel_def = f rel_def};
  14.203 +fun map_defs f {map_def, set_defs, rel_def, pred_def} =
  14.204 +  {map_def = f map_def, set_defs = map f set_defs, rel_def = f rel_def, pred_def = f pred_def};
  14.205  
  14.206  val morph_defs = map_defs o Morphism.thm;
  14.207  
  14.208 @@ -246,6 +263,7 @@
  14.209    map_comp: thm lazy,
  14.210    map_cong: thm lazy,
  14.211    map_cong_simp: thm lazy,
  14.212 +  map_cong_pred: thm lazy,
  14.213    map_id: thm lazy,
  14.214    map_ident0: thm lazy,
  14.215    map_ident: thm lazy,
  14.216 @@ -269,14 +287,24 @@
  14.217    rel_reflp: thm lazy,
  14.218    rel_symp: thm lazy,
  14.219    rel_transp: thm lazy,
  14.220 -  rel_transfer: thm lazy
  14.221 +  rel_transfer: thm lazy,
  14.222 +  rel_eq_onp: thm lazy,
  14.223 +  pred_True: thm lazy,
  14.224 +  pred_map: thm lazy,
  14.225 +  pred_rel: thm lazy,
  14.226 +  pred_mono_strong0: thm lazy,
  14.227 +  pred_mono_strong: thm lazy,
  14.228 +  pred_cong0: thm lazy,
  14.229 +  pred_cong: thm lazy,
  14.230 +  pred_cong_simp: thm lazy
  14.231  };
  14.232  
  14.233  fun mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_bd in_cong in_mono in_rel
  14.234 -    inj_map inj_map_strong map_comp map_cong map_cong_simp map_id map_ident0 map_ident map_transfer
  14.235 -    rel_eq rel_flip set_map rel_cong0 rel_cong rel_cong_simp rel_map rel_mono rel_mono_strong0
  14.236 -    rel_mono_strong set_transfer rel_Grp rel_conversep rel_OO rel_refl rel_refl_strong rel_reflp
  14.237 -    rel_symp rel_transp rel_transfer = {
  14.238 +    inj_map inj_map_strong map_comp map_cong map_cong_simp map_cong_pred map_id map_ident0 map_ident
  14.239 +    map_transfer rel_eq rel_flip set_map rel_cong0 rel_cong rel_cong_simp rel_map rel_mono
  14.240 +    rel_mono_strong0 rel_mono_strong set_transfer rel_Grp rel_conversep rel_OO rel_refl
  14.241 +    rel_refl_strong rel_reflp rel_symp rel_transp rel_transfer rel_eq_onp pred_True pred_map pred_rel
  14.242 +    pred_mono_strong0 pred_mono_strong pred_cong0 pred_cong pred_cong_simp = {
  14.243    bd_Card_order = bd_Card_order,
  14.244    bd_Cinfinite = bd_Cinfinite,
  14.245    bd_Cnotzero = bd_Cnotzero,
  14.246 @@ -290,6 +318,7 @@
  14.247    map_comp = map_comp,
  14.248    map_cong = map_cong,
  14.249    map_cong_simp = map_cong_simp,
  14.250 +  map_cong_pred = map_cong_pred,
  14.251    map_id = map_id,
  14.252    map_ident0 = map_ident0,
  14.253    map_ident = map_ident,
  14.254 @@ -313,7 +342,16 @@
  14.255    rel_reflp = rel_reflp,
  14.256    rel_symp = rel_symp,
  14.257    rel_transp = rel_transp,
  14.258 -  set_transfer = set_transfer};
  14.259 +  set_transfer = set_transfer,
  14.260 +  rel_eq_onp = rel_eq_onp,
  14.261 +  pred_True = pred_True,
  14.262 +  pred_map = pred_map,
  14.263 +  pred_rel = pred_rel,
  14.264 +  pred_mono_strong0 = pred_mono_strong0,
  14.265 +  pred_mono_strong = pred_mono_strong,
  14.266 +  pred_cong0 = pred_cong0,
  14.267 +  pred_cong = pred_cong,
  14.268 +  pred_cong_simp = pred_cong_simp};
  14.269  
  14.270  fun map_facts f {
  14.271    bd_Card_order,
  14.272 @@ -329,6 +367,7 @@
  14.273    map_comp,
  14.274    map_cong,
  14.275    map_cong_simp,
  14.276 +  map_cong_pred,
  14.277    map_id,
  14.278    map_ident0,
  14.279    map_ident,
  14.280 @@ -352,7 +391,16 @@
  14.281    rel_reflp,
  14.282    rel_symp,
  14.283    rel_transp,
  14.284 -  set_transfer} =
  14.285 +  set_transfer,
  14.286 +  rel_eq_onp,
  14.287 +  pred_True,
  14.288 +  pred_map,
  14.289 +  pred_rel,
  14.290 +  pred_mono_strong0,
  14.291 +  pred_mono_strong,
  14.292 +  pred_cong0,
  14.293 +  pred_cong,
  14.294 +  pred_cong_simp} =
  14.295    {bd_Card_order = f bd_Card_order,
  14.296      bd_Cinfinite = f bd_Cinfinite,
  14.297      bd_Cnotzero = f bd_Cnotzero,
  14.298 @@ -366,6 +414,7 @@
  14.299      map_comp = Lazy.map f map_comp,
  14.300      map_cong = Lazy.map f map_cong,
  14.301      map_cong_simp = Lazy.map f map_cong_simp,
  14.302 +    map_cong_pred = Lazy.map f map_cong_pred,
  14.303      map_id = Lazy.map f map_id,
  14.304      map_ident0 = Lazy.map f map_ident0,
  14.305      map_ident = Lazy.map f map_ident,
  14.306 @@ -389,7 +438,16 @@
  14.307      rel_reflp = Lazy.map f rel_reflp,
  14.308      rel_symp = Lazy.map f rel_symp,
  14.309      rel_transp = Lazy.map f rel_transp,
  14.310 -    set_transfer = Lazy.map (map f) set_transfer};
  14.311 +    set_transfer = Lazy.map (map f) set_transfer,
  14.312 +    rel_eq_onp = Lazy.map f rel_eq_onp,
  14.313 +    pred_True = Lazy.map f pred_True,
  14.314 +    pred_map = Lazy.map f pred_map,
  14.315 +    pred_rel = Lazy.map f pred_rel,
  14.316 +    pred_mono_strong0 = Lazy.map f pred_mono_strong0,
  14.317 +    pred_mono_strong = Lazy.map f pred_mono_strong,
  14.318 +    pred_cong0 = Lazy.map f pred_cong0,
  14.319 +    pred_cong = Lazy.map f pred_cong,
  14.320 +    pred_cong_simp = Lazy.map f pred_cong_simp};
  14.321  
  14.322  val morph_facts = map_facts o Morphism.thm;
  14.323  
  14.324 @@ -419,7 +477,8 @@
  14.325    facts: facts,
  14.326    nwits: int,
  14.327    wits: nonemptiness_witness list,
  14.328 -  rel: term
  14.329 +  rel: term,
  14.330 +  pred: term
  14.331  };
  14.332  
  14.333  (* getters *)
  14.334 @@ -482,13 +541,20 @@
  14.335      Term.subst_atomic_types
  14.336        ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts) @ (#lives' bnf_rep ~~ Us)) (#rel bnf_rep)
  14.337    end;
  14.338 +val pred_of_bnf = #pred o rep_bnf;
  14.339 +fun mk_pred_of_bnf Ds Ts bnf =
  14.340 +  let val bnf_rep = rep_bnf bnf;
  14.341 +  in
  14.342 +    Term.subst_atomic_types
  14.343 +      ((#deads bnf_rep ~~ Ds) @ (#lives bnf_rep ~~ Ts)) (#pred bnf_rep)
  14.344 +  end;
  14.345  
  14.346  (*thms*)
  14.347 -val bd_card_order_of_bnf = #bd_card_order o #axioms o rep_bnf;
  14.348 -val bd_cinfinite_of_bnf = #bd_cinfinite o #axioms o rep_bnf;
  14.349  val bd_Card_order_of_bnf = #bd_Card_order o #facts o rep_bnf;
  14.350  val bd_Cinfinite_of_bnf = #bd_Cinfinite o #facts o rep_bnf;
  14.351  val bd_Cnotzero_of_bnf = #bd_Cnotzero o #facts o rep_bnf;
  14.352 +val bd_card_order_of_bnf = #bd_card_order o #axioms o rep_bnf;
  14.353 +val bd_cinfinite_of_bnf = #bd_cinfinite o #axioms o rep_bnf;
  14.354  val collect_set_map_of_bnf = Lazy.force o #collect_set_map o #facts o rep_bnf;
  14.355  val in_bd_of_bnf = Lazy.force o #in_bd o #facts o rep_bnf;
  14.356  val in_cong_of_bnf = Lazy.force o #in_cong o #facts o rep_bnf;
  14.357 @@ -496,29 +562,40 @@
  14.358  val in_rel_of_bnf = Lazy.force o #in_rel o #facts o rep_bnf;
  14.359  val inj_map_of_bnf = Lazy.force o #inj_map o #facts o rep_bnf;
  14.360  val inj_map_strong_of_bnf = Lazy.force o #inj_map_strong o #facts o rep_bnf;
  14.361 +val le_rel_OO_of_bnf = #le_rel_OO o #axioms o rep_bnf;
  14.362 +val map_comp0_of_bnf = #map_comp0 o #axioms o rep_bnf;
  14.363 +val map_comp_of_bnf = Lazy.force o #map_comp o #facts o rep_bnf;
  14.364 +val map_cong0_of_bnf = #map_cong0 o #axioms o rep_bnf;
  14.365 +val map_cong_of_bnf = Lazy.force o #map_cong o #facts o rep_bnf;
  14.366 +val map_cong_pred_of_bnf = Lazy.force o #map_cong_pred o #facts o rep_bnf;
  14.367 +val map_cong_simp_of_bnf = Lazy.force o #map_cong_simp o #facts o rep_bnf;
  14.368  val map_def_of_bnf = #map_def o #defs o rep_bnf;
  14.369  val map_id0_of_bnf = #map_id0 o #axioms o rep_bnf;
  14.370  val map_id_of_bnf = Lazy.force o #map_id o #facts o rep_bnf;
  14.371  val map_ident0_of_bnf = Lazy.force o #map_ident0 o #facts o rep_bnf;
  14.372  val map_ident_of_bnf = Lazy.force o #map_ident o #facts o rep_bnf;
  14.373 -val map_comp0_of_bnf = #map_comp0 o #axioms o rep_bnf;
  14.374 -val map_comp_of_bnf = Lazy.force o #map_comp o #facts o rep_bnf;
  14.375 -val map_cong0_of_bnf = #map_cong0 o #axioms o rep_bnf;
  14.376 -val map_cong_of_bnf = Lazy.force o #map_cong o #facts o rep_bnf;
  14.377 -val map_cong_simp_of_bnf = Lazy.force o #map_cong_simp o #facts o rep_bnf;
  14.378  val map_transfer_of_bnf = Lazy.force o #map_transfer o #facts o rep_bnf;
  14.379 -val le_rel_OO_of_bnf = #le_rel_OO o #axioms o rep_bnf;
  14.380 +val rel_eq_onp_of_bnf = Lazy.force o #rel_eq_onp o #facts o rep_bnf;
  14.381 +val pred_rel_of_bnf = Lazy.force o #pred_rel o #facts o rep_bnf;
  14.382 +val pred_map_of_bnf = Lazy.force o #pred_map o #facts o rep_bnf;
  14.383 +val pred_mono_strong0_of_bnf = Lazy.force o #pred_mono_strong0 o #facts o rep_bnf;
  14.384 +val pred_mono_strong_of_bnf = Lazy.force o #pred_mono_strong o #facts o rep_bnf;
  14.385 +val pred_cong0_of_bnf = Lazy.force o #pred_cong0 o #facts o rep_bnf;
  14.386 +val pred_cong_of_bnf = Lazy.force o #pred_cong o #facts o rep_bnf;
  14.387 +val pred_cong_simp_of_bnf = Lazy.force o #pred_cong_simp o #facts o rep_bnf;
  14.388 +val pred_def_of_bnf = #pred_def o #defs o rep_bnf;
  14.389 +val pred_set_of_bnf = #pred_set o #axioms o rep_bnf;
  14.390 +val rel_Grp_of_bnf = Lazy.force o #rel_Grp o #facts o rep_bnf;
  14.391 +val rel_OO_Grp_of_bnf = #rel_OO_Grp o #axioms o rep_bnf;
  14.392 +val rel_OO_of_bnf = Lazy.force o #rel_OO o #facts o rep_bnf;
  14.393 +val rel_cong0_of_bnf = Lazy.force o #rel_cong0 o #facts o rep_bnf;
  14.394 +val rel_cong_of_bnf = Lazy.force o #rel_cong o #facts o rep_bnf;
  14.395 +val rel_cong_simp_of_bnf = Lazy.force o #rel_cong_simp o #facts o rep_bnf;
  14.396 +val rel_conversep_of_bnf = Lazy.force o #rel_conversep o #facts o rep_bnf;
  14.397  val rel_def_of_bnf = #rel_def o #defs o rep_bnf;
  14.398  val rel_eq_of_bnf = Lazy.force o #rel_eq o #facts o rep_bnf;
  14.399  val rel_flip_of_bnf = Lazy.force o #rel_flip o #facts o rep_bnf;
  14.400 -val set_bd_of_bnf = #set_bd o #axioms o rep_bnf;
  14.401 -val set_defs_of_bnf = #set_defs o #defs o rep_bnf;
  14.402 -val set_map0_of_bnf = #set_map0 o #axioms o rep_bnf;
  14.403 -val set_map_of_bnf = map Lazy.force o #set_map o #facts o rep_bnf;
  14.404 -val set_transfer_of_bnf = Lazy.force o #set_transfer o #facts o rep_bnf;
  14.405 -val rel_cong0_of_bnf = Lazy.force o #rel_cong0 o #facts o rep_bnf;
  14.406 -val rel_cong_of_bnf = Lazy.force o #rel_cong o #facts o rep_bnf;
  14.407 -val rel_cong_simp_of_bnf = Lazy.force o #rel_cong_simp o #facts o rep_bnf;
  14.408 +val rel_map_of_bnf = Lazy.force o #rel_map o #facts o rep_bnf;
  14.409  val rel_mono_of_bnf = Lazy.force o #rel_mono o #facts o rep_bnf;
  14.410  val rel_mono_strong0_of_bnf = Lazy.force o #rel_mono_strong0 o #facts o rep_bnf;
  14.411  val rel_mono_strong_of_bnf = Lazy.force o #rel_mono_strong o #facts o rep_bnf;
  14.412 @@ -526,33 +603,33 @@
  14.413  val rel_refl_strong_of_bnf = Lazy.force o #rel_refl_strong o #facts o rep_bnf;
  14.414  val rel_reflp_of_bnf = Lazy.force o #rel_reflp o #facts o rep_bnf;
  14.415  val rel_symp_of_bnf = Lazy.force o #rel_symp o #facts o rep_bnf;
  14.416 +val rel_transfer_of_bnf = Lazy.force o #rel_transfer o #facts o rep_bnf;
  14.417  val rel_transp_of_bnf = Lazy.force o #rel_transp o #facts o rep_bnf;
  14.418 -val rel_map_of_bnf = Lazy.force o #rel_map o #facts o rep_bnf;
  14.419 -val rel_transfer_of_bnf = Lazy.force o #rel_transfer o #facts o rep_bnf;
  14.420 -val rel_Grp_of_bnf = Lazy.force o #rel_Grp o #facts o rep_bnf;
  14.421 -val rel_conversep_of_bnf = Lazy.force o #rel_conversep o #facts o rep_bnf;
  14.422 -val rel_OO_of_bnf = Lazy.force o #rel_OO o #facts o rep_bnf;
  14.423 -val rel_OO_Grp_of_bnf = #rel_OO_Grp o #axioms o rep_bnf;
  14.424 +val set_bd_of_bnf = #set_bd o #axioms o rep_bnf;
  14.425 +val set_defs_of_bnf = #set_defs o #defs o rep_bnf;
  14.426 +val set_map0_of_bnf = #set_map0 o #axioms o rep_bnf;
  14.427 +val set_map_of_bnf = map Lazy.force o #set_map o #facts o rep_bnf;
  14.428 +val set_transfer_of_bnf = Lazy.force o #set_transfer o #facts o rep_bnf;
  14.429  val wit_thms_of_bnf = maps #prop o wits_of_bnf;
  14.430  val wit_thmss_of_bnf = map #prop o wits_of_bnf;
  14.431  
  14.432 -fun mk_bnf name T live lives lives' dead deads map sets bd axioms defs facts wits rel =
  14.433 +fun mk_bnf name T live lives lives' dead deads map sets bd axioms defs facts wits rel pred =
  14.434    BNF {name = name, T = T,
  14.435         live = live, lives = lives, lives' = lives', dead = dead, deads = deads,
  14.436         map = map, sets = sets, bd = bd,
  14.437         axioms = axioms, defs = defs, facts = facts,
  14.438 -       nwits = length wits, wits = wits, rel = rel};
  14.439 +       nwits = length wits, wits = wits, rel = rel, pred = pred};
  14.440  
  14.441 -fun map_bnf f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16
  14.442 +fun map_bnf f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13 f14 f15 f16 f17
  14.443    (BNF {name = name, T = T, live = live, lives = lives, lives' = lives',
  14.444    dead = dead, deads = deads, map = map, sets = sets, bd = bd,
  14.445    axioms = axioms, defs = defs, facts = facts,
  14.446 -  nwits = nwits, wits = wits, rel = rel}) =
  14.447 +  nwits = nwits, wits = wits, rel = rel, pred = pred}) =
  14.448    BNF {name = f1 name, T = f2 T,
  14.449         live = f3 live, lives = f4 lives, lives' = f5 lives', dead = f6 dead, deads = f7 deads,
  14.450         map = f8 map, sets = f9 sets, bd = f10 bd,
  14.451         axioms = f11 axioms, defs = f12 defs, facts = f13 facts,
  14.452 -       nwits = f14 nwits, wits = f15 wits, rel = f16 rel};
  14.453 +       nwits = f14 nwits, wits = f15 wits, rel = f16 rel, pred = f17 pred};
  14.454  
  14.455  fun morph_bnf phi =
  14.456    let
  14.457 @@ -560,10 +637,10 @@
  14.458      val tphi = Morphism.term phi;
  14.459    in
  14.460      map_bnf (Morphism.binding phi) Tphi I (map Tphi) (map Tphi) I (map Tphi) tphi (map tphi) tphi
  14.461 -      (morph_axioms phi) (morph_defs phi) (morph_facts phi) I (map (morph_witness phi)) tphi
  14.462 +      (morph_axioms phi) (morph_defs phi) (morph_facts phi) I (map (morph_witness phi)) tphi tphi
  14.463    end;
  14.464  
  14.465 -fun morph_bnf_defs phi = map_bnf I I I I I I I I I I I (morph_defs phi) I I I I;
  14.466 +fun morph_bnf_defs phi = map_bnf I I I I I I I I I I I (morph_defs phi) I I I I I;
  14.467  
  14.468  val transfer_bnf = morph_bnf o Morphism.transfer_morphism;
  14.469  
  14.470 @@ -600,6 +677,15 @@
  14.471    in Envir.subst_term (tyenv, Vartab.empty) rel end
  14.472    handle Type.TYPE_MATCH => error "Bad relator";
  14.473  
  14.474 +fun normalize_pred ctxt instTs instA pred =
  14.475 +  let
  14.476 +    val thy = Proof_Context.theory_of ctxt;
  14.477 +    val tyenv =
  14.478 +      Sign.typ_match thy (fastype_of pred, Library.foldr (op -->) (instTs, mk_pred1T instA))
  14.479 +        Vartab.empty;
  14.480 +  in Envir.subst_term (tyenv, Vartab.empty) pred end
  14.481 +  handle Type.TYPE_MATCH => error "Bad predicator";
  14.482 +
  14.483  fun normalize_wit insts CA As wit =
  14.484    let
  14.485      fun strip_param (Ts, T as Type (@{type_name fun}, [T1, T2])) =
  14.486 @@ -677,49 +763,60 @@
  14.487  val witN = "wit";
  14.488  fun mk_witN i = witN ^ nonzero_string_of_int i;
  14.489  val relN = "rel";
  14.490 +val predN = "pred";
  14.491  
  14.492 -val bd_card_orderN = "bd_card_order";
  14.493 -val bd_cinfiniteN = "bd_cinfinite";
  14.494  val bd_Card_orderN = "bd_Card_order";
  14.495  val bd_CinfiniteN = "bd_Cinfinite";
  14.496  val bd_CnotzeroN = "bd_Cnotzero";
  14.497 +val bd_card_orderN = "bd_card_order";
  14.498 +val bd_cinfiniteN = "bd_cinfinite";
  14.499  val collect_set_mapN = "collect_set_map";
  14.500  val in_bdN = "in_bd";
  14.501  val in_monoN = "in_mono";
  14.502  val in_relN = "in_rel";
  14.503  val inj_mapN = "inj_map";
  14.504  val inj_map_strongN = "inj_map_strong";
  14.505 -val map_id0N = "map_id0";
  14.506 -val map_idN = "map_id";
  14.507 -val map_identN = "map_ident";
  14.508  val map_comp0N = "map_comp0";
  14.509  val map_compN = "map_comp";
  14.510  val map_cong0N = "map_cong0";
  14.511  val map_congN = "map_cong";
  14.512  val map_cong_simpN = "map_cong_simp";
  14.513 +val map_cong_predN = "map_cong_pred";
  14.514 +val map_id0N = "map_id0";
  14.515 +val map_idN = "map_id";
  14.516 +val map_identN = "map_ident";
  14.517  val map_transferN = "map_transfer";
  14.518 +val pred_mono_strong0N = "pred_mono_strong0";
  14.519 +val pred_mono_strongN = "pred_mono_strong";
  14.520 +val pred_TrueN = "pred_True";
  14.521 +val pred_mapN = "pred_map";
  14.522 +val pred_relN = "pred_rel";
  14.523 +val pred_setN = "pred_set";
  14.524 +val pred_congN = "pred_cong";
  14.525 +val pred_cong_simpN = "pred_cong_simp";
  14.526 +val rel_GrpN = "rel_Grp";
  14.527 +val rel_comppN = "rel_compp";
  14.528 +val rel_compp_GrpN = "rel_compp_Grp";
  14.529 +val rel_congN = "rel_cong";
  14.530 +val rel_cong_simpN = "rel_cong_simp";
  14.531 +val rel_conversepN = "rel_conversep";
  14.532  val rel_eqN = "rel_eq";
  14.533 +val rel_eq_onpN = "rel_eq_onp";
  14.534  val rel_flipN = "rel_flip";
  14.535 -val set_map0N = "set_map0";
  14.536 -val set_mapN = "set_map";
  14.537 -val set_bdN = "set_bd";
  14.538 -val set_transferN = "set_transfer";
  14.539 -val rel_GrpN = "rel_Grp";
  14.540 -val rel_conversepN = "rel_conversep";
  14.541  val rel_mapN = "rel_map";
  14.542  val rel_monoN = "rel_mono";
  14.543  val rel_mono_strong0N = "rel_mono_strong0";
  14.544  val rel_mono_strongN = "rel_mono_strong";
  14.545 -val rel_congN = "rel_cong";
  14.546 -val rel_cong_simpN = "rel_cong_simp";
  14.547  val rel_reflN = "rel_refl";
  14.548  val rel_refl_strongN = "rel_refl_strong";
  14.549  val rel_reflpN = "rel_reflp";
  14.550  val rel_sympN = "rel_symp";
  14.551 +val rel_transferN = "rel_transfer";
  14.552  val rel_transpN = "rel_transp";
  14.553 -val rel_transferN = "rel_transfer";
  14.554 -val rel_comppN = "rel_compp";
  14.555 -val rel_compp_GrpN = "rel_compp_Grp";
  14.556 +val set_bdN = "set_bd";
  14.557 +val set_map0N = "set_map0";
  14.558 +val set_mapN = "set_map";
  14.559 +val set_transferN = "set_transfer";
  14.560  
  14.561  datatype inline_policy = Dont_Inline | Hardly_Inline | Smart_Inline | Do_Inline;
  14.562  
  14.563 @@ -755,6 +852,7 @@
  14.564             (in_monoN, [Lazy.force (#in_mono facts)]),
  14.565             (map_comp0N, [#map_comp0 axioms]),
  14.566             (rel_mono_strong0N, [Lazy.force (#rel_mono_strong0 facts)]),
  14.567 +           (pred_mono_strong0N, [Lazy.force (#pred_mono_strong0 facts)]),
  14.568             (set_map0N, #set_map0 axioms),
  14.569             (set_bdN, #set_bd axioms)] @
  14.570            (witNs ~~ wit_thmss_of_bnf bnf)
  14.571 @@ -775,14 +873,23 @@
  14.572             (map_cong0N, [#map_cong0 axioms], []),
  14.573             (map_congN, [Lazy.force (#map_cong facts)], fundefcong_attrs),
  14.574             (map_cong_simpN, [Lazy.force (#map_cong_simp facts)], []),
  14.575 +           (map_cong_predN, [Lazy.force (#map_cong_pred facts)], []),
  14.576             (map_idN, [Lazy.force (#map_id facts)], []),
  14.577             (map_id0N, [#map_id0 axioms], []),
  14.578             (map_transferN, [Lazy.force (#map_transfer facts)], []),
  14.579             (map_identN, [Lazy.force (#map_ident facts)], []),
  14.580 +           (pred_mono_strongN, [Lazy.force (#pred_mono_strong facts)], []),
  14.581 +           (pred_congN, [Lazy.force (#pred_cong facts)], fundefcong_attrs),
  14.582 +           (pred_cong_simpN, [Lazy.force (#pred_cong_simp facts)], []),
  14.583 +           (pred_mapN, [Lazy.force (#pred_map facts)], []),
  14.584 +           (pred_relN, [Lazy.force (#pred_rel facts)], []),
  14.585 +           (pred_TrueN, [Lazy.force (#pred_True facts)], []),
  14.586 +           (pred_setN, [#pred_set axioms], []),
  14.587             (rel_comppN, [Lazy.force (#rel_OO facts)], []),
  14.588             (rel_compp_GrpN, no_refl [#rel_OO_Grp axioms], []),
  14.589             (rel_conversepN, [Lazy.force (#rel_conversep facts)], []),
  14.590             (rel_eqN, [Lazy.force (#rel_eq facts)], []),
  14.591 +           (rel_eq_onpN, [Lazy.force (#rel_eq_onp facts)], []),
  14.592             (rel_flipN, [Lazy.force (#rel_flip facts)], []),
  14.593             (rel_GrpN, [Lazy.force (#rel_Grp facts)], []),
  14.594             (rel_mapN, Lazy.force (#rel_map facts), []),
  14.595 @@ -831,8 +938,9 @@
  14.596  
  14.597  (* Define new BNFs *)
  14.598  
  14.599 -fun define_bnf_consts const_policy fact_policy internal Ds_opt map_b rel_b set_bs
  14.600 -  ((((((bnf_b, T_rhs), map_rhs), set_rhss), bd_rhs), wit_rhss), rel_rhs_opt) no_defs_lthy =
  14.601 +fun define_bnf_consts const_policy fact_policy internal Ds_opt map_b rel_b pred_b set_bs
  14.602 +    (((((((bnf_b, T_rhs), map_rhs), set_rhss), bd_rhs), wit_rhss), rel_rhs_opt), pred_rhs_opt)
  14.603 +    no_defs_lthy =
  14.604    let
  14.605      val live = length set_rhss;
  14.606  
  14.607 @@ -947,7 +1055,7 @@
  14.608  
  14.609      (*Grp (in (Collect (split R1) .. Collect (split Rn))) (map fst .. fst)^--1 OO
  14.610        Grp (in (Collect (split R1) .. Collect (split Rn))) (map snd .. snd)*)
  14.611 -    val OO_Grp =
  14.612 +    val rel_spec =
  14.613        let
  14.614          val map1 = Term.list_comb (mk_bnf_map Ds RTs As, map fst_const RTs);
  14.615          val map2 = Term.list_comb (mk_bnf_map Ds RTs Bs, map snd_const RTs);
  14.616 @@ -957,12 +1065,34 @@
  14.617          |> fold_rev Term.absfree Rs'
  14.618        end;
  14.619  
  14.620 -    val rel_rhs = the_default OO_Grp rel_rhs_opt;
  14.621 +    val rel_rhs = the_default rel_spec rel_rhs_opt;
  14.622  
  14.623      val rel_bind_def =
  14.624        (fn () => def_qualify (if Binding.is_empty rel_b then mk_prefix_binding relN else rel_b),
  14.625           rel_rhs);
  14.626  
  14.627 +    val pred_spec =
  14.628 +      if live = 0 then Term.absdummy (mk_bnf_T Ds As Calpha) @{term True} else
  14.629 +      let
  14.630 +        val sets = map (mk_bnf_t Ds As) bnf_sets;
  14.631 +        val argTs = map mk_pred1T As;
  14.632 +        val T = mk_bnf_T Ds As Calpha;
  14.633 +        val ((Ps, Ps'), x) = lthy
  14.634 +          |> mk_Frees' "P" argTs
  14.635 +          ||>> yield_singleton (mk_Frees "x") T
  14.636 +          |> fst;
  14.637 +        val conjs = map2 (fn set => fn P => mk_Ball (set $ x) P) sets Ps;
  14.638 +      in
  14.639 +        fold_rev Term.absfree Ps'
  14.640 +          (Term.absfree (dest_Free x) (Library.foldr1 HOLogic.mk_conj conjs))
  14.641 +      end;
  14.642 +
  14.643 +    val pred_rhs = the_default pred_spec pred_rhs_opt;
  14.644 +
  14.645 +    val pred_bind_def =
  14.646 +      (fn () => def_qualify (if Binding.is_empty pred_b then mk_prefix_binding predN else pred_b),
  14.647 +         pred_rhs);
  14.648 +
  14.649      val wit_rhss =
  14.650        if null wit_rhss then
  14.651          [fold_rev Term.absdummy As (Term.list_comb (mk_bnf_map Ds As As,
  14.652 @@ -976,10 +1106,12 @@
  14.653            else map (fn i => fn () => def_qualify (mk_prefix_binding (mk_witN i))) (1 upto nwits);
  14.654        in bs ~~ wit_rhss end;
  14.655  
  14.656 -    val (((bnf_rel_term, raw_rel_def), (bnf_wit_terms, raw_wit_defs)), (lthy, lthy_old)) =
  14.657 +    val ((((bnf_rel_term, raw_rel_def), (bnf_pred_term, raw_pred_def)),
  14.658 +        (bnf_wit_terms, raw_wit_defs)), (lthy, lthy_old)) =
  14.659        lthy
  14.660        |> Local_Theory.open_target |> snd
  14.661        |> maybe_define (is_some rel_rhs_opt) rel_bind_def
  14.662 +      ||>> maybe_define (is_some pred_rhs_opt) pred_bind_def
  14.663        ||>> apfst split_list o fold_map (maybe_define (not (null wit_rhss))) wit_binds_defs
  14.664        ||> `Local_Theory.close_target;
  14.665  
  14.666 @@ -990,22 +1122,30 @@
  14.667        normalize_rel lthy (map2 mk_pred2T As' Bs') (mk_bnf_T Ds As' Calpha) (mk_bnf_T Ds Bs' Calpha)
  14.668          bnf_rel;
  14.669  
  14.670 +    val bnf_pred_def = Morphism.thm phi raw_pred_def;
  14.671 +    val bnf_pred = Morphism.term phi bnf_pred_term;
  14.672 +    fun mk_bnf_pred Ds As' =
  14.673 +      normalize_pred lthy (map mk_pred1T As') (mk_bnf_T Ds As' Calpha) bnf_pred;
  14.674 +
  14.675      val bnf_wit_defs = map (Morphism.thm phi) raw_wit_defs;
  14.676      val bnf_wits =
  14.677        map (normalize_wit Calpha_params Calpha alphas o Morphism.term phi) bnf_wit_terms;
  14.678  
  14.679 -    fun mk_OO_Grp Ds' As' Bs' =
  14.680 -      Term.subst_atomic_types ((Ds ~~ Ds') @ (As ~~ As') @ (Bs ~~ Bs')) OO_Grp;
  14.681 +    fun mk_rel_spec Ds' As' Bs' =
  14.682 +      Term.subst_atomic_types ((Ds ~~ Ds') @ (As ~~ As') @ (Bs ~~ Bs')) rel_spec;
  14.683 +
  14.684 +    fun mk_pred_spec Ds' As' =
  14.685 +      Term.subst_atomic_types ((Ds ~~ Ds') @ (As ~~ As')) pred_spec;
  14.686    in
  14.687      (((alphas, betas, deads, Calpha),
  14.688 -     (bnf_map, bnf_sets, bnf_bd, bnf_wits, bnf_rel),
  14.689 -     (bnf_map_def, bnf_set_defs, bnf_bd_def, bnf_wit_defs, bnf_rel_def),
  14.690 -     (mk_bnf_map, mk_bnf_t, mk_bnf_T, mk_bnf_rel, mk_OO_Grp)), lthy)
  14.691 +     (bnf_map, bnf_sets, bnf_bd, bnf_wits, bnf_rel, bnf_pred),
  14.692 +     (bnf_map_def, bnf_set_defs, bnf_bd_def, bnf_wit_defs, bnf_rel_def, bnf_pred_def),
  14.693 +     (mk_bnf_map, mk_bnf_t, mk_bnf_T, mk_bnf_rel, mk_bnf_pred, mk_rel_spec, mk_pred_spec)), lthy)
  14.694    end;
  14.695  
  14.696  fun prepare_def const_policy mk_fact_policy internal qualify prep_typ prep_term Ds_opt map_b rel_b
  14.697 -  set_bs ((((((raw_bnf_b, raw_bnf_T), raw_map), raw_sets), raw_bd), raw_wits), raw_rel_opt)
  14.698 -  no_defs_lthy =
  14.699 +  pred_b set_bs (((((((raw_bnf_b, raw_bnf_T), raw_map), raw_sets), raw_bd), raw_wits), raw_rel_opt),
  14.700 +    raw_pred_opt) no_defs_lthy =
  14.701    let
  14.702      val fact_policy = mk_fact_policy no_defs_lthy;
  14.703      val bnf_b = qualify raw_bnf_b;
  14.704 @@ -1017,6 +1157,7 @@
  14.705      val bd_rhs = prep_term no_defs_lthy raw_bd;
  14.706      val wit_rhss = map (prep_term no_defs_lthy) raw_wits;
  14.707      val rel_rhs_opt = Option.map (prep_term no_defs_lthy) raw_rel_opt;
  14.708 +    val pred_rhs_opt = Option.map (prep_term no_defs_lthy) raw_pred_opt;
  14.709  
  14.710      fun err T =
  14.711        error ("Trying to register the type " ^ quote (Syntax.string_of_typ no_defs_lthy T) ^
  14.712 @@ -1031,11 +1172,12 @@
  14.713        else (bnf_b, Local_Theory.full_name no_defs_lthy bnf_b);
  14.714  
  14.715      val (((alphas, betas, deads, Calpha),
  14.716 -     (bnf_map, bnf_sets, bnf_bd, bnf_wits, bnf_rel),
  14.717 -     (bnf_map_def, bnf_set_defs, bnf_bd_def, bnf_wit_defs, bnf_rel_def),
  14.718 -     (mk_bnf_map_Ds, mk_bnf_t_Ds, mk_bnf_T_Ds, _, mk_OO_Grp)), lthy) =
  14.719 -       define_bnf_consts const_policy fact_policy internal Ds_opt map_b rel_b set_bs
  14.720 -         ((((((bnf_b, T_rhs), map_rhs), set_rhss), bd_rhs), wit_rhss), rel_rhs_opt) no_defs_lthy;
  14.721 +     (bnf_map, bnf_sets, bnf_bd, bnf_wits, bnf_rel, bnf_pred),
  14.722 +     (bnf_map_def, bnf_set_defs, bnf_bd_def, bnf_wit_defs, bnf_rel_def, bnf_pred_def),
  14.723 +     (mk_bnf_map_Ds, mk_bnf_t_Ds, mk_bnf_T_Ds, _, _, mk_rel_spec, mk_pred_spec)), lthy) =
  14.724 +       define_bnf_consts const_policy fact_policy internal Ds_opt map_b rel_b pred_b set_bs
  14.725 +         (((((((bnf_b, T_rhs), map_rhs), set_rhss), bd_rhs), wit_rhss), rel_rhs_opt), pred_rhs_opt)
  14.726 +         no_defs_lthy;
  14.727  
  14.728      val dead = length deads;
  14.729  
  14.730 @@ -1057,6 +1199,8 @@
  14.731      val mk_bnf_t = mk_bnf_t_Ds Ds;
  14.732      val mk_bnf_T = mk_bnf_T_Ds Ds;
  14.733  
  14.734 +    val pred1PTs = map mk_pred1T As';
  14.735 +    val pred1QTs = map mk_pred1T Bs';
  14.736      val pred2RTs = map2 mk_pred2T As' Bs';
  14.737      val pred2RTsAsCs = map2 mk_pred2T As' Cs;
  14.738      val pred2RTsBsCs = map2 mk_pred2T Bs' Cs;
  14.739 @@ -1083,11 +1227,11 @@
  14.740      val bnf_sets_Bs = map (mk_bnf_t Bs') bnf_sets;
  14.741      val bnf_bd_As = mk_bnf_t As' bnf_bd;
  14.742      fun mk_bnf_rel RTs CA CB = normalize_rel lthy RTs CA CB bnf_rel;
  14.743 +    fun mk_bnf_pred PTs CA = normalize_pred lthy PTs CA bnf_pred;
  14.744  
  14.745 -    val pre_names_lthy = lthy;
  14.746 -    val (((((((((((((((((((((((fs, fs'), gs), hs), is), x), x'), y), y'), zs), zs'), ys), As),
  14.747 -      As_copy), bs), Rs), Rs_copy), Ss), S_AsCs), S_CsBs), S_BsEs),
  14.748 -      transfer_domRs), transfer_ranRs), names_lthy) = pre_names_lthy
  14.749 +    val ((((((((((((((((((((((((((fs, fs'), gs), hs), is), x), x'), y), y'), zs), zs'), ys), As),
  14.750 +      As_copy), bs), (Ps, Ps')), Ps_copy), Qs), Rs), Rs_copy), Ss), S_AsCs), S_CsBs), S_BsEs),
  14.751 +      transfer_domRs), transfer_ranRs), _) = lthy
  14.752        |> mk_Frees "f" (map2 (curry op -->) As' Bs')
  14.753        ||>> mk_Frees "f" (map2 (curry op -->) As' Bs')
  14.754        ||>> mk_Frees "g" (map2 (curry op -->) Bs' Cs)
  14.755 @@ -1103,6 +1247,9 @@
  14.756        ||>> mk_Frees "A" (map HOLogic.mk_setT As')
  14.757        ||>> mk_Frees "A" (map HOLogic.mk_setT As')
  14.758        ||>> mk_Frees "b" As'
  14.759 +      ||>> mk_Frees' "P" pred1PTs
  14.760 +      ||>> mk_Frees "P" pred1PTs
  14.761 +      ||>> mk_Frees "Q" pred1QTs
  14.762        ||>> mk_Frees "R" pred2RTs
  14.763        ||>> mk_Frees "R" pred2RTs
  14.764        ||>> mk_Frees "S" pred2RTsBsCs
  14.765 @@ -1117,6 +1264,8 @@
  14.766      val y_copy = retype_const_or_free CB' x';
  14.767  
  14.768      val rel = mk_bnf_rel pred2RTs CA' CB';
  14.769 +    val pred = mk_bnf_pred pred1PTs CA';
  14.770 +    val pred' = mk_bnf_pred pred1QTs CB';
  14.771      val relCsEs = mk_bnf_rel pred2RTsCsEs CC' CE';
  14.772      val relAsAs = mk_bnf_rel self_pred2RTs CA' CA';
  14.773      val bnf_wit_As = map (apsnd (mk_bnf_t As')) bnf_wits;
  14.774 @@ -1181,10 +1330,13 @@
  14.775        fold_rev Logic.all (Rs @ Ss) (HOLogic.mk_Trueprop (mk_leq rel_OO_rhs rel_OO_lhs));
  14.776  
  14.777      val rel_OO_Grp_goal = fold_rev Logic.all Rs (mk_Trueprop_eq (Term.list_comb (rel, Rs),
  14.778 -      Term.list_comb (mk_OO_Grp Ds As' Bs', Rs)));
  14.779 +      Term.list_comb (mk_rel_spec Ds As' Bs', Rs)));
  14.780 +
  14.781 +    val pred_set_goal = fold_rev Logic.all Ps (mk_Trueprop_eq (Term.list_comb (pred, Ps),
  14.782 +      Term.list_comb (mk_pred_spec Ds As', Ps)));
  14.783  
  14.784      val goals = zip_axioms map_id0_goal map_comp0_goal map_cong0_goal set_map0s_goal
  14.785 -      card_order_bd_goal cinfinite_bd_goal set_bds_goal le_rel_OO_goal rel_OO_Grp_goal;
  14.786 +      card_order_bd_goal cinfinite_bd_goal set_bds_goal le_rel_OO_goal rel_OO_Grp_goal pred_set_goal;
  14.787  
  14.788      val mk_wit_goals = mk_wit_goals bs zs bnf_sets_As;
  14.789      fun triv_wit_tac ctxt = mk_trivial_wit_tac ctxt bnf_wit_defs;
  14.790 @@ -1210,7 +1362,7 @@
  14.791              (*collect {set1 ... setm} o map f1 ... fm = collect {f1` o set1 ... fm` o setm}*)
  14.792              val goal = fold_rev Logic.all hs (mk_Trueprop_eq (collect_map, image_collect));
  14.793            in
  14.794 -            Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} => 
  14.795 +            Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} =>
  14.796                mk_collect_set_map_tac ctxt (#set_map0 axioms))
  14.797              |> Thm.close_derivation
  14.798            end;
  14.799 @@ -1447,9 +1599,7 @@
  14.800  
  14.801          val rel_mono_strong0 = Lazy.lazy mk_rel_mono_strong0;
  14.802  
  14.803 -        fun mk_rel_mono_strong () = Object_Logic.rulify lthy (Lazy.force rel_mono_strong0)
  14.804 -
  14.805 -        val rel_mono_strong = Lazy.lazy mk_rel_mono_strong;
  14.806 +        val rel_mono_strong = Lazy.map (Object_Logic.rulify lthy) rel_mono_strong0;
  14.807  
  14.808          fun mk_rel_cong_prem mk_implies x x' z z' set set' R R_copy =
  14.809            Logic.all z (Logic.all z'
  14.810 @@ -1475,6 +1625,99 @@
  14.811          val rel_cong = Lazy.lazy (mk_rel_cong Logic.mk_implies);
  14.812          val rel_cong_simp = Lazy.lazy (mk_rel_cong (fn (a, b) => @{term simp_implies} $ a $ b));
  14.813  
  14.814 +        fun mk_pred_prems f = map2 (HOLogic.mk_Trueprop oo f) Ps Ps_copy;
  14.815 +        fun mk_pred_concl f = HOLogic.mk_Trueprop
  14.816 +          (f (Term.list_comb (pred, Ps), Term.list_comb (pred, Ps_copy)));
  14.817 +
  14.818 +        fun mk_pred_cong0 () =
  14.819 +          let
  14.820 +            val cong_prems = mk_pred_prems (curry HOLogic.mk_eq);
  14.821 +            val cong_concl = mk_pred_concl HOLogic.mk_eq;
  14.822 +          in
  14.823 +            Goal.prove_sorry lthy [] []
  14.824 +              (fold_rev Logic.all (Ps @ Ps_copy) (Logic.list_implies (cong_prems, cong_concl)))
  14.825 +              (fn {context = ctxt, prems = _} => (TRY o hyp_subst_tac ctxt THEN' rtac ctxt refl) 1)
  14.826 +            |> Thm.close_derivation
  14.827 +          end;
  14.828 +
  14.829 +        val pred_cong0 = Lazy.lazy mk_pred_cong0;
  14.830 +
  14.831 +        fun mk_rel_eq_onp () =
  14.832 +          let
  14.833 +            val lhs = Term.list_comb (relAsAs, map mk_eq_onp Ps);
  14.834 +            val rhs = mk_eq_onp (Term.list_comb (pred, Ps));
  14.835 +          in
  14.836 +            Goal.prove_sorry lthy (map fst Ps') [] (mk_Trueprop_eq (lhs, rhs))
  14.837 +              (fn {context = ctxt, prems = _} =>
  14.838 +                mk_rel_eq_onp_tac ctxt (#pred_set axioms) (#map_id0 axioms) (Lazy.force rel_Grp))
  14.839 +            |> Thm.close_derivation
  14.840 +          end;
  14.841 +
  14.842 +        val rel_eq_onp = Lazy.lazy mk_rel_eq_onp;
  14.843 +        val pred_rel = Lazy.map (fn thm => thm RS sym RS @{thm eq_onp_eqD}) rel_eq_onp;
  14.844 +
  14.845 +        fun mk_pred_mono_strong0 () =
  14.846 +          let
  14.847 +            fun mk_prem setA P Q a =
  14.848 +              HOLogic.mk_Trueprop
  14.849 +                (mk_Ball (setA $ x) (Term.absfree (dest_Free a) (HOLogic.mk_imp (P $ a, Q $ a))));
  14.850 +            val prems = HOLogic.mk_Trueprop (Term.list_comb (pred, Ps) $ x) ::
  14.851 +              @{map 4} mk_prem bnf_sets_As Ps Ps_copy zs;
  14.852 +            val concl = HOLogic.mk_Trueprop (Term.list_comb (pred, Ps_copy) $ x);
  14.853 +          in
  14.854 +            Goal.prove_sorry lthy [] []
  14.855 +              (fold_rev Logic.all (x :: Ps @ Ps_copy) (Logic.list_implies (prems, concl)))
  14.856 +              (fn {context = ctxt, prems = _} =>
  14.857 +                mk_pred_mono_strong0_tac ctxt (Lazy.force pred_rel) (Lazy.force rel_mono_strong0))
  14.858 +            |> Thm.close_derivation
  14.859 +          end;
  14.860 +
  14.861 +        val pred_mono_strong0 = Lazy.lazy mk_pred_mono_strong0;
  14.862 +
  14.863 +        val pred_mono_strong = Lazy.map (Object_Logic.rulify lthy) pred_mono_strong0;
  14.864 +
  14.865 +        fun mk_pred_cong_prem mk_implies x z set P P_copy =
  14.866 +          Logic.all z
  14.867 +            (mk_implies (mk_Trueprop_mem (z, set $ x), mk_Trueprop_eq (P $ z, P_copy $ z)));
  14.868 +
  14.869 +        fun mk_pred_cong mk_implies () =
  14.870 +          let
  14.871 +            val prem0 = mk_Trueprop_eq (x, x_copy);
  14.872 +            val prems = @{map 4} (mk_pred_cong_prem mk_implies x_copy) zs bnf_sets_As Ps Ps_copy;
  14.873 +            val eq = mk_Trueprop_eq (Term.list_comb (pred, Ps) $ x,
  14.874 +              Term.list_comb (pred, Ps_copy) $ x_copy);
  14.875 +          in
  14.876 +            fold (Variable.add_free_names lthy) (eq :: prem0 :: prems) []
  14.877 +            |> (fn vars => Goal.prove_sorry lthy vars (prem0 :: prems) eq
  14.878 +              (fn {context = ctxt, prems} =>
  14.879 +                mk_rel_cong_tac ctxt (chop 1 prems) (Lazy.force pred_mono_strong)))
  14.880 +            |> Thm.close_derivation
  14.881 +          end;
  14.882 +
  14.883 +        val pred_cong = Lazy.lazy (mk_pred_cong Logic.mk_implies);
  14.884 +        val pred_cong_simp = Lazy.lazy (mk_pred_cong (fn (a, b) => @{term simp_implies} $ a $ b));
  14.885 +
  14.886 +        fun mk_map_cong_pred () =
  14.887 +          let
  14.888 +            val prem0 = mk_Trueprop_eq (x, x_copy);
  14.889 +            fun mk_eq f g z = Term.absfree (dest_Free z) (HOLogic.mk_eq (f $ z, g $ z));
  14.890 +            val prem = HOLogic.mk_Trueprop
  14.891 +              (Term.list_comb (pred, @{map 3} mk_eq fs fs_copy zs) $ x_copy);
  14.892 +            val eq = mk_Trueprop_eq (Term.list_comb (bnf_map_AsBs, fs) $ x,
  14.893 +              Term.list_comb (bnf_map_AsBs, fs_copy) $ x_copy);
  14.894 +            val goal = fold_rev Logic.all (x :: x_copy :: fs @ fs_copy)
  14.895 +              (Logic.list_implies ([prem0, prem], eq));
  14.896 +          in
  14.897 +            Goal.prove_sorry lthy [] [] goal (fn {context = ctxt, prems = _} =>
  14.898 +              unfold_thms_tac ctxt [#pred_set axioms] THEN
  14.899 +              HEADGOAL (EVERY' [REPEAT_DETERM o etac ctxt conjE,
  14.900 +                etac ctxt (Lazy.force map_cong) THEN_ALL_NEW
  14.901 +                  (etac ctxt bspec THEN' assume_tac ctxt)]))
  14.902 +            |> Thm.close_derivation
  14.903 +          end;
  14.904 +
  14.905 +        val map_cong_pred = Lazy.lazy mk_map_cong_pred;
  14.906 +
  14.907          fun mk_rel_map () =
  14.908            let
  14.909              fun mk_goal lhs rhs =
  14.910 @@ -1525,7 +1768,7 @@
  14.911              Goal.prove_sorry lthy vars [] (Logic.list_implies (prems, goal))
  14.912                (fn {context = ctxt, prems = _} =>
  14.913                  unfold_thms_tac ctxt [prop_conv_thm] THEN
  14.914 -                HEADGOAL (rtac ctxt (Lazy.force thm RS sym RS @{thm ord_eq_le_trans}) 
  14.915 +                HEADGOAL (rtac ctxt (Lazy.force thm RS sym RS @{thm ord_eq_le_trans})
  14.916                    THEN' rtac ctxt (Lazy.force rel_mono) THEN_ALL_NEW assume_tac ctxt))
  14.917              |> Thm.close_derivation
  14.918            end;
  14.919 @@ -1534,6 +1777,41 @@
  14.920          val rel_symp = Lazy.lazy (mk_rel_preserves mk_symp @{thm symp_conversep} rel_conversep);
  14.921          val rel_transp = Lazy.lazy (mk_rel_preserves mk_transp @{thm transp_relcompp} rel_OO);
  14.922  
  14.923 +        fun mk_pred_True () =
  14.924 +          let
  14.925 +            val lhs = Term.list_comb (pred, map (fn T => absdummy T @{term True}) As');
  14.926 +            val rhs = absdummy CA' @{term True};
  14.927 +            val goal = mk_Trueprop_eq (lhs, rhs);
  14.928 +          in
  14.929 +            Goal.prove_sorry lthy [] [] goal
  14.930 +              (fn {context = ctxt, prems = _} =>
  14.931 +                HEADGOAL (EVERY' (map (rtac ctxt) [ext, Lazy.force pred_rel RS trans,
  14.932 +                  Lazy.force rel_cong0 RS fun_cong RS fun_cong RS trans OF
  14.933 +                    replicate live @{thm eq_onp_True},
  14.934 +                  Lazy.force rel_eq RS fun_cong RS fun_cong RS trans, @{thm eqTrueI[OF refl]}])))
  14.935 +            |> Thm.close_derivation
  14.936 +          end;
  14.937 +
  14.938 +        val pred_True = Lazy.lazy mk_pred_True;
  14.939 +
  14.940 +        fun mk_pred_map () =
  14.941 +          let
  14.942 +            val lhs = Term.list_comb (pred', Qs) $ (Term.list_comb (bnf_map_AsBs, fs) $ x);
  14.943 +            val rhs = Term.list_comb (pred, @{map 2} (curry HOLogic.mk_comp) Qs fs) $ x;
  14.944 +            val goal = mk_Trueprop_eq (lhs, rhs);
  14.945 +            val vars = Variable.add_free_names lthy goal [];
  14.946 +            val pred_set = #pred_set axioms RS fun_cong RS sym;
  14.947 +          in
  14.948 +            Goal.prove_sorry lthy vars [] goal
  14.949 +              (fn {context = ctxt, prems = _} =>
  14.950 +                HEADGOAL (rtac ctxt (pred_set RSN (2, pred_set RSN (2, box_equals)))) THEN
  14.951 +                unfold_thms_tac ctxt (@{thm Ball_image_comp} :: map Lazy.force set_map) THEN
  14.952 +                HEADGOAL (rtac ctxt refl))
  14.953 +            |> Thm.close_derivation
  14.954 +          end;
  14.955 +
  14.956 +        val pred_map = Lazy.lazy mk_pred_map;
  14.957 +
  14.958          fun mk_map_transfer () =
  14.959            let
  14.960              val rels = map2 mk_rel_fun transfer_domRs transfer_ranRs;
  14.961 @@ -1621,27 +1899,32 @@
  14.962  
  14.963          val inj_map_strong = Lazy.lazy mk_inj_map_strong;
  14.964  
  14.965 -        val defs = mk_defs bnf_map_def bnf_set_defs bnf_rel_def;
  14.966 +        val defs = mk_defs bnf_map_def bnf_set_defs bnf_rel_def bnf_pred_def;
  14.967  
  14.968          val facts = mk_facts bd_Card_order bd_Cinfinite bd_Cnotzero collect_set_map in_bd in_cong
  14.969 -          in_mono in_rel inj_map inj_map_strong map_comp map_cong map_cong_simp map_id map_ident0
  14.970 -          map_ident map_transfer rel_eq rel_flip set_map rel_cong0 rel_cong rel_cong_simp rel_map
  14.971 -          rel_mono rel_mono_strong0 rel_mono_strong set_transfer rel_Grp rel_conversep rel_OO
  14.972 -          rel_refl rel_refl_strong rel_reflp rel_symp rel_transp rel_transfer;
  14.973 +          in_mono in_rel inj_map inj_map_strong map_comp map_cong map_cong_simp map_cong_pred map_id
  14.974 +          map_ident0 map_ident map_transfer rel_eq rel_flip set_map rel_cong0 rel_cong rel_cong_simp
  14.975 +          rel_map rel_mono rel_mono_strong0 rel_mono_strong set_transfer rel_Grp rel_conversep
  14.976 +          rel_OO rel_refl rel_refl_strong rel_reflp rel_symp rel_transp rel_transfer rel_eq_onp
  14.977 +          pred_True pred_map pred_rel pred_mono_strong0 pred_mono_strong pred_cong0 pred_cong
  14.978 +          pred_cong_simp;
  14.979  
  14.980          val wits = map2 mk_witness bnf_wits wit_thms;
  14.981  
  14.982          val bnf_rel =
  14.983            Term.subst_atomic_types ((Ds ~~ deads) @ (As' ~~ alphas) @ (Bs' ~~ betas)) rel;
  14.984  
  14.985 +        val bnf_pred = Term.subst_atomic_types ((Ds ~~ deads) @ (As' ~~ alphas)) pred;
  14.986 +
  14.987          val bnf = mk_bnf bnf_b Calpha live alphas betas dead deads bnf_map bnf_sets bnf_bd axioms
  14.988 -          defs facts wits bnf_rel;
  14.989 +          defs facts wits bnf_rel bnf_pred;
  14.990        in
  14.991          note_bnf_thms fact_policy qualify bnf_b bnf lthy
  14.992        end;
  14.993  
  14.994      val one_step_defs =
  14.995 -      no_reflexive (bnf_map_def :: bnf_bd_def :: bnf_set_defs @ bnf_wit_defs @ [bnf_rel_def]);
  14.996 +      no_reflexive (bnf_map_def :: bnf_bd_def :: bnf_set_defs @ bnf_wit_defs @
  14.997 +        [bnf_rel_def, bnf_pred_def]);
  14.998    in
  14.999      (key, goals, wit_goalss, after_qed, lthy, one_step_defs)
 14.1000    end;
 14.1001 @@ -1661,7 +1944,8 @@
 14.1002  fun register_bnf plugins key bnf =
 14.1003    register_bnf_raw key bnf #> interpret_bnf plugins bnf;
 14.1004  
 14.1005 -fun bnf_def const_policy fact_policy internal qualify tacs wit_tac Ds map_b rel_b set_bs raw_csts =
 14.1006 +fun bnf_def const_policy fact_policy internal qualify tacs wit_tac Ds map_b rel_b pred_b set_bs
 14.1007 +    raw_csts =
 14.1008    (fn (_, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, one_step_defs) =>
 14.1009    let
 14.1010      fun mk_wits_tac ctxt set_maps =
 14.1011 @@ -1682,8 +1966,8 @@
 14.1012        goals (map (fn tac => fn {context = ctxt, prems = _} =>
 14.1013          unfold_thms_tac ctxt one_step_defs THEN tac ctxt) tacs)
 14.1014      |> (fn thms => after_qed mk_wit_thms (map single thms) lthy)
 14.1015 -  end) o prepare_def const_policy fact_policy internal qualify (K I) (K I) Ds map_b rel_b set_bs
 14.1016 -    raw_csts;
 14.1017 +  end) o prepare_def const_policy fact_policy internal qualify (K I) (K I) Ds map_b rel_b pred_b
 14.1018 +    set_bs raw_csts;
 14.1019  
 14.1020  fun bnf_cmd (raw_csts, raw_plugins) =
 14.1021    (fn (key, goals, (triv_tac_opt, wit_goalss), after_qed, lthy, defs) =>
 14.1022 @@ -1702,13 +1986,14 @@
 14.1023          NONE => (fn _ => [], map (map (rpair [])) wit_goalss)
 14.1024        | SOME tac => (mk_triv_wit_thms tac, []));
 14.1025    in
 14.1026 -    Proof.unfolding ([[(defs, [])]])
 14.1027 -      (lthy
 14.1028 -       |> Proof.theorem NONE (uncurry (register_bnf plugins key) oo after_qed mk_wit_thms)
 14.1029 -         (map (single o rpair []) goals @ nontriv_wit_goals)
 14.1030 -       |> Proof.refine_singleton (Method.primitive_text (K I)))
 14.1031 +    lthy
 14.1032 +    |> Proof.theorem NONE (uncurry (register_bnf plugins key) oo after_qed mk_wit_thms)
 14.1033 +      (map (single o rpair []) goals @ nontriv_wit_goals)
 14.1034 +    |> Proof.unfolding ([[(@{thm OO_Grp_alt} :: @{thm mem_Collect_eq} :: defs, [])]])
 14.1035 +    |> Proof.refine_singleton (Method.Basic (fn ctxt =>
 14.1036 +      Method.SIMPLE_METHOD (TRYALL (rtac ctxt refl))))
 14.1037    end) o prepare_def Do_Inline (user_policy Note_Some) false I Syntax.read_typ Syntax.read_term
 14.1038 -    NONE Binding.empty Binding.empty [] raw_csts;
 14.1039 +    NONE Binding.empty Binding.empty Binding.empty [] raw_csts;
 14.1040  
 14.1041  fun print_bnfs ctxt =
 14.1042    let
 14.1043 @@ -1752,6 +2037,7 @@
 14.1044           Scan.repeat1 (Scan.unless (Parse.reserved "rel" ||
 14.1045             Parse.reserved "plugins") Parse.term)) [] --
 14.1046         Scan.option ((Parse.reserved "rel" -- @{keyword ":"}) |-- Parse.term) --
 14.1047 +       Scan.option ((Parse.reserved "pred" -- @{keyword ":"}) |-- Parse.term) --
 14.1048         Scan.optional Plugin_Name.parse_filter (K Plugin_Name.default_filter)
 14.1049         >> bnf_cmd);
 14.1050  
    15.1 --- a/src/HOL/Tools/BNF/bnf_def_tactics.ML	Tue Feb 16 17:01:40 2016 +0100
    15.2 +++ b/src/HOL/Tools/BNF/bnf_def_tactics.ML	Tue Feb 16 22:28:19 2016 +0100
    15.3 @@ -2,7 +2,8 @@
    15.4      Author:     Dmitriy Traytel, TU Muenchen
    15.5      Author:     Jasmin Blanchette, TU Muenchen
    15.6      Author:     Martin Desharnais, TU Muenchen
    15.7 -    Copyright   2012, 2013, 2014
    15.8 +    Author:     Ondrej Kuncar, TU Muenchen
    15.9 +    Copyright   2012, 2013, 2014, 2015
   15.10  
   15.11  Tactics for definition of bounded natural functors.
   15.12  *)
   15.13 @@ -30,6 +31,8 @@
   15.14    val mk_rel_mono_strong0_tac: Proof.context -> thm -> thm list -> tactic
   15.15    val mk_rel_cong_tac: Proof.context -> thm list * thm list -> thm -> tactic
   15.16    val mk_rel_transfer_tac: Proof.context -> thm -> thm list -> thm -> tactic
   15.17 +  val mk_rel_eq_onp_tac: Proof.context -> thm -> thm -> thm -> tactic
   15.18 +  val mk_pred_mono_strong0_tac: Proof.context -> thm -> thm -> tactic
   15.19  
   15.20    val mk_map_transfer_tac: Proof.context -> thm -> thm -> thm list -> thm -> thm -> tactic
   15.21  
   15.22 @@ -363,7 +366,7 @@
   15.23  fun mk_rel_cong_tac ctxt (eqs, prems) mono =
   15.24    let
   15.25      fun mk_tac thm = etac ctxt thm THEN_ALL_NEW assume_tac ctxt;
   15.26 -    fun mk_tacs iffD = etac ctxt mono :: 
   15.27 +    fun mk_tacs iffD = etac ctxt mono ::
   15.28        map (fn thm => (unfold_thms ctxt @{thms simp_implies_def} thm RS iffD)
   15.29          |> Drule.rotate_prems ~1 |> mk_tac) prems;
   15.30    in
   15.31 @@ -371,4 +374,18 @@
   15.32      HEADGOAL (EVERY' (rtac ctxt iffI :: mk_tacs iffD1 @ mk_tacs iffD2))
   15.33    end;
   15.34  
   15.35 +fun subst_conv ctxt thm =
   15.36 +  Conv.arg_conv (Conv.arg_conv
   15.37 +   (Conv.top_sweep_conv (K (Conv.rewr_conv (safe_mk_meta_eq thm))) ctxt));
   15.38 +
   15.39 +fun mk_rel_eq_onp_tac ctxt pred_def map_id0 rel_Grp =
   15.40 +  HEADGOAL (EVERY'
   15.41 +   [SELECT_GOAL (unfold_thms_tac ctxt (pred_def :: @{thms UNIV_def eq_onp_Grp Ball_Collect})),
   15.42 +   CONVERSION (subst_conv ctxt (map_id0 RS sym)),
   15.43 +   rtac ctxt (unfold_thms ctxt @{thms UNIV_def} rel_Grp)]);
   15.44 +
   15.45 +fun mk_pred_mono_strong0_tac ctxt pred_rel rel_mono_strong0 =
   15.46 +   unfold_thms_tac ctxt [pred_rel] THEN
   15.47 +   HEADGOAL (etac ctxt rel_mono_strong0 THEN_ALL_NEW etac ctxt @{thm eq_onp_mono0});
   15.48 +
   15.49  end;
    16.1 --- a/src/HOL/Tools/BNF/bnf_fp_def_sugar.ML	Tue Feb 16 17:01:40 2016 +0100
    16.2 +++ b/src/HOL/Tools/BNF/bnf_fp_def_sugar.ML	Tue Feb 16 22:28:19 2016 +0100
    16.3 @@ -147,26 +147,27 @@
    16.4      thm list -> Proof.context -> gfp_sugar_thms
    16.5  
    16.6    val co_datatypes: BNF_Util.fp_kind -> (mixfix list -> binding list -> binding list ->
    16.7 -      binding list list -> binding list -> (string * sort) list -> typ list * typ list list ->
    16.8 -      BNF_Def.bnf list -> BNF_Comp.absT_info list -> local_theory ->
    16.9 +      binding list -> binding list list -> binding list -> (string * sort) list ->
   16.10 +      typ list * typ list list -> BNF_Def.bnf list -> BNF_Comp.absT_info list -> local_theory ->
   16.11        BNF_FP_Util.fp_result * local_theory) ->
   16.12      Ctr_Sugar.ctr_options
   16.13      * ((((((binding option * (typ * sort)) list * binding) * mixfix)
   16.14 -         * ((binding, binding * typ) Ctr_Sugar.ctr_spec * mixfix) list) * (binding * binding))
   16.15 +         * ((binding, binding * typ) Ctr_Sugar.ctr_spec * mixfix) list) *
   16.16 +         (binding * binding * binding))
   16.17         * term list) list ->
   16.18      local_theory -> local_theory
   16.19    val co_datatype_cmd: BNF_Util.fp_kind ->
   16.20 -    (mixfix list -> binding list -> binding list -> binding list list -> binding list ->
   16.21 -     (string * sort) list -> typ list * typ list list -> BNF_Def.bnf list ->
   16.22 +    (mixfix list -> binding list -> binding list -> binding list -> binding list list ->
   16.23 +      binding list -> (string * sort) list -> typ list * typ list list -> BNF_Def.bnf list ->
   16.24       BNF_Comp.absT_info list -> local_theory -> BNF_FP_Util.fp_result * Proof.context) ->
   16.25      ((Proof.context -> Plugin_Name.filter) * bool)
   16.26      * ((((((binding option * (string * string option)) list * binding) * mixfix)
   16.27           * ((binding, binding * string) Ctr_Sugar.ctr_spec * mixfix) list)
   16.28 -        * (binding * binding)) * string list) list ->
   16.29 +        * (binding * binding * binding)) * string list) list ->
   16.30      Proof.context -> local_theory
   16.31    val parse_co_datatype_cmd: BNF_Util.fp_kind -> (mixfix list -> binding list -> binding list ->
   16.32 -      binding list list -> binding list -> (string * sort) list -> typ list * typ list list ->
   16.33 -      BNF_Def.bnf list -> BNF_Comp.absT_info list -> local_theory ->
   16.34 +      binding list -> binding list list -> binding list -> (string * sort) list ->
   16.35 +      typ list * typ list list -> BNF_Def.bnf list -> BNF_Comp.absT_info list -> local_theory ->
   16.36        BNF_FP_Util.fp_result * local_theory) ->
   16.37      (local_theory -> local_theory) parser
   16.38  end;
   16.39 @@ -533,8 +534,9 @@
   16.40  fun type_binding_of_spec (((((_, b), _), _), _), _) = b;
   16.41  fun mixfix_of_spec ((((_, mx), _), _), _) = mx;
   16.42  fun mixfixed_ctr_specs_of_spec (((_, mx_ctr_specs), _), _) = mx_ctr_specs;
   16.43 -fun map_binding_of_spec ((_, (b, _)), _) = b;
   16.44 -fun rel_binding_of_spec ((_, (_, b)), _) = b;
   16.45 +fun map_binding_of_spec ((_, (b, _, _)), _) = b;
   16.46 +fun rel_binding_of_spec ((_, (_, b, _)), _) = b;
   16.47 +fun pred_binding_of_spec ((_, (_, _, b)), _) = b;
   16.48  fun sel_default_eqs_of_spec (_, ts) = ts;
   16.49  
   16.50  fun add_nesting_bnf_names Us =
   16.51 @@ -1964,6 +1966,7 @@
   16.52      val fp_common_name = mk_common_name fp_b_names;
   16.53      val map_bs = map map_binding_of_spec specs;
   16.54      val rel_bs = map rel_binding_of_spec specs;
   16.55 +    val pred_bs = map pred_binding_of_spec specs;
   16.56  
   16.57      fun prepare_type_arg (_, (ty, c)) =
   16.58        let val TFree (s, _) = prepare_typ no_defs_lthy ty in
   16.59 @@ -2094,8 +2097,8 @@
   16.60               xtor_co_rec_thms, xtor_rel_co_induct, dtor_set_inducts,
   16.61               xtor_co_rec_transfers, xtor_co_rec_o_maps, ...},
   16.62             lthy)) =
   16.63 -      fp_bnf (construct_fp mixfixes map_bs rel_bs set_bss) fp_bs (map dest_TFree unsorted_As)
   16.64 -        (map dest_TFree killed_As) fp_eqs no_defs_lthy
   16.65 +      fp_bnf (construct_fp mixfixes map_bs rel_bs pred_bs set_bss) fp_bs
   16.66 +        (map dest_TFree unsorted_As) (map dest_TFree killed_As) fp_eqs no_defs_lthy
   16.67        handle BAD_DEAD (X, X_backdrop) =>
   16.68          (case X_backdrop of
   16.69            Type (bad_tc, _) =>
   16.70 @@ -2147,8 +2150,8 @@
   16.71  
   16.72      val live = live_of_bnf any_fp_bnf;
   16.73      val _ =
   16.74 -      if live = 0 andalso exists (not o Binding.is_empty) (map_bs @ rel_bs) then
   16.75 -        warning "Map function and relator names ignored"
   16.76 +      if live = 0 andalso exists (not o Binding.is_empty) (map_bs @ rel_bs @ pred_bs) then
   16.77 +        warning "Map function, relator, and predicator names ignored"
   16.78        else
   16.79          ();
   16.80  
   16.81 @@ -2663,7 +2666,7 @@
   16.82      val timer = time (timer ("Constructors, discriminators, selectors, etc., for the new " ^
   16.83        co_prefix fp ^ "datatype"));
   16.84    in
   16.85 -    timer; lthy''
   16.86 +    lthy''
   16.87    end;
   16.88  
   16.89  fun co_datatypes x = define_co_datatypes (K I) (K I) (K I) (K I) x;
   16.90 @@ -2681,7 +2684,7 @@
   16.91  
   16.92  val parse_spec =
   16.93    parse_type_args_named_constrained -- Parse.binding -- Parse.opt_mixfix --
   16.94 -  (@{keyword "="} |-- parse_ctr_specs) -- parse_map_rel_bindings -- parse_sel_default_eqs;
   16.95 +  (@{keyword "="} |-- parse_ctr_specs) -- parse_map_rel_pred_bindings -- parse_sel_default_eqs;
   16.96  
   16.97  val parse_co_datatype = parse_ctr_options -- Parse.and_list1 parse_spec;
   16.98  
    17.1 --- a/src/HOL/Tools/BNF/bnf_gfp.ML	Tue Feb 16 17:01:40 2016 +0100
    17.2 +++ b/src/HOL/Tools/BNF/bnf_gfp.ML	Tue Feb 16 22:28:19 2016 +0100
    17.3 @@ -9,9 +9,10 @@
    17.4  
    17.5  signature BNF_GFP =
    17.6  sig
    17.7 -  val construct_gfp: mixfix list -> binding list -> binding list -> binding list list ->
    17.8 -    binding list -> (string * sort) list -> typ list * typ list list -> BNF_Def.bnf list ->
    17.9 -    BNF_Comp.absT_info list -> local_theory -> BNF_FP_Util.fp_result * local_theory
   17.10 +  val construct_gfp: mixfix list -> binding list -> binding list -> binding list ->
   17.11 +    binding list list -> binding list -> (string * sort) list -> typ list * typ list list ->
   17.12 +    BNF_Def.bnf list -> BNF_Comp.absT_info list -> local_theory ->
   17.13 +    BNF_FP_Util.fp_result * local_theory
   17.14  end;
   17.15  
   17.16  structure BNF_GFP : BNF_GFP =
   17.17 @@ -55,7 +56,7 @@
   17.18       ((i, I), nth (nth lwitss i) nwit) :: maps (tree_to_coind_wits lwitss) subtrees;
   17.19  
   17.20  (*all BNFs have the same lives*)
   17.21 -fun construct_gfp mixfixes map_bs rel_bs set_bss0 bs resBs (resDs, Dss) bnfs _ lthy =
   17.22 +fun construct_gfp mixfixes map_bs rel_bs pred_bs set_bss0 bs resBs (resDs, Dss) bnfs _ lthy =
   17.23    let
   17.24      val time = time lthy;
   17.25      val timer = time (Timer.startRealTimer ());
   17.26 @@ -1860,26 +1861,30 @@
   17.27          val setss = map (fn i => map2 (mk_set Ts i) ls passiveAs) ks;
   17.28  
   17.29          val (Jbnf_consts, lthy) =
   17.30 -          @{fold_map 7} (fn b => fn map_b => fn rel_b => fn set_bs => fn mapx => fn sets => fn T =>
   17.31 -              fn lthy =>
   17.32 +          @{fold_map 8} (fn b => fn map_b => fn rel_b => fn pred_b => fn set_bs => fn mapx =>
   17.33 +              fn sets => fn T => fn lthy =>
   17.34              define_bnf_consts Hardly_Inline (user_policy Note_Some lthy) false (SOME deads)
   17.35 -              map_b rel_b set_bs
   17.36 -              ((((((b, T), fold_rev Term.absfree fs' mapx), sets), sbd),
   17.37 -                [Const (@{const_name undefined}, T)]), NONE) lthy)
   17.38 -          bs map_bs rel_bs set_bss fs_maps setss Ts lthy;
   17.39 +              map_b rel_b pred_b set_bs
   17.40 +              (((((((b, T), fold_rev Term.absfree fs' mapx), sets), sbd),
   17.41 +                [Const (@{const_name undefined}, T)]), NONE), NONE) lthy)
   17.42 +          bs map_bs rel_bs pred_bs set_bss fs_maps setss Ts lthy;
   17.43  
   17.44          val (_, Jconsts, Jconst_defs, mk_Jconsts) = @{split_list 4} Jbnf_consts;
   17.45 -        val (_, Jsetss, Jbds_Ds, _, _) = @{split_list 5} Jconsts;
   17.46 -        val (Jmap_defs, Jset_defss, Jbd_defs, _, Jrel_defs) = @{split_list 5} Jconst_defs;
   17.47 -        val (mk_Jmaps_Ds, mk_Jt_Ds, _, mk_Jrels_Ds, _) = @{split_list 5} mk_Jconsts;
   17.48 +        val (_, Jsetss, Jbds_Ds, _, _, _) = @{split_list 6} Jconsts;
   17.49 +        val (Jmap_defs, Jset_defss, Jbd_defs, _, Jrel_defs, Jpred_defs) =
   17.50 +          @{split_list 6} Jconst_defs;
   17.51 +        val (mk_Jmaps_Ds, mk_Jt_Ds, _, mk_Jrels_Ds, mk_Jpreds_Ds, _, _) =
   17.52 +          @{split_list 7} mk_Jconsts;
   17.53  
   17.54          val Jrel_unabs_defs = map (fn def => mk_unabs_def m (def RS meta_eq_to_obj_eq)) Jrel_defs;
   17.55 +        val Jpred_unabs_defs = map (fn def => mk_unabs_def m (def RS meta_eq_to_obj_eq)) Jpred_defs;
   17.56          val Jset_defs = flat Jset_defss;
   17.57  
   17.58          fun mk_Jmaps As Bs = map (fn mk => mk deads As Bs) mk_Jmaps_Ds;
   17.59          fun mk_Jsetss As = map2 (fn mk => fn Jsets => map (mk deads As) Jsets) mk_Jt_Ds Jsetss;
   17.60          val Jbds = map2 (fn mk => mk deads passiveAs) mk_Jt_Ds Jbds_Ds;
   17.61          fun mk_Jrels As Bs = map (fn mk => mk deads As Bs) mk_Jrels_Ds;
   17.62 +        fun mk_Jpreds As = map (fn mk => mk deads As) mk_Jpreds_Ds;
   17.63  
   17.64          val Jmaps = mk_Jmaps passiveAs passiveBs;
   17.65          val (Jsetss_by_range, Jsetss_by_bnf) = `transpose (mk_Jsetss passiveAs);
   17.66 @@ -2240,6 +2245,7 @@
   17.67              Jrel_unabs_defs;
   17.68  
   17.69          val Jrels = mk_Jrels passiveAs passiveBs;
   17.70 +        val Jpreds = mk_Jpreds passiveAs;
   17.71          val Jrelphis = map (fn rel => Term.list_comb (rel, Jphis)) Jrels;
   17.72          val relphis = map (fn rel => Term.list_comb (rel, Jphis @ Jrelphis)) rels;
   17.73          val Jrelpsi1s = map (fn rel => Term.list_comb (rel, Jpsi1s)) (mk_Jrels passiveAs passiveCs);
   17.74 @@ -2574,20 +2580,22 @@
   17.75  
   17.76          val rel_OO_Grp_tacs = map (fn def => fn ctxt => rtac ctxt def 1) Jrel_unabs_defs;
   17.77  
   17.78 -        val tacss = @{map 9} zip_axioms map_id0_tacs map_comp0_tacs map_cong0_tacs set_map0_tacss
   17.79 -          bd_co_tacs bd_cinf_tacs set_bd_tacss le_rel_OO_tacs rel_OO_Grp_tacs;
   17.80 +        val pred_set_tacs = map (fn def => fn ctxt => rtac ctxt def 1) Jpred_unabs_defs;
   17.81 +
   17.82 +        val tacss = @{map 10} zip_axioms map_id0_tacs map_comp0_tacs map_cong0_tacs set_map0_tacss
   17.83 +          bd_co_tacs bd_cinf_tacs set_bd_tacss le_rel_OO_tacs rel_OO_Grp_tacs pred_set_tacs;
   17.84  
   17.85          fun wit_tac thms ctxt =
   17.86            mk_wit_tac ctxt n dtor_ctor_thms (flat dtor_Jset_thmss) (maps wit_thms_of_bnf bnfs) thms;
   17.87  
   17.88          val (Jbnfs, lthy) =
   17.89 -          @{fold_map 6} (fn tacs => fn map_b => fn rel_b => fn set_bs => fn wit_thms =>
   17.90 +          @{fold_map 7} (fn tacs => fn map_b => fn rel_b => fn pred_b => fn set_bs => fn wit_thms =>
   17.91                fn consts =>
   17.92              bnf_def Hardly_Inline (user_policy Note_Some) false I tacs (wit_tac wit_thms)
   17.93 -              (SOME deads) map_b rel_b set_bs consts)
   17.94 -          tacss map_bs rel_bs set_bss wit_thmss
   17.95 -          ((((((replicate n Binding.empty ~~ Ts) ~~ Jmaps) ~~ Jsetss_by_bnf) ~~ Jbds) ~~
   17.96 -            all_witss) ~~ map SOME Jrels)
   17.97 +              (SOME deads) map_b rel_b pred_b set_bs consts)
   17.98 +          tacss map_bs rel_bs pred_bs set_bss wit_thmss
   17.99 +          (((((((replicate n Binding.empty ~~ Ts) ~~ Jmaps) ~~ Jsetss_by_bnf) ~~ Jbds) ~~
  17.100 +            all_witss) ~~ map SOME Jrels) ~~ map SOME Jpreds)
  17.101            lthy;
  17.102  
  17.103          val timer = time (timer "registered new codatatypes as BNFs");
    18.1 --- a/src/HOL/Tools/BNF/bnf_lfp.ML	Tue Feb 16 17:01:40 2016 +0100
    18.2 +++ b/src/HOL/Tools/BNF/bnf_lfp.ML	Tue Feb 16 22:28:19 2016 +0100
    18.3 @@ -8,9 +8,10 @@
    18.4  
    18.5  signature BNF_LFP =
    18.6  sig
    18.7 -  val construct_lfp: mixfix list -> binding list -> binding list -> binding list list ->
    18.8 -    binding list -> (string * sort) list -> typ list * typ list list -> BNF_Def.bnf list ->
    18.9 -    BNF_Comp.absT_info list -> local_theory -> BNF_FP_Util.fp_result * local_theory
   18.10 +  val construct_lfp: mixfix list -> binding list -> binding list -> binding list ->
   18.11 +    binding list list -> binding list -> (string * sort) list -> typ list * typ list list ->
   18.12 +    BNF_Def.bnf list -> BNF_Comp.absT_info list -> local_theory ->
   18.13 +    BNF_FP_Util.fp_result * local_theory
   18.14  end;
   18.15  
   18.16  structure BNF_LFP : BNF_LFP =
   18.17 @@ -26,7 +27,7 @@
   18.18  open BNF_LFP_Tactics
   18.19  
   18.20  (*all BNFs have the same lives*)
   18.21 -fun construct_lfp mixfixes map_bs rel_bs set_bss0 bs resBs (resDs, Dss) bnfs _ lthy =
   18.22 +fun construct_lfp mixfixes map_bs rel_bs pred_bs set_bss0 bs resBs (resDs, Dss) bnfs _ lthy =
   18.23    let
   18.24      val time = time lthy;
   18.25      val timer = time (Timer.startRealTimer ());
   18.26 @@ -1526,12 +1527,12 @@
   18.27              end;
   18.28  
   18.29          val (Ibnf_consts, lthy) =
   18.30 -          @{fold_map 8} (fn b => fn map_b => fn rel_b => fn set_bs => fn mapx => fn sets =>
   18.31 -              fn wits => fn T => fn lthy =>
   18.32 +          @{fold_map 9} (fn b => fn map_b => fn rel_b => fn pred_b => fn set_bs => fn mapx =>
   18.33 +              fn sets => fn wits => fn T => fn lthy =>
   18.34              define_bnf_consts Hardly_Inline (user_policy Note_Some lthy) false (SOME deads)
   18.35 -              map_b rel_b set_bs
   18.36 -              ((((((b, T), fold_rev Term.absfree fs' mapx), sets), sbd0), wits), NONE) lthy)
   18.37 -          bs map_bs rel_bs set_bss fs_maps setss_by_bnf ctor_witss Ts lthy;
   18.38 +              map_b rel_b pred_b set_bs
   18.39 +              (((((((b, T), fold_rev Term.absfree fs' mapx), sets), sbd0), wits), NONE), NONE) lthy)
   18.40 +          bs map_bs rel_bs pred_bs set_bss fs_maps setss_by_bnf ctor_witss Ts lthy;
   18.41  
   18.42          val ((((((((((((((Izs, (Izs1, Izs1')), (Izs2, Izs2')), xFs), yFs))), Iphis), Ipsi1s),
   18.43              Ipsi2s), fs), fs_copy), us), (ys, ys')), _) =
   18.44 @@ -1550,11 +1551,14 @@
   18.45            ||>> mk_Frees' "y" passiveAs;
   18.46  
   18.47          val (_, Iconsts, Iconst_defs, mk_Iconsts) = @{split_list 4} Ibnf_consts;
   18.48 -        val (_, Isetss, Ibds_Ds, Iwitss_Ds, _) = @{split_list 5} Iconsts;
   18.49 -        val (Imap_defs, Iset_defss, Ibd_defs, Iwit_defss, Irel_defs) = @{split_list 5} Iconst_defs;
   18.50 -        val (mk_Imaps_Ds, mk_It_Ds, _, mk_Irels_Ds, _) = @{split_list 5} mk_Iconsts;
   18.51 +        val (_, Isetss, Ibds_Ds, Iwitss_Ds, _, _) = @{split_list 6} Iconsts;
   18.52 +        val (Imap_defs, Iset_defss, Ibd_defs, Iwit_defss, Irel_defs, Ipred_defs) =
   18.53 +          @{split_list 6} Iconst_defs;
   18.54 +        val (mk_Imaps_Ds, mk_It_Ds, _, mk_Irels_Ds, mk_Ipreds_Ds, _, _) =
   18.55 +          @{split_list 7} mk_Iconsts;
   18.56  
   18.57          val Irel_unabs_defs = map (fn def => mk_unabs_def m (def RS meta_eq_to_obj_eq)) Irel_defs;
   18.58 +        val Ipred_unabs_defs = map (fn def => mk_unabs_def m (def RS meta_eq_to_obj_eq)) Ipred_defs;
   18.59          val Iset_defs = flat Iset_defss;
   18.60  
   18.61          fun mk_Imaps As Bs = map (fn mk => mk deads As Bs) mk_Imaps_Ds;
   18.62 @@ -1563,6 +1567,7 @@
   18.63          val Iwitss =
   18.64            map2 (fn mk => fn Iwits => map (mk deads passiveAs o snd) Iwits) mk_It_Ds Iwitss_Ds;
   18.65          fun mk_Irels As Bs = map (fn mk => mk deads As Bs) mk_Irels_Ds;
   18.66 +        fun mk_Ipreds As = map (fn mk => mk deads As) mk_Ipreds_Ds;
   18.67  
   18.68          val Imaps = mk_Imaps passiveAs passiveBs;
   18.69          val fs_Imaps = map (fn m => Term.list_comb (m, fs)) Imaps;
   18.70 @@ -1762,6 +1767,7 @@
   18.71          val ctor_Iset_thmss' = transpose ctor_Iset_thmss;
   18.72  
   18.73          val Irels = mk_Irels passiveAs passiveBs;
   18.74 +        val Ipreds = mk_Ipreds passiveAs;
   18.75          val Irelphis = map (fn rel => Term.list_comb (rel, Iphis)) Irels;
   18.76          val relphis = map (fn rel => Term.list_comb (rel, Iphis @ Irelphis)) rels;
   18.77          val Irelpsi1s = map (fn rel => Term.list_comb (rel, Ipsi1s)) (mk_Irels passiveAs passiveCs);
   18.78 @@ -1832,19 +1838,21 @@
   18.79  
   18.80          val rel_OO_Grp_tacs = map (fn def => fn ctxt => rtac ctxt def 1) Irel_unabs_defs;
   18.81  
   18.82 -        val tacss = @{map 9} zip_axioms map_id0_tacs map_comp0_tacs map_cong0_tacs set_map0_tacss
   18.83 -          bd_co_tacs bd_cinf_tacs set_bd_tacss le_rel_OO_tacs rel_OO_Grp_tacs;
   18.84 +        val pred_set_tacs = map (fn def => fn ctxt => rtac ctxt def 1) Ipred_unabs_defs;
   18.85 +
   18.86 +        val tacss = @{map 10} zip_axioms map_id0_tacs map_comp0_tacs map_cong0_tacs set_map0_tacss
   18.87 +          bd_co_tacs bd_cinf_tacs set_bd_tacss le_rel_OO_tacs rel_OO_Grp_tacs pred_set_tacs;
   18.88  
   18.89          fun wit_tac ctxt = unfold_thms_tac ctxt (flat Iwit_defss) THEN
   18.90            mk_wit_tac ctxt n (flat ctor_Iset_thmss) (maps wit_thms_of_bnf bnfs);
   18.91  
   18.92          val (Ibnfs, lthy) =
   18.93 -          @{fold_map 5} (fn tacs => fn map_b => fn rel_b => fn set_bs => fn consts =>
   18.94 +          @{fold_map 6} (fn tacs => fn map_b => fn rel_b => fn pred_b => fn set_bs => fn consts =>
   18.95              bnf_def Do_Inline (user_policy Note_Some) false I tacs wit_tac (SOME deads)
   18.96 -              map_b rel_b set_bs consts)
   18.97 -          tacss map_bs rel_bs set_bss
   18.98 -            ((((((replicate n Binding.empty ~~ Ts) ~~ Imaps) ~~ Isetss_by_bnf) ~~ Ibds) ~~
   18.99 -              Iwitss) ~~ map SOME Irels) lthy;
  18.100 +              map_b rel_b pred_b set_bs consts)
  18.101 +          tacss map_bs rel_bs pred_bs set_bss
  18.102 +            (((((((replicate n Binding.empty ~~ Ts) ~~ Imaps) ~~ Isetss_by_bnf) ~~ Ibds) ~~
  18.103 +              Iwitss) ~~ map SOME Irels) ~~ map SOME Ipreds) lthy;
  18.104  
  18.105          val timer = time (timer "registered new datatypes as BNFs");
  18.106  
    19.1 --- a/src/HOL/Tools/BNF/bnf_lfp_compat.ML	Tue Feb 16 17:01:40 2016 +0100
    19.2 +++ b/src/HOL/Tools/BNF/bnf_lfp_compat.ML	Tue Feb 16 22:28:19 2016 +0100
    19.3 @@ -521,7 +521,7 @@
    19.4  
    19.5      fun new_spec_of ((b, old_tyargs, mx), old_ctr_specs) =
    19.6        (((((map new_type_args_of old_tyargs, b), mx), map new_ctr_spec_of old_ctr_specs),
    19.7 -        (Binding.empty, Binding.empty)), []);
    19.8 +        (Binding.empty, Binding.empty, Binding.empty)), []);
    19.9  
   19.10      val new_specs = map new_spec_of old_specs;
   19.11    in
    20.1 --- a/src/HOL/Tools/BNF/bnf_lift.ML	Tue Feb 16 17:01:40 2016 +0100
    20.2 +++ b/src/HOL/Tools/BNF/bnf_lift.ML	Tue Feb 16 22:28:19 2016 +0100
    20.3 @@ -13,21 +13,21 @@
    20.4    | No_Warn_Wits
    20.5    val copy_bnf:
    20.6      (((lift_bnf_option list * (binding option * (string * sort option)) list) *
    20.7 -      string) * thm option) * (binding * binding) ->
    20.8 +      string) * thm option) * (binding * binding * binding) ->
    20.9        local_theory -> local_theory
   20.10    val copy_bnf_cmd:
   20.11      (((lift_bnf_option list * (binding option * (string * string option)) list) *
   20.12 -      string) * (Facts.ref * Token.src list) option) * (binding * binding) ->
   20.13 +      string) * (Facts.ref * Token.src list) option) * (binding * binding * binding) ->
   20.14        local_theory -> local_theory
   20.15    val lift_bnf:
   20.16      (((lift_bnf_option list * (binding option * (string * sort option)) list) *
   20.17 -      string) * thm option) * (binding * binding) ->
   20.18 +      string) * thm option) * (binding * binding * binding) ->
   20.19        ({context: Proof.context, prems: thm list} -> tactic) list ->
   20.20        local_theory -> local_theory
   20.21    val lift_bnf_cmd:
   20.22       ((((lift_bnf_option list * (binding option * (string * string option)) list) *
   20.23 -       string) * string list) * (Facts.ref * Token.src list) option) * (binding * binding) ->
   20.24 -       local_theory -> Proof.state
   20.25 +       string) * string list) * (Facts.ref * Token.src list) option) *
   20.26 +       (binding * binding * binding) -> local_theory -> Proof.state
   20.27  end
   20.28  
   20.29  structure BNF_Lift : BNF_LIFT =
   20.30 @@ -45,7 +45,7 @@
   20.31    Plugins_Option of Proof.context -> Plugin_Name.filter
   20.32  | No_Warn_Wits;
   20.33  
   20.34 -fun typedef_bnf thm wits specs map_b rel_b opts lthy =
   20.35 +fun typedef_bnf thm wits specs map_b rel_b pred_b opts lthy =
   20.36    let
   20.37      val plugins =
   20.38        get_first (fn Plugins_Option f => SOME (f lthy) | _ => NONE) (rev opts)
   20.39 @@ -212,6 +212,14 @@
   20.40              val rel_G = fold_rev absfree (map dest_Free var_Rs)
   20.41                (mk_vimage2p Rep_G Rep_Gb $ list_comb (rel_F, var_Rs));
   20.42  
   20.43 +            (* val pred_G = @{term "\<lambda>P. pred_F P o Rep_G"}; *)
   20.44 +            val pred_F = mk_pred_of_bnf deads alphas bnf;
   20.45 +            val (typ_Ps, _) = strip_typeN lives (fastype_of pred_F);
   20.46 +
   20.47 +            val (var_Ps, names_lthy) = mk_Frees "P" typ_Ps names_lthy;
   20.48 +            val pred_G = fold_rev absfree (map dest_Free var_Ps)
   20.49 +              (HOLogic.mk_comp (list_comb (pred_F, var_Ps), Rep_G));
   20.50 +
   20.51              (* val wits_G = [@{term "Abs_G o wit_F"}]; *)
   20.52              val (var_as, _) = mk_Frees "a" alphas names_lthy;
   20.53              val wits_G =
   20.54 @@ -297,6 +305,12 @@
   20.55                    [rtac ctxt (iffD1 OF [Abs_inject_thm OF [map_closed_thm OF [Rep_thm], Rep_thm]]),
   20.56                    etac ctxt (Rep_inverse_thm RS sym RSN (2, trans))]]));
   20.57  
   20.58 +            fun pred_set_tac ctxt =
   20.59 +              HEADGOAL (EVERY'
   20.60 +                [rtac ctxt (pred_set_of_bnf bnf RS @{thm arg_cong[of _ _ "\<lambda>f. f o _"]} RS trans),
   20.61 +                SELECT_GOAL (unfold_thms_tac ctxt (@{thms Ball_comp_iff conj_comp_iff})),
   20.62 +                rtac ctxt refl]);
   20.63 +
   20.64              fun wit_tac ctxt =
   20.65                HEADGOAL (EVERY'
   20.66                  (map (fn thm => (EVERY'
   20.67 @@ -306,11 +320,12 @@
   20.68                  wit_thms));
   20.69  
   20.70              val tactics = [map_id0_tac, map_comp0_tac, map_cong0_tac] @ set_map0s_tac @
   20.71 -              [card_order_bd_tac, cinfinite_bd_tac] @ set_bds_tac @ [le_rel_OO_tac, rel_OO_Grp_tac];
   20.72 +              [card_order_bd_tac, cinfinite_bd_tac] @ set_bds_tac @
   20.73 +              [le_rel_OO_tac, rel_OO_Grp_tac, pred_set_tac];
   20.74  
   20.75              val (bnf, lthy) = bnf_def Dont_Inline (user_policy Note_Some) false I
   20.76 -              tactics wit_tac NONE map_b rel_b set_bs
   20.77 -              ((((((Binding.empty, AbsT), map_G), sets_G), bd_G), wits_G), SOME rel_G)
   20.78 +              tactics wit_tac NONE map_b rel_b pred_b set_bs
   20.79 +              (((((((Binding.empty, AbsT), map_G), sets_G), bd_G), wits_G), SOME rel_G), SOME pred_G)
   20.80                lthy;
   20.81  
   20.82              val bnf = morph_bnf_defs (Morphism.thm_morphism "BNF" (unfold_thms lthy defs)) bnf;
   20.83 @@ -328,7 +343,7 @@
   20.84  local
   20.85  
   20.86  fun prepare_common prepare_name prepare_sort prepare_term prepare_thm
   20.87 -    (((((plugins, raw_specs), raw_Tname), raw_wits), xthm_opt), (map_b, rel_b)) lthy =
   20.88 +    (((((plugins, raw_specs), raw_Tname), raw_wits), xthm_opt), (map_b, rel_b, pred_b)) lthy =
   20.89    let
   20.90      val Tname = prepare_name lthy raw_Tname;
   20.91      val input_thm =
   20.92 @@ -344,7 +359,7 @@
   20.93          Const (@{const_name type_definition}, _) $ _ $ _ $ _ => ()
   20.94        | _ => error "Unsupported type of a theorem: only type_definition is supported");
   20.95    in
   20.96 -    typedef_bnf input_thm wits specs map_b rel_b plugins lthy
   20.97 +    typedef_bnf input_thm wits specs map_b rel_b pred_b plugins lthy
   20.98    end;
   20.99  
  20.100  fun prepare_lift_bnf prepare_name prepare_sort prepare_term prepare_thm =
  20.101 @@ -413,13 +428,13 @@
  20.102    Outer_Syntax.local_theory_to_proof @{command_keyword lift_bnf}
  20.103      "register a subtype of a bounded natural functor (BNF) as a BNF"
  20.104      ((parse_options -- parse_type_args_named_constrained -- Parse.type_const -- parse_wits --
  20.105 -      parse_typedef_thm -- parse_map_rel_bindings) >> lift_bnf_cmd);
  20.106 +      parse_typedef_thm -- parse_map_rel_pred_bindings) >> lift_bnf_cmd);
  20.107  
  20.108  val _ =
  20.109    Outer_Syntax.local_theory @{command_keyword copy_bnf}
  20.110      "register a type copy of a bounded natural functor (BNF) as a BNF"
  20.111      ((parse_plugins -- parse_type_args_named_constrained -- Parse.type_const --
  20.112 -      parse_typedef_thm -- parse_map_rel_bindings) >> copy_bnf_cmd);
  20.113 +      parse_typedef_thm -- parse_map_rel_pred_bindings) >> copy_bnf_cmd);
  20.114  
  20.115  end;
  20.116  
    21.1 --- a/src/HOL/Tools/BNF/bnf_util.ML	Tue Feb 16 17:01:40 2016 +0100
    21.2 +++ b/src/HOL/Tools/BNF/bnf_util.ML	Tue Feb 16 22:28:19 2016 +0100
    21.3 @@ -52,6 +52,7 @@
    21.4    val mk_cprod: term -> term -> term
    21.5    val mk_csum: term -> term -> term
    21.6    val mk_dir_image: term -> term -> term
    21.7 +  val mk_eq_onp: term -> term
    21.8    val mk_rel_fun: term -> term -> term
    21.9    val mk_image: term -> term
   21.10    val mk_in: term list -> term list -> typ -> term
   21.11 @@ -103,7 +104,7 @@
   21.12    val fold_thms: Proof.context -> thm list -> thm -> thm
   21.13  
   21.14    val parse_type_args_named_constrained: (binding option * (string * string option)) list parser
   21.15 -  val parse_map_rel_bindings: (binding * binding) parser
   21.16 +  val parse_map_rel_pred_bindings: (binding * binding * binding) parser
   21.17  
   21.18    val typedef: binding * (string * sort) list * mixfix -> term ->
   21.19      (binding * binding) option -> (Proof.context -> tactic) ->
   21.20 @@ -130,17 +131,18 @@
   21.21    @{keyword "("} |-- Parse.!!! (Parse.list1 parse_type_arg_named_constrained --| @{keyword ")"}) ||
   21.22    Scan.succeed [];
   21.23  
   21.24 -val parse_map_rel_binding = Parse.name --| @{keyword ":"} -- Parse.binding;
   21.25 +val parse_map_rel_pred_binding = Parse.name --| @{keyword ":"} -- Parse.binding;
   21.26  
   21.27 -val no_map_rel = (Binding.empty, Binding.empty);
   21.28 +val no_map_rel = (Binding.empty, Binding.empty, Binding.empty);
   21.29  
   21.30 -fun extract_map_rel ("map", b) = apfst (K b)
   21.31 -  | extract_map_rel ("rel", b) = apsnd (K b)
   21.32 -  | extract_map_rel (s, _) = error ("Unknown label " ^ quote s ^ " (expected \"map\" or \"rel\")");
   21.33 +fun extract_map_rel_pred ("map", m) = (fn (_, r, p) => (m, r, p))
   21.34 +  | extract_map_rel_pred ("rel", r) = (fn (m, _, p) => (m, r, p))
   21.35 +  | extract_map_rel_pred ("pred", p) = (fn (m, r, _) => (m, r, p))
   21.36 +  | extract_map_rel_pred (s, _) = error ("Unknown label " ^ quote s ^ " (expected \"map\" or \"rel\")");
   21.37  
   21.38 -val parse_map_rel_bindings =
   21.39 -  @{keyword "for"} |-- Scan.repeat parse_map_rel_binding
   21.40 -    >> (fn ps => fold extract_map_rel ps no_map_rel)
   21.41 +val parse_map_rel_pred_bindings =
   21.42 +  @{keyword "for"} |-- Scan.repeat parse_map_rel_pred_binding
   21.43 +    >> (fn ps => fold extract_map_rel_pred ps no_map_rel)
   21.44    || Scan.succeed no_map_rel;
   21.45  
   21.46  fun typedef (b, Ts, mx) set opt_morphs tac lthy =
   21.47 @@ -352,6 +354,13 @@
   21.48        (T1 --> T2) --> (U1 --> U2) --> mk_pred2T T2 U2 --> mk_pred2T T1 U1) $ f $ g
   21.49    end;
   21.50  
   21.51 +fun mk_eq_onp P =
   21.52 +  let
   21.53 +    val T = domain_type (fastype_of P);
   21.54 +  in
   21.55 +    Const (@{const_name eq_onp}, (T --> HOLogic.boolT) --> T --> T --> HOLogic.boolT) $ P
   21.56 +  end;
   21.57 +
   21.58  fun mk_pred name R =
   21.59    Const (name, uncurry mk_pred2T (fastype_of R |> dest_pred2T) --> HOLogic.boolT) $ R;
   21.60  val mk_reflp = mk_pred @{const_name reflp};
    22.1 --- a/src/HOL/Tools/Lifting/lifting_bnf.ML	Tue Feb 16 17:01:40 2016 +0100
    22.2 +++ b/src/HOL/Tools/Lifting/lifting_bnf.ML	Tue Feb 16 22:28:19 2016 +0100
    22.3 @@ -85,14 +85,8 @@
    22.4  
    22.5  (* relator_eq_onp  *)
    22.6  
    22.7 -fun relator_eq_onp bnf ctxt =
    22.8 -  let
    22.9 -    val relator_eq_onp_thm = lookup_defined_pred_data ctxt (type_name_of_bnf bnf) 
   22.10 -      |> Transfer.rel_eq_onp
   22.11 -  in
   22.12 -    [((Binding.empty, []), [([relator_eq_onp_thm], @{attributes [relator_eq_onp]})])]    
   22.13 -  end
   22.14 -  handle NO_PRED_DATA _ => [] (* the "lifting" plugin should work even if "quotient" is disabled *)
   22.15 +fun relator_eq_onp bnf =
   22.16 +  [((Binding.empty, []), [([rel_eq_onp_of_bnf bnf], @{attributes [relator_eq_onp]})])]
   22.17  
   22.18  (* relator_mono  *)
   22.19  
   22.20 @@ -110,7 +104,7 @@
   22.21    if dead_of_bnf bnf > 0 then lthy
   22.22    else
   22.23      let
   22.24 -      val notess = [relator_eq_onp bnf lthy, Quotient_map bnf lthy, relator_mono bnf,
   22.25 +      val notess = [relator_eq_onp bnf, Quotient_map bnf lthy, relator_mono bnf,
   22.26          relator_distr bnf]
   22.27      in
   22.28        lthy |> fold (perhaps o try o (snd oo Local_Theory.notes)) notess
    23.1 --- a/src/HOL/Tools/Transfer/transfer_bnf.ML	Tue Feb 16 17:01:40 2016 +0100
    23.2 +++ b/src/HOL/Tools/Transfer/transfer_bnf.ML	Tue Feb 16 22:28:19 2016 +0100
    23.3 @@ -27,7 +27,6 @@
    23.4  (* util functions *)
    23.5  
    23.6  fun base_name_of_bnf bnf = Binding.name (Binding.name_of (name_of_bnf bnf))
    23.7 -fun mk_Frees_free x Ts ctxt = Variable.variant_frees ctxt [] (mk_names (length Ts) x ~~ Ts) |> map Free
    23.8  
    23.9  fun mk_Domainp P =
   23.10    let
   23.11 @@ -37,15 +36,6 @@
   23.12      Const (@{const_name Domainp}, PT --> argT --> HOLogic.boolT) $ P
   23.13    end
   23.14  
   23.15 -fun mk_pred pred_def args T =
   23.16 -  let
   23.17 -    val pred_name = pred_def |> Thm.prop_of |> HOLogic.dest_Trueprop |> fst o HOLogic.dest_eq
   23.18 -      |> head_of |> fst o dest_Const
   23.19 -    val argsT = map fastype_of args
   23.20 -  in
   23.21 -    list_comb (Const (pred_name, argsT ---> (T --> HOLogic.boolT)), args)
   23.22 -  end
   23.23 -
   23.24  fun mk_eq_onp arg =
   23.25    let
   23.26      val argT = domain_type (fastype_of arg)
   23.27 @@ -54,9 +44,6 @@
   23.28        $ arg
   23.29    end
   23.30  
   23.31 -fun subst_conv thm =
   23.32 -  Conv.top_sweep_conv (K (Conv.rewr_conv (safe_mk_meta_eq thm))) @{context}
   23.33 -
   23.34  fun type_name_of_bnf bnf = T_of_bnf bnf |> dest_Type |> fst
   23.35  
   23.36  fun is_Type (Type _) = true
   23.37 @@ -169,32 +156,7 @@
   23.38      map (fn thm => ((Binding.empty,[]),[([thm],transfer_attr)])) transfer_rules
   23.39    end
   23.40  
   23.41 -(* predicator definition and Domainp and eq_onp theorem *)
   23.42 -
   23.43 -fun define_pred bnf lthy =
   23.44 -  let
   23.45 -    fun mk_pred_name c = Binding.prefix_name "pred_" c
   23.46 -    val live = live_of_bnf bnf
   23.47 -    val Tname = base_name_of_bnf bnf
   23.48 -    val ((As, Ds), lthy) = lthy
   23.49 -      |> mk_TFrees live
   23.50 -      ||>> mk_TFrees' (map Type.sort_of_atyp (deads_of_bnf bnf))
   23.51 -    val T = mk_T_of_bnf Ds As bnf
   23.52 -    val sets = mk_sets_of_bnf (replicate live Ds) (replicate live As) bnf
   23.53 -    val argTs = map mk_pred1T As
   23.54 -    val args = mk_Frees_free "P" argTs lthy
   23.55 -    val conjs = map (fn (set, arg) => mk_Ball (set $ Bound 0) arg) (sets ~~ args)
   23.56 -    val rhs = Abs ("x", T, foldr1 HOLogic.mk_conj conjs)
   23.57 -    val pred_name = mk_pred_name Tname
   23.58 -    val headT = argTs ---> (T --> HOLogic.boolT)
   23.59 -    val head = Free (Binding.name_of pred_name, headT)
   23.60 -    val lhs = list_comb (head, args)
   23.61 -    val def = HOLogic.mk_Trueprop (HOLogic.mk_eq (lhs, rhs))
   23.62 -    val ((_, (_, pred_def)), lthy) = Specification.definition ((SOME (pred_name, SOME headT, NoSyn)),
   23.63 -      ((Binding.empty, []), def)) lthy
   23.64 -  in
   23.65 -    (pred_def, lthy)
   23.66 -  end
   23.67 +(* Domainp theorem for predicator *)
   23.68  
   23.69  fun Domainp_tac bnf pred_def ctxt i =
   23.70    let
   23.71 @@ -233,10 +195,9 @@
   23.72  
   23.73      val relator = mk_rel_of_bnf Ds As Bs bnf
   23.74      val relsT = map2 mk_pred2T As Bs
   23.75 -    val T = mk_T_of_bnf Ds As bnf
   23.76      val (args, ctxt) = Ctr_Sugar_Util.mk_Frees "R" relsT ctxt
   23.77      val lhs = mk_Domainp (list_comb (relator, args))
   23.78 -    val rhs = mk_pred pred_def (map mk_Domainp args) T
   23.79 +    val rhs = Term.list_comb (mk_pred_of_bnf Ds As bnf, map mk_Domainp args)
   23.80      val goal = HOLogic.mk_eq (lhs, rhs) |> HOLogic.mk_Trueprop
   23.81      val thm = Goal.prove_sorry ctxt [] [] goal
   23.82        (fn {context = ctxt, prems = _} => Domainp_tac bnf pred_def ctxt 1)
   23.83 @@ -245,46 +206,17 @@
   23.84      Drule.zero_var_indexes (singleton (Variable.export ctxt old_ctxt) thm)
   23.85    end
   23.86  
   23.87 -fun pred_eq_onp_tac bnf pred_def ctxt i =
   23.88 -  (SELECT_GOAL (Local_Defs.unfold_tac ctxt [@{thm eq_onp_Grp},
   23.89 -    @{thm Ball_Collect}, pred_def]) THEN' CONVERSION (subst_conv (map_id0_of_bnf bnf RS sym))
   23.90 -  THEN' rtac ctxt (rel_Grp_of_bnf bnf)) i
   23.91 -
   23.92 -fun prove_rel_eq_onp ctxt bnf pred_def =
   23.93 -  let
   23.94 -    val live = live_of_bnf bnf
   23.95 -    val old_ctxt = ctxt
   23.96 -    val ((As, Ds), ctxt) = ctxt
   23.97 -      |> mk_TFrees live
   23.98 -      ||>> mk_TFrees' (map Type.sort_of_atyp (deads_of_bnf bnf))
   23.99 -    val T = mk_T_of_bnf Ds As bnf
  23.100 -    val argTs = map mk_pred1T As
  23.101 -    val (args, ctxt) = mk_Frees "P" argTs ctxt
  23.102 -    val relator = mk_rel_of_bnf Ds As As bnf
  23.103 -    val lhs = list_comb (relator, map mk_eq_onp args)
  23.104 -    val rhs = mk_eq_onp (mk_pred pred_def args T)
  23.105 -    val goal = HOLogic.mk_eq (lhs, rhs) |> HOLogic.mk_Trueprop
  23.106 -    val thm = Goal.prove_sorry ctxt [] [] goal
  23.107 -      (fn {context = ctxt, prems = _} => pred_eq_onp_tac bnf pred_def ctxt 1)
  23.108 -      |> Thm.close_derivation
  23.109 -  in
  23.110 -    Drule.zero_var_indexes (singleton (Variable.export ctxt old_ctxt) thm)
  23.111 -  end
  23.112 -
  23.113  fun predicator bnf lthy =
  23.114    let
  23.115 -    val (pred_def, lthy) = define_pred bnf lthy
  23.116 -    val pred_def = Morphism.thm (Local_Theory.target_morphism lthy) pred_def
  23.117 +    val pred_def = pred_set_of_bnf bnf
  23.118      val Domainp_rel = prove_Domainp_rel lthy bnf pred_def
  23.119 -    val rel_eq_onp = prove_rel_eq_onp lthy bnf pred_def
  23.120 +    val rel_eq_onp = rel_eq_onp_of_bnf bnf
  23.121      fun qualify defname suffix = Binding.qualified true suffix defname
  23.122      val Domainp_rel_thm_name = qualify (base_name_of_bnf bnf) "Domainp_rel"
  23.123 -    val rel_eq_onp_thm_name = qualify (base_name_of_bnf bnf) "rel_eq_onp"
  23.124      val pred_data = Transfer.mk_pred_data pred_def rel_eq_onp []
  23.125      val type_name = type_name_of_bnf bnf
  23.126      val relator_domain_attr = @{attributes [relator_domain]}
  23.127 -    val notes = [((Domainp_rel_thm_name, []), [([Domainp_rel], relator_domain_attr)]),
  23.128 -      ((rel_eq_onp_thm_name, []), [([rel_eq_onp], [])])]
  23.129 +    val notes = [((Domainp_rel_thm_name, []), [([Domainp_rel], relator_domain_attr)])]
  23.130    in
  23.131      lthy
  23.132      |> Local_Theory.notes notes
  23.133 @@ -328,7 +260,7 @@
  23.134      map_filter (uncurry (fn true => SOME | false => K NONE)) (liveness ~~ As)
  23.135    end
  23.136  
  23.137 -fun prove_pred_inject lthy (fp_sugar:fp_sugar) =
  23.138 +fun prove_pred_inject lthy (fp_sugar : fp_sugar) =
  23.139    let
  23.140      val involved_types = distinct op= (
  23.141          map type_name_of_bnf (#fp_nesting_bnfs fp_sugar)
    24.1 --- a/src/HOL/Transfer.thy	Tue Feb 16 17:01:40 2016 +0100
    24.2 +++ b/src/HOL/Transfer.thy	Tue Feb 16 22:28:19 2016 +0100
    24.3 @@ -229,28 +229,7 @@
    24.4  
    24.5  end
    24.6  
    24.7 -subsection \<open>Equality restricted by a predicate\<close>
    24.8  
    24.9 -definition eq_onp :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool"
   24.10 -  where "eq_onp R = (\<lambda>x y. R x \<and> x = y)"
   24.11 -
   24.12 -lemma eq_onp_Grp: "eq_onp P = BNF_Def.Grp (Collect P) id"
   24.13 -unfolding eq_onp_def Grp_def by auto
   24.14 -
   24.15 -lemma eq_onp_to_eq:
   24.16 -  assumes "eq_onp P x y"
   24.17 -  shows "x = y"
   24.18 -using assms by (simp add: eq_onp_def)
   24.19 -
   24.20 -lemma eq_onp_top_eq_eq: "eq_onp top = op="
   24.21 -by (simp add: eq_onp_def)
   24.22 -
   24.23 -lemma eq_onp_same_args:
   24.24 -  shows "eq_onp P x x = P x"
   24.25 -using assms by (auto simp add: eq_onp_def)
   24.26 -
   24.27 -lemma Ball_Collect: "Ball A P = (A \<subseteq> (Collect P))"
   24.28 -by auto
   24.29  
   24.30  ML_file "Tools/Transfer/transfer.ML"
   24.31  declare refl [transfer_rule]
   24.32 @@ -557,7 +536,7 @@
   24.33  
   24.34  lemma prod_pred_parametric [transfer_rule]:
   24.35    "((A ===> op =) ===> (B ===> op =) ===> rel_prod A B ===> op =) pred_prod pred_prod"
   24.36 -unfolding pred_prod_def[abs_def] Basic_BNFs.fsts_def Basic_BNFs.snds_def fstsp.simps sndsp.simps 
   24.37 +unfolding prod.pred_set[abs_def] Basic_BNFs.fsts_def Basic_BNFs.snds_def fstsp.simps sndsp.simps 
   24.38  by simp transfer_prover
   24.39  
   24.40  lemma apfst_parametric [transfer_rule]: