(*
  Theory: Measure_Embeddings.thy
  Authors: Manuel Eberl

  Defines measure embeddings with injective functions, i.e. lifting a measure on some values
  to a measure on "tagged" values (e.g. embed_measure M Inl lifts a measure on values 'a to a
  measure on the left part of the sum type 'a + 'b)
*)

header {* Embed Measure Spaces with a Function *}

theory Measure_Embeddings
imports Probability Density_Predicates PDF_Misc
begin

lemma vimage_algebra_cong:
  assumes "X = Y"
  assumes "\<And>x. x \<in> Y \<Longrightarrow> f x = g x"
  assumes "sets M = sets N"
  shows "vimage_algebra X f M = vimage_algebra Y g N"
  by (auto simp: vimage_algebra_def assms simple_image intro!: arg_cong2[where f=sigma])

definition embed_measure :: "'a measure \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'b measure" where
  "embed_measure M f = measure_of (f ` space M) {f ` A |A. A \<in> sets M}
                           (\<lambda>A. emeasure M (f -` A \<inter> space M))"

lemma space_embed_measure: "space (embed_measure M f) = f ` space M"
  unfolding embed_measure_def
  by (subst space_measure_of) (auto dest: sets.sets_into_space)

lemma sets_embed_measure':
  assumes inj: "inj_on f (space M)"
  shows "sets (embed_measure M f) = {f ` A |A. A \<in> sets M}"
  unfolding embed_measure_def
proof (intro sigma_algebra.sets_measure_of_eq sigma_algebra_iff2[THEN iffD2] conjI allI ballI impI)
  fix s assume "s \<in> {f ` A |A. A \<in> sets M}"
  then obtain s' where s'_props: "s = f ` s'" "s' \<in> sets M" by auto
  hence "f ` space M - s = f ` (space M - s')" using inj
    by (auto dest: inj_onD sets.sets_into_space)
  also have "... \<in> {f ` A |A. A \<in> sets M}" using s'_props by auto
  finally show "f ` space M - s \<in> {f ` A |A. A \<in> sets M}" .
next
  fix A :: "nat \<Rightarrow> _" assume "range A \<subseteq> {f ` A |A. A \<in> sets M}"
  then obtain A' where "\<And>i. A i = f ` A' i" "\<And>i. A' i \<in> sets M"
    by (auto simp: subset_eq choice_iff)
  moreover from this have "(\<Union>x. f ` A' x) = f ` (\<Union>x. A' x)" by blast
  ultimately show "(\<Union>i. A i) \<in> {f ` A |A. A \<in> sets M}" by blast
qed (auto dest: sets.sets_into_space)

lemma the_inv_into_vimage:
  "inj_on f X \<Longrightarrow> A \<subseteq> X \<Longrightarrow> the_inv_into X f -` A \<inter> (f`X) = f ` A"
  by (auto simp: the_inv_into_f_f)

lemma sets_embed_eq_vimage_algebra:
  assumes "inj_on f (space M)"
  shows "sets (embed_measure M f) = sets (vimage_algebra (f`space M) (the_inv_into (space M) f) M)"
  by (auto simp: sets_embed_measure'[OF assms] Pi_iff the_inv_into_f_f assms sets_vimage_algebra2 simple_image
           dest: sets.sets_into_space
           intro!: image_cong the_inv_into_vimage[symmetric])

lemma emeasure_sigma[simp]: "emeasure (sigma \<Omega> A) = (\<lambda>_. 0)"
  unfolding measure_of_def emeasure_def
  by (subst Abs_measure_inverse)
     (auto simp: measure_space_def sigma_algebra_trivial sigma_algebra_sigma_sets
                 positive_def countably_additive_def)

lemma vimage_algebra_Sup_sigma:
  assumes [simp]: "MM \<noteq> {}" and "\<And>M. M \<in> MM \<Longrightarrow> f \<in> X \<rightarrow> space M"
  shows "vimage_algebra X f (Sup_sigma MM) = Sup_sigma (vimage_algebra X f ` MM)"
proof (rule measure_eqI)
  show "sets (vimage_algebra X f (Sup_sigma MM)) = sets (Sup_sigma (vimage_algebra X f ` MM))"
    apply (intro antisym[of "sets A" for A] sets_image_in_sets sets_Sup_in_sets)
    apply (subst space_Sup_sigma)
    using assms
    apply simp
    apply (rule measurable_Sup_sigma2)
    apply simp
    apply (rule measurable_Sup_sigma1)
    apply (rule imageI)
    apply assumption
    apply (rule measurable_vimage_algebra1)
    apply fact
    apply auto []
    apply simp
    apply (auto simp: sets_vimage_algebra2 assms(2))
    apply (rule in_vimage_algebra)
    apply (rule in_Sup_sigma)
    apply assumption +
    done
qed (simp add: vimage_algebra_def Sup_sigma_def)

lemma vimage_algebra_vimage_algebra:
  assumes "f \<in> X \<rightarrow> Y" "g \<in> Y \<rightarrow> space M"
  shows "vimage_algebra X f (vimage_algebra Y g M) = vimage_algebra X (\<lambda>x. g (f x)) M" (is "?L = ?R")
proof (rule measure_eqI)
  have fg: "(\<lambda>x. g (f x)) \<in> X \<rightarrow> space M" "\<And>A. f -` g -` A \<inter> f -` Y \<inter> X = (\<lambda>x. g (f x)) -` A \<inter> X"
    using assms by auto
  show "sets ?L = sets ?R"
    by (simp add: sets_vimage_algebra2 assms fg simple_image image_comp comp_def del: ex_simps)
qed (simp add: vimage_algebra_def Sup_sigma_def)

lemma sets_embed_measure:
  assumes inj: "inj f"
  shows "sets (embed_measure M f) = {f ` A |A. A \<in> sets M}"
  using assms by (subst sets_embed_measure') (auto intro!: inj_onI dest: injD)

lemma in_sets_embed_measure: "A \<in> sets M \<Longrightarrow> f ` A \<in> sets (embed_measure M f)"
  unfolding embed_measure_def
  by (intro in_measure_of) (auto dest: sets.sets_into_space)

lemma measurable_embed_measure1[measurable (raw)]:
  assumes g: "(\<lambda>x. g (f x)) \<in> measurable M N"
  shows "g \<in> measurable (embed_measure M f) N"
  unfolding measurable_def
proof safe
  fix A assume "A \<in> sets N"
  with g have "(\<lambda>x. g (f x)) -` A \<inter> space M \<in> sets M"
    by (rule measurable_sets)
  then have "f ` ((\<lambda>x. g (f x)) -` A \<inter> space M) \<in> sets (embed_measure M f)"
    by (rule in_sets_embed_measure)
  also have "f ` ((\<lambda>x. g (f x)) -` A \<inter> space M) = g -` A \<inter> space (embed_measure M f)"
    by (auto simp: space_embed_measure)
  finally show "g -` A \<inter> space (embed_measure M f) \<in> sets (embed_measure M f)" .
qed (insert measurable_space[OF assms], auto simp: space_embed_measure)

lemma measurable_embed_measure2':
  assumes "inj_on f (space M)"
  shows "f \<in> measurable M (embed_measure M f)"
proof-
  {
    fix A assume A: "A \<in> sets M"
    also from this have "A = A \<inter> space M" by auto
    also have "... = f -` f ` A \<inter> space M" using A assms
      by (auto dest: inj_onD sets.sets_into_space)
    finally have "f -` f ` A \<inter> space M \<in> sets M" .
  }
  thus ?thesis using assms unfolding embed_measure_def
    by (intro measurable_measure_of) (auto dest: sets.sets_into_space)
qed

lemma measurable_embed_measure2[measurable]:
  assumes [simp]: "inj f" shows "f \<in> measurable M (embed_measure M f)"
  by (auto simp: inj_vimage_image_eq embed_measure_def
           intro!: measurable_measure_of dest: sets.sets_into_space)

lemma embed_measure_eq_distr':
  assumes "inj_on f (space M)"
  shows "embed_measure M f = distr M (embed_measure M f) f"
proof-
  have "distr M (embed_measure M f) f =
            measure_of (f ` space M) {f ` A |A. A \<in> sets M}
                       (\<lambda>A. emeasure M (f -` A \<inter> space M))" unfolding distr_def
      by (simp add: space_embed_measure sets_embed_measure'[OF assms])
  also have "... = embed_measure M f" unfolding embed_measure_def ..
  finally show ?thesis ..
qed

lemma embed_measure_eq_distr:
    "inj f \<Longrightarrow> embed_measure M f = distr M (embed_measure M f) f"
  by (rule embed_measure_eq_distr') (auto intro!: inj_onI dest: injD)

lemma emeasure_embed_measure':
    assumes "inj_on f (space M)" "A \<in> sets (embed_measure M f)"
    shows "emeasure (embed_measure M f) A = emeasure M (f -` A \<inter> space M)"
  by (subst embed_measure_eq_distr'[OF assms(1)])
     (simp add: emeasure_distr[OF measurable_embed_measure2'[OF assms(1)] assms(2)])

lemma emeasure_embed_measure:
    assumes "inj f" "A \<in> sets (embed_measure M f)"
    shows "emeasure (embed_measure M f) A = emeasure M (f -` A \<inter> space M)"
 using assms by (intro emeasure_embed_measure') (auto intro!: inj_onI dest: injD)

lemma embed_measure_comp:
  assumes [simp]: "inj f" "inj g"
  shows "embed_measure (embed_measure M f) g = embed_measure M (g \<circ> f)"
proof-
  have [simp]: "inj (\<lambda>x. g (f x))" by (subst o_def[symmetric]) (auto intro: inj_comp)
  have "embed_measure (embed_measure M f) g =
            distr M (embed_measure (embed_measure M f) g) (g \<circ> f)"
      by (subst (1 2) embed_measure_eq_distr)
         (simp_all add: distr_distr sets_embed_measure cong: distr_cong)
  also have "... = embed_measure M (g \<circ> f)"
      by (subst (3) embed_measure_eq_distr, simp add: o_def, rule distr_cong)
         (auto simp: sets_embed_measure o_def image_image[symmetric]
               intro: inj_comp cong: distr_cong)
  finally show ?thesis .
qed

lemma sigma_finite_embed_measure:
  assumes "sigma_finite_measure M" and inj: "inj f"
  shows "sigma_finite_measure (embed_measure M f)"
proof
  case goal1
  from assms(1) interpret sigma_finite_measure M .
  from sigma_finite_countable obtain A where
      A_props: "countable A" "A \<subseteq> sets M" "\<Union>A = space M" "\<And>X. X\<in>A \<Longrightarrow> emeasure M X \<noteq> \<infinity>" by blast
  show ?case
  proof (intro exI[of _ "op ` f`A"] conjI allI)
    from A_props show "countable (op ` f`A)" by auto
    from inj and A_props show "op ` f`A \<subseteq> sets (embed_measure M f)"
      by (auto simp: sets_embed_measure)
    from A_props and inj show "\<Union>(op ` f`A) = space (embed_measure M f)"
      by (auto simp: space_embed_measure intro!: imageI)
    from A_props and inj show "\<forall>a\<in>op ` f ` A. emeasure (embed_measure M f) a \<noteq> \<infinity>"
      by (intro ballI, subst emeasure_embed_measure)
         (auto simp: inj_vimage_image_eq intro: in_sets_embed_measure)
  qed
qed

lemma embed_measure_count_space:
    "inj f \<Longrightarrow> embed_measure (count_space A) f = count_space (f`A)"
apply (subst count_space_image, assumption)
apply (subst (1) embed_measure_eq_distr, assumption)
apply (rule distr_cong, simp, subst sets_embed_measure)
apply (auto elim: subset_imageE)
done

lemma sets_embed_measure_alt:
    "inj f \<Longrightarrow> sets (embed_measure M f) = (op`f) ` sets M"
  by (auto simp: sets_embed_measure)

lemma emeasure_embed_measure_image':
  assumes "inj_on f (space M)" "X \<in> sets M"
  shows "emeasure (embed_measure M f) (f`X) = emeasure M X"
proof-
  from assms have "emeasure (embed_measure M f) (f`X) = emeasure M (f -` f ` X \<inter> space M)"
    by (subst emeasure_embed_measure') (auto simp: sets_embed_measure')
  also from assms have "f -` f ` X \<inter> space M = X" by (auto dest: inj_onD sets.sets_into_space)
  finally show ?thesis .
qed

lemma emeasure_embed_measure_image:
    "inj f \<Longrightarrow> X \<in> sets M \<Longrightarrow> emeasure (embed_measure M f) (f`X) = emeasure M X"
  by (simp_all add: emeasure_embed_measure in_sets_embed_measure inj_vimage_image_eq)

lemma embed_measure_eq_iff:
  assumes "inj f"
  shows "embed_measure A f = embed_measure B f \<longleftrightarrow> A = B" (is "?M = ?N \<longleftrightarrow> _")
proof
  from assms have I: "inj (op` f)" by (auto intro: injI dest: injD)
  assume asm: "?M = ?N"
  hence "sets (embed_measure A f) = sets (embed_measure B f)" by simp
  with assms have "sets A = sets B" by (simp only: I inj_image_eq_iff sets_embed_measure_alt)
  moreover {
    fix X assume "X \<in> sets A"
    from asm have "emeasure ?M (f`X) = emeasure ?N (f`X)" by simp
    with `X \<in> sets A` and `sets A = sets B` and assms
        have "emeasure A X = emeasure B X" by (simp add: emeasure_embed_measure_image)
  }
  ultimately show "A = B" by (rule measure_eqI)
qed simp

lemma the_inv_into_in_Pi: "inj_on f A \<Longrightarrow> the_inv_into A f \<in> f ` A \<rightarrow> A"
  by (auto simp: the_inv_into_f_f)

lemma map_prod_image: "map_prod f g ` (A \<times> B) = (f`A) \<times> (g`B)"
  using map_prod_surj_on[OF refl refl] .

lemma map_prod_vimage: "map_prod f g -` (A \<times> B) = (f-`A) \<times> (g-`B)"
  by auto

lemma embed_measure_prod:
  assumes f: "inj f" and g: "inj g" and [simp]: "sigma_finite_measure M" "sigma_finite_measure N"
  shows "embed_measure M f \<Otimes>\<^sub>M embed_measure N g = embed_measure (M \<Otimes>\<^sub>M N) (\<lambda>(x, y). (f x, g y))"
    (is "?L = _")
  unfolding map_prod_def[symmetric]
proof (rule pair_measure_eqI)
  have fg[simp]: "\<And>A. inj_on (map_prod f g) A" "\<And>A. inj_on f A" "\<And>A. inj_on g A"
    using f g by (auto simp: inj_on_def)

  show sets: "sets ?L = sets (embed_measure (M \<Otimes>\<^sub>M N) (map_prod f g))"
    unfolding map_prod_def[symmetric]
    apply (simp add: sets_pair_eq_sets_fst_snd sets_embed_eq_vimage_algebra
      cong: vimage_algebra_cong)
    apply (subst vimage_algebra_Sup_sigma)
    apply (simp_all add: space_pair_measure[symmetric])
    apply (auto simp add: the_inv_into_f_f
                simp del: map_prod_simp
                del: prod_fun_imageE) []
    apply (subst (1 2 3 4 ) vimage_algebra_vimage_algebra)
    apply (simp_all add: the_inv_into_in_Pi Pi_iff[of snd] Pi_iff[of fst] space_pair_measure)
    apply (simp_all add: Pi_iff[of snd] Pi_iff[of fst] the_inv_into_in_Pi vimage_algebra_vimage_algebra
       space_pair_measure[symmetric] map_prod_image[symmetric])
    apply (intro arg_cong[where f=sets] arg_cong[where f=Sup_sigma] arg_cong2[where f=insert] vimage_algebra_cong)
    apply (auto simp: map_prod_image the_inv_into_f_f
                simp del: map_prod_simp del: prod_fun_imageE)
    apply (simp_all add: the_inv_into_f_f space_pair_measure)
    done

  fix A B assume AB: "A \<in> sets (embed_measure M f)" "B \<in> sets (embed_measure N g)"
  moreover have "f -` A \<times> g -` B \<inter> space (M \<Otimes>\<^sub>M N) = (f -` A \<inter> space M) \<times> (g -` B \<inter> space N)"
    by (auto simp: space_pair_measure)
  ultimately show "emeasure (embed_measure M f) A * emeasure (embed_measure N g) B =
                     emeasure (embed_measure (M \<Otimes>\<^sub>M N) (map_prod f g)) (A \<times> B)"
    by (simp add: map_prod_vimage sets[symmetric] emeasure_embed_measure
                  sigma_finite_measure.emeasure_pair_measure_Times)
qed (insert assms, simp_all add: sigma_finite_embed_measure)

lemma density_embed_measure:
  assumes inj: "inj f" and Mg[measurable]: "g \<in> borel_measurable (embed_measure M f)"
  shows "density (embed_measure M f) g = embed_measure (density M (g \<circ> f)) f" (is "?M1 = ?M2")
proof (rule measure_eqI)
  fix X assume X: "X \<in> sets ?M1"
  from inj have Mf[measurable]: "f \<in> measurable M (embed_measure M f)"
    by (rule measurable_embed_measure2)
  from Mg and X have "emeasure ?M1 X = \<integral>\<^sup>+ x. g x * indicator X x \<partial>embed_measure M f"
    by (subst emeasure_density) simp_all
  also from X have "... = \<integral>\<^sup>+ x. g (f x) * indicator X (f x) \<partial>M"
    by (subst embed_measure_eq_distr[OF inj], subst nn_integral_distr)
       (auto intro!: borel_measurable_ereal_times borel_measurable_indicator)
  also have "... = \<integral>\<^sup>+ x. g (f x) * indicator (f -` X \<inter> space M) x \<partial>M"
    by (intro nn_integral_cong) (auto split: split_indicator)
  also from X have "... = emeasure (density M (g \<circ> f)) (f -` X \<inter> space M)"
    by (subst emeasure_density) (simp_all add: measurable_comp[OF Mf Mg] measurable_sets[OF Mf])
  also from X and inj have "... = emeasure ?M2 X"
    by (subst emeasure_embed_measure) (simp_all add: sets_embed_measure)
  finally show "emeasure ?M1 X = emeasure ?M2 X" .
qed (simp_all add: sets_embed_measure inj)

lemma density_embed_measure':
  assumes inj: "inj f" and inv: "\<And>x. f' (f x) = x" and Mg[measurable]: "g \<in> borel_measurable M"
  shows "density (embed_measure M f) (g \<circ> f') = embed_measure (density M g) f"
proof-
  have "density (embed_measure M f) (g \<circ> f') = embed_measure (density M (g \<circ> f' \<circ> f)) f"
    by (rule density_embed_measure[OF inj])
       (rule measurable_comp, rule measurable_embed_measure1, subst measurable_cong,
        rule inv, rule measurable_ident_sets, simp, rule Mg)
  also have "density M (g \<circ> f' \<circ> f) = density M g"
    by (intro density_cong) (subst measurable_cong, simp add: o_def inv, simp_all add: Mg inv)
  finally show ?thesis .
qed

lemma inj_on_image_subset_iff:
  assumes "inj_on f C" "A \<subseteq> C"  "B \<subseteq> C"
  shows "f ` A \<subseteq> f ` B \<longleftrightarrow> A \<subseteq> B"
proof (intro iffI subsetI)
  fix x assume A: "f ` A \<subseteq> f ` B" and B: "x \<in> A"
  from B have "f x \<in> f ` A" by blast
  with A have "f x \<in> f ` B" by blast
  then obtain y where "f x = f y" and "y \<in> B" by blast
  with assms and B have "x = y" by (auto dest: inj_onD)
  with `y \<in> B` show "x \<in> B" by simp
qed auto

lemma AE_embed_measure':
  assumes inj: "inj_on f (space M)"
  shows "(AE x in embed_measure M f. P x) \<longleftrightarrow> (AE x in M. P (f x))"
proof
  let ?M = "embed_measure M f"
  assume "AE x in ?M. P x"
  then obtain A where A_props: "A \<in> sets ?M" "emeasure ?M A = 0" "{x\<in>space ?M. \<not>P x} \<subseteq> A"
    by (force elim: AE_E)
  then obtain A' where A'_props: "A = f ` A'" "A' \<in> sets M" by (auto simp: sets_embed_measure' inj)
  moreover have B: "{x\<in>space ?M. \<not>P x} = f ` {x\<in>space M. \<not>P (f x)}"
    by (auto simp: inj space_embed_measure)
  from A_props(3) have "{x\<in>space M. \<not>P (f x)} \<subseteq> A'"
    by (subst (asm) B, subst (asm) A'_props, subst (asm) inj_on_image_subset_iff[OF inj])
       (insert A'_props, auto dest: sets.sets_into_space)
  moreover from A_props A'_props have "emeasure M A' = 0"
    by (simp add: emeasure_embed_measure_image' inj)
  ultimately show "AE x in M. P (f x)" by (intro AE_I)
next
  let ?M = "embed_measure M f"
  assume "AE x in M. P (f x)"
  then obtain A where A_props: "A \<in> sets M" "emeasure M A = 0" "{x\<in>space M. \<not>P (f x)} \<subseteq> A"
    by (force elim: AE_E)
  hence "f`A \<in> sets ?M" "emeasure ?M (f`A) = 0" "{x\<in>space ?M. \<not>P x} \<subseteq> f`A"
    by (auto simp: space_embed_measure emeasure_embed_measure_image' sets_embed_measure' inj)
  thus "AE x in ?M. P x" by (intro AE_I)
qed

lemma AE_embed_measure:
  assumes inj: "inj f"
  shows "(AE x in embed_measure M f. P x) \<longleftrightarrow> (AE x in M. P (f x))"
  using assms by (intro AE_embed_measure') (auto intro!: inj_onI dest: injD)

lemma has_density_embed_measure:
  assumes inj: "inj f" and inv: "\<And>x. x \<in> space N \<Longrightarrow> f' (f x) = x"
  shows "has_density (embed_measure M f) (embed_measure N f) (\<delta> \<circ> f') \<longleftrightarrow> has_density M N \<delta>"
        (is "has_density ?M' ?N' ?\<delta>' \<longleftrightarrow> has_density M N \<delta>")
proof
  assume dens: "has_density ?M' ?N' ?\<delta>'"
  show "has_density M N \<delta>"
  proof
    from dens show "space N \<noteq> {}" by (auto simp: space_embed_measure dest: has_densityD)
    from dens have M\<delta>f': "\<delta> \<circ> f' \<in> borel_measurable ?N'" by (rule has_densityD)
    hence M\<delta>f'f: "\<delta> \<circ> f' \<circ> f \<in> borel_measurable N"
      by (rule_tac measurable_comp, rule_tac measurable_embed_measure2[OF inj])
    thus M\<delta>: "\<delta> \<in> borel_measurable N" by (simp cong: measurable_cong add: inv)
    from dens have "embed_measure M f = density (embed_measure N f) (\<delta> \<circ> f')" by (rule has_densityD)
    also have "... = embed_measure (density N (\<delta> \<circ> f' \<circ> f)) f"
      by (simp only: density_embed_measure[OF inj M\<delta>f'])
    also have "density N (\<delta> \<circ> f' \<circ> f) = density N \<delta>"
      by (intro density_cong[OF M\<delta>f'f M\<delta>]) (simp_all add: inv)
    finally show "M = density N \<delta>" by (simp add: embed_measure_eq_iff[OF inj])
    fix x assume x: "x \<in> space N"
    with inv have "\<delta> x = ?\<delta>' (f x)" by simp
    also from x have "... \<ge> 0" by (intro has_densityD[OF dens]) (simp add: space_embed_measure)
    finally show "\<delta> x \<ge> 0" .
  qed
next
  assume dens: "has_density M N \<delta>"
  show "has_density ?M' ?N' ?\<delta>'"
  proof
    from dens show "space ?N' \<noteq> {}" by (auto simp: space_embed_measure dest: has_densityD)
    have Mf'f: "(\<lambda>x. f' (f x)) \<in> measurable N N" by (subst measurable_cong[OF inv]) simp_all
    from dens have M\<delta>: "\<delta> \<in> borel_measurable N" by (auto dest: has_densityD)
    from Mf'f and dens show M\<delta>f': "\<delta> \<circ> f' \<in> borel_measurable (embed_measure N f)"
      by (intro measurable_comp) (erule measurable_embed_measure1, rule has_densityD)
    have "embed_measure M f = embed_measure (density N \<delta>) f"
      by (simp only: has_densityD[OF dens])
    also from inv and dens and measurable_comp[OF Mf'f M\<delta>]
      have "density N \<delta> = density N (?\<delta>' \<circ> f)"
      by (intro density_cong[OF M\<delta>]) (simp add: o_def, simp add: inv o_def)
    also have "embed_measure (density N (?\<delta>' \<circ> f)) f = density (embed_measure N f) (\<delta> \<circ> f')"
      by (simp only: density_embed_measure[OF inj M\<delta>f', symmetric])
    finally show "embed_measure M f = density (embed_measure N f) (\<delta> \<circ> f')" .
    fix x assume "x \<in> space (embed_measure N f)"
    hence "f' x \<in> space N" by (auto simp: space_embed_measure inv)
    with dens show "?\<delta>' x \<ge> 0" by (auto dest: has_densityD)
  qed
qed

lemma has_density_embed_measure':
  assumes inj: "inj f" and inv: "\<And>x. x \<in> space N \<Longrightarrow> f' (f x) = x" and
          sets_M: "sets M = sets (embed_measure N f)"
  shows "has_density (distr M N f') N (\<delta> \<circ> f) \<longleftrightarrow> has_density M (embed_measure N f) \<delta>"
proof-
  have sets': "sets (embed_measure (distr M N f') f) = sets (embed_measure N f)"
    by (simp add: sets_embed_measure[OF inj])
  have Mff': "(\<lambda>x. f' (f x)) \<in> measurable N N" by (subst measurable_cong[OF inv]) simp_all
  have inv': "\<And>x. x \<in> space M \<Longrightarrow> f (f' x) = x"
    by (subst (asm) sets_eq_imp_space_eq[OF sets_M]) (auto simp: space_embed_measure inv)
  have "M = distr M (embed_measure (distr M N f') f) (\<lambda>x. f (f' x))"
    by (subst distr_cong[OF refl _ inv', of _ M]) (simp_all add: sets_embed_measure inj sets_M)
  also have "... = embed_measure (distr M N f') f"
    apply (subst (2) embed_measure_eq_distr[OF inj], subst distr_distr)
    apply (subst measurable_cong_sets[OF refl sets'], rule measurable_embed_measure2[OF inj])
    apply (subst measurable_cong_sets[OF sets_M refl], rule measurable_embed_measure1, rule Mff')
    apply (simp cong: distr_cong add: inv)
    done
  finally have M: "M = embed_measure (distr M N f') f" .
  show ?thesis by (subst (2) M, subst has_density_embed_measure[OF inj inv, symmetric])
                  (auto simp: space_embed_measure inv intro!: has_density_cong)
qed

lemma has_density_embed_measure'':
  assumes inj: "inj f" and inv: "\<And>x. x \<in> space N \<Longrightarrow> f' (f x) = x" and
          "has_density M (embed_measure N f) \<delta>"
  shows "has_density (distr M N f') N (\<delta> \<circ> f)"
proof (subst has_density_embed_measure')
  from assms(3) show "sets M = sets (embed_measure N f)" by (auto dest: has_densityD)
qed (insert assms)

lemma has_subprob_density_embed_measure'':
  assumes inj: "inj f" and inv: "\<And>x. x \<in> space N \<Longrightarrow> f' (f x) = x" and
          "has_subprob_density M (embed_measure N f) \<delta>"
  shows "has_subprob_density (distr M N f') N (\<delta> \<circ> f)"
proof (unfold has_subprob_density_def, intro conjI)
  from assms show "has_density (distr M N f') N (\<delta> \<circ> f)"
    by (intro has_density_embed_measure'' has_subprob_density_imp_has_density)
  from assms(3) have "sets M = sets (embed_measure N f)" by (auto dest: has_subprob_densityD)
  hence M: "measurable M = measurable (embed_measure N f)"
    by (intro ext measurable_cong_sets) simp_all
  have "(\<lambda>x. f' (f x)) \<in> measurable N N" by (simp cong: measurable_cong add: inv)
  moreover from assms have "space (embed_measure N f) \<noteq> {}"
    unfolding has_subprob_density_def has_density_def by simp
  ultimately show "subprob_space (distr M N f')" using assms
    by (intro subprob_space.subprob_space_distr has_subprob_densityD)
       (auto simp: M space_embed_measure intro!: measurable_embed_measure1 dest: has_subprob_densityD)
qed (insert assms)

end


(*  Title:      HOL/HOLCF/Bifinite.thy
    Author:     Brian Huffman
*)

section \<open>Profinite and bifinite cpos\<close>

theory Bifinite
imports Map_Functions "~~/src/HOL/Library/Countable"
begin

default_sort cpo

subsection \<open>Chains of finite deflations\<close>

locale approx_chain =
  fixes approx :: "nat \<Rightarrow> 'a \<rightarrow> 'a"
  assumes chain_approx [simp]: "chain (\<lambda>i. approx i)"
  assumes lub_approx [simp]: "(\<Squnion>i. approx i) = ID"
  assumes finite_deflation_approx [simp]: "\<And>i. finite_deflation (approx i)"
begin

lemma deflation_approx: "deflation (approx i)"
using finite_deflation_approx by (rule finite_deflation_imp_deflation)

lemma approx_idem: "approx i\<cdot>(approx i\<cdot>x) = approx i\<cdot>x"
using deflation_approx by (rule deflation.idem)

lemma approx_below: "approx i\<cdot>x \<sqsubseteq> x"
using deflation_approx by (rule deflation.below)

lemma finite_range_approx: "finite (range (\<lambda>x. approx i\<cdot>x))"
apply (rule finite_deflation.finite_range)
apply (rule finite_deflation_approx)
done

lemma compact_approx [simp]: "compact (approx n\<cdot>x)"
apply (rule finite_deflation.compact)
apply (rule finite_deflation_approx)
done

lemma compact_eq_approx: "compact x \<Longrightarrow> \<exists>i. approx i\<cdot>x = x"
by (rule admD2, simp_all)

end

subsection \<open>Omega-profinite and bifinite domains\<close>

class bifinite = pcpo +
  assumes bifinite: "\<exists>(a::nat \<Rightarrow> 'a \<rightarrow> 'a). approx_chain a"

class profinite = cpo +
  assumes profinite: "\<exists>(a::nat \<Rightarrow> 'a\<^sub>\<bottom> \<rightarrow> 'a\<^sub>\<bottom>). approx_chain a"

subsection \<open>Building approx chains\<close>

lemma approx_chain_iso:
  assumes a: "approx_chain a"
  assumes [simp]: "\<And>x. f\<cdot>(g\<cdot>x) = x"
  assumes [simp]: "\<And>y. g\<cdot>(f\<cdot>y) = y"
  shows "approx_chain (\<lambda>i. f oo a i oo g)"
proof -
  have 1: "f oo g = ID" by (simp add: cfun_eqI)
  have 2: "ep_pair f g" by (simp add: ep_pair_def)
  from 1 2 show ?thesis
    using a unfolding approx_chain_def
    by (simp add: lub_APP ep_pair.finite_deflation_e_d_p)
qed

lemma approx_chain_u_map:
  assumes "approx_chain a"
  shows "approx_chain (\<lambda>i. u_map\<cdot>(a i))"
  using assms unfolding approx_chain_def
  by (simp add: lub_APP u_map_ID finite_deflation_u_map)

lemma approx_chain_sfun_map:
  assumes "approx_chain a" and "approx_chain b"
  shows "approx_chain (\<lambda>i. sfun_map\<cdot>(a i)\<cdot>(b i))"
  using assms unfolding approx_chain_def
  by (simp add: lub_APP sfun_map_ID finite_deflation_sfun_map)

lemma approx_chain_sprod_map:
  assumes "approx_chain a" and "approx_chain b"
  shows "approx_chain (\<lambda>i. sprod_map\<cdot>(a i)\<cdot>(b i))"
  using assms unfolding approx_chain_def
  by (simp add: lub_APP sprod_map_ID finite_deflation_sprod_map)

lemma approx_chain_ssum_map:
  assumes "approx_chain a" and "approx_chain b"
  shows "approx_chain (\<lambda>i. ssum_map\<cdot>(a i)\<cdot>(b i))"
  using assms unfolding approx_chain_def
  by (simp add: lub_APP ssum_map_ID finite_deflation_ssum_map)

lemma approx_chain_cfun_map:
  assumes "approx_chain a" and "approx_chain b"
  shows "approx_chain (\<lambda>i. cfun_map\<cdot>(a i)\<cdot>(b i))"
  using assms unfolding approx_chain_def
  by (simp add: lub_APP cfun_map_ID finite_deflation_cfun_map)

lemma approx_chain_prod_map:
  assumes "approx_chain a" and "approx_chain b"
  shows "approx_chain (\<lambda>i. prod_map\<cdot>(a i)\<cdot>(b i))"
  using assms unfolding approx_chain_def
  by (simp add: lub_APP prod_map_ID finite_deflation_prod_map)

text \<open>Approx chains for countable discrete types.\<close>

definition discr_approx :: "nat \<Rightarrow> 'a::countable discr u \<rightarrow> 'a discr u"
  where "discr_approx = (\<lambda>i. \<Lambda>(up\<cdot>x). if to_nat (undiscr x) < i then up\<cdot>x else \<bottom>)"

lemma chain_discr_approx [simp]: "chain discr_approx"
unfolding discr_approx_def
by (rule chainI, simp add: monofun_cfun monofun_LAM)

lemma lub_discr_approx [simp]: "(\<Squnion>i. discr_approx i) = ID"
apply (rule cfun_eqI)
apply (simp add: contlub_cfun_fun)
apply (simp add: discr_approx_def)
apply (case_tac x, simp)
apply (rule lub_eqI)
apply (rule is_lubI)
apply (rule ub_rangeI, simp)
apply (drule ub_rangeD)
apply (erule rev_below_trans)
apply simp
apply (rule lessI)
done

lemma inj_on_undiscr [simp]: "inj_on undiscr A"
using Discr_undiscr by (rule inj_on_inverseI)

lemma finite_deflation_discr_approx: "finite_deflation (discr_approx i)"
proof
  fix x :: "'a discr u"
  show "discr_approx i\<cdot>x \<sqsubseteq> x"
    unfolding discr_approx_def
    by (cases x, simp, simp)
  show "discr_approx i\<cdot>(discr_approx i\<cdot>x) = discr_approx i\<cdot>x"
    unfolding discr_approx_def
    by (cases x, simp, simp)
  show "finite {x::'a discr u. discr_approx i\<cdot>x = x}"
  proof (rule finite_subset)
    let ?S = "insert (\<bottom>::'a discr u) ((\<lambda>x. up\<cdot>x) ` undiscr -` to_nat -` {..<i})"
    show "{x::'a discr u. discr_approx i\<cdot>x = x} \<subseteq> ?S"
      unfolding discr_approx_def
      by (rule subsetI, case_tac x, simp, simp split: if_split_asm)
    show "finite ?S"
      by (simp add: finite_vimageI)
  qed
qed

lemma discr_approx: "approx_chain discr_approx"
using chain_discr_approx lub_discr_approx finite_deflation_discr_approx
by (rule approx_chain.intro)

subsection \<open>Class instance proofs\<close>

instance bifinite \<subseteq> profinite
proof
  show "\<exists>(a::nat \<Rightarrow> 'a\<^sub>\<bottom> \<rightarrow> 'a\<^sub>\<bottom>). approx_chain a"
    using bifinite [where 'a='a]
    by (fast intro!: approx_chain_u_map)
qed

instance u :: (profinite) bifinite
  by standard (rule profinite)

text \<open>
  Types @{typ "'a \<rightarrow> 'b"} and @{typ "'a u \<rightarrow>! 'b"} are isomorphic.
\<close>

definition "encode_cfun = (\<Lambda> f. sfun_abs\<cdot>(fup\<cdot>f))"

definition "decode_cfun = (\<Lambda> g x. sfun_rep\<cdot>g\<cdot>(up\<cdot>x))"

lemma decode_encode_cfun [simp]: "decode_cfun\<cdot>(encode_cfun\<cdot>x) = x"
unfolding encode_cfun_def decode_cfun_def
by (simp add: eta_cfun)

lemma encode_decode_cfun [simp]: "encode_cfun\<cdot>(decode_cfun\<cdot>y) = y"
unfolding encode_cfun_def decode_cfun_def
apply (simp add: sfun_eq_iff strictify_cancel)
apply (rule cfun_eqI, case_tac x, simp_all)
done

instance cfun :: (profinite, bifinite) bifinite
proof
  obtain a :: "nat \<Rightarrow> 'a\<^sub>\<bottom> \<rightarrow> 'a\<^sub>\<bottom>" where a: "approx_chain a"
    using profinite ..
  obtain b :: "nat \<Rightarrow> 'b \<rightarrow> 'b" where b: "approx_chain b"
    using bifinite ..
  have "approx_chain (\<lambda>i. decode_cfun oo sfun_map\<cdot>(a i)\<cdot>(b i) oo encode_cfun)"
    using a b by (simp add: approx_chain_iso approx_chain_sfun_map)
  thus "\<exists>(a::nat \<Rightarrow> ('a \<rightarrow> 'b) \<rightarrow> ('a \<rightarrow> 'b)). approx_chain a"
    by - (rule exI)
qed

text \<open>
  Types @{typ "('a * 'b) u"} and @{typ "'a u \<otimes> 'b u"} are isomorphic.
\<close>

definition "encode_prod_u = (\<Lambda>(up\<cdot>(x, y)). (:up\<cdot>x, up\<cdot>y:))"

definition "decode_prod_u = (\<Lambda>(:up\<cdot>x, up\<cdot>y:). up\<cdot>(x, y))"

lemma decode_encode_prod_u [simp]: "decode_prod_u\<cdot>(encode_prod_u\<cdot>x) = x"
unfolding encode_prod_u_def decode_prod_u_def
by (case_tac x, simp, rename_tac y, case_tac y, simp)

lemma encode_decode_prod_u [simp]: "encode_prod_u\<cdot>(decode_prod_u\<cdot>y) = y"
unfolding encode_prod_u_def decode_prod_u_def
apply (case_tac y, simp, rename_tac a b)
apply (case_tac a, simp, case_tac b, simp, simp)
done

instance prod :: (profinite, profinite) profinite
proof
  obtain a :: "nat \<Rightarrow> 'a\<^sub>\<bottom> \<rightarrow> 'a\<^sub>\<bottom>" where a: "approx_chain a"
    using profinite ..
  obtain b :: "nat \<Rightarrow> 'b\<^sub>\<bottom> \<rightarrow> 'b\<^sub>\<bottom>" where b: "approx_chain b"
    using profinite ..
  have "approx_chain (\<lambda>i. decode_prod_u oo sprod_map\<cdot>(a i)\<cdot>(b i) oo encode_prod_u)"
    using a b by (simp add: approx_chain_iso approx_chain_sprod_map)
  thus "\<exists>(a::nat \<Rightarrow> ('a \<times> 'b)\<^sub>\<bottom> \<rightarrow> ('a \<times> 'b)\<^sub>\<bottom>). approx_chain a"
    by - (rule exI)
qed

instance prod :: (bifinite, bifinite) bifinite
proof
  show "\<exists>(a::nat \<Rightarrow> ('a \<times> 'b) \<rightarrow> ('a \<times> 'b)). approx_chain a"
    using bifinite [where 'a='a] and bifinite [where 'a='b]
    by (fast intro!: approx_chain_prod_map)
qed

instance sfun :: (bifinite, bifinite) bifinite
proof
  show "\<exists>(a::nat \<Rightarrow> ('a \<rightarrow>! 'b) \<rightarrow> ('a \<rightarrow>! 'b)). approx_chain a"
    using bifinite [where 'a='a] and bifinite [where 'a='b]
    by (fast intro!: approx_chain_sfun_map)
qed

instance sprod :: (bifinite, bifinite) bifinite
proof
  show "\<exists>(a::nat \<Rightarrow> ('a \<otimes> 'b) \<rightarrow> ('a \<otimes> 'b)). approx_chain a"
    using bifinite [where 'a='a] and bifinite [where 'a='b]
    by (fast intro!: approx_chain_sprod_map)
qed

instance ssum :: (bifinite, bifinite) bifinite
proof
  show "\<exists>(a::nat \<Rightarrow> ('a \<oplus> 'b) \<rightarrow> ('a \<oplus> 'b)). approx_chain a"
    using bifinite [where 'a='a] and bifinite [where 'a='b]
    by (fast intro!: approx_chain_ssum_map)
qed

lemma approx_chain_unit: "approx_chain (\<bottom> :: nat \<Rightarrow> unit \<rightarrow> unit)"
by (simp add: approx_chain_def cfun_eq_iff finite_deflation_bottom)

instance unit :: bifinite
  by standard (fast intro!: approx_chain_unit)

instance discr :: (countable) profinite
  by standard (fast intro!: discr_approx)

instance lift :: (countable) bifinite
proof
  note [simp] = cont_Abs_lift cont_Rep_lift Rep_lift_inverse Abs_lift_inverse
  obtain a :: "nat \<Rightarrow> ('a discr)\<^sub>\<bottom> \<rightarrow> ('a discr)\<^sub>\<bottom>" where a: "approx_chain a"
    using profinite ..
  hence "approx_chain (\<lambda>i. (\<Lambda> y. Abs_lift y) oo a i oo (\<Lambda> x. Rep_lift x))"
    by (rule approx_chain_iso) simp_all
  thus "\<exists>(a::nat \<Rightarrow> 'a lift \<rightarrow> 'a lift). approx_chain a"
    by - (rule exI)
qed

end


(*  Title:      ZF/Constructible/Reflection.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
*)

section \<open>The Reflection Theorem\<close>

theory Reflection imports Normal begin

lemma all_iff_not_ex_not: "(\<forall>x. P(x)) \<longleftrightarrow> (\<not> (\<exists>x. \<not> P(x)))"
  by blast

lemma ball_iff_not_bex_not: "(\<forall>x\<in>A. P(x)) \<longleftrightarrow> (\<not> (\<exists>x\<in>A. \<not> P(x)))"
  by blast

text\<open>From the notes of A. S. Kechris, page 6, and from
      Andrzej Mostowski, \emph{Constructible Sets with Applications},
      North-Holland, 1969, page 23.\<close>

subsection\<open>Basic Definitions\<close>

text\<open>First part: the cumulative hierarchy defining the class \<open>M\<close>.
To avoid handling multiple arguments, we assume that \<open>Mset(l)\<close> is
closed under ordered pairing provided \<open>l\<close> is limit.  Possibly this
could be avoided: the induction hypothesis \<^term>\<open>Cl_reflects\<close>
(in locale \<open>ex_reflection\<close>) could be weakened to
\<^term>\<open>\<forall>y\<in>Mset(a). \<forall>z\<in>Mset(a). P(\<langle>y,z\<rangle>) \<longleftrightarrow> Q(a,\<langle>y,z\<rangle>)\<close>, removing most
uses of \<^term>\<open>Pair_in_Mset\<close>.  But there isn't much point in doing so, since
ultimately the \<open>ex_reflection\<close> proof is packaged up using the
predicate \<open>Reflects\<close>.
\<close>
locale reflection =
  fixes Mset and M and Reflects
  assumes Mset_mono_le : "mono_le_subset(Mset)"
      and Mset_cont    : "cont_Ord(Mset)"
      and Pair_in_Mset : "\<lbrakk>x \<in> Mset(a); y \<in> Mset(a); Limit(a)\<rbrakk>
                          \<Longrightarrow> \<langle>x,y\<rangle> \<in> Mset(a)"
  defines "M(x) \<equiv> \<exists>a. Ord(a) \<and> x \<in> Mset(a)"
      and "Reflects(Cl,P,Q) \<equiv> Closed_Unbounded(Cl) \<and>
                              (\<forall>a. Cl(a) \<longrightarrow> (\<forall>x\<in>Mset(a). P(x) \<longleftrightarrow> Q(a,x)))"
  fixes F0 \<comment> \<open>ordinal for a specific value \<^term>\<open>y\<close>\<close>
  fixes FF \<comment> \<open>sup over the whole level, \<^term>\<open>y\<in>Mset(a)\<close>\<close>
  fixes ClEx \<comment> \<open>Reflecting ordinals for the formula \<^term>\<open>\<exists>z. P\<close>\<close>
  defines "F0(P,y) \<equiv> \<mu> b. (\<exists>z. M(z) \<and> P(\<langle>y,z\<rangle>)) \<longrightarrow>
                               (\<exists>z\<in>Mset(b). P(\<langle>y,z\<rangle>))"
      and "FF(P)   \<equiv> \<lambda>a. \<Union>y\<in>Mset(a). F0(P,y)"
      and "ClEx(P,a) \<equiv> Limit(a) \<and> normalize(FF(P),a) = a"

begin

lemma Mset_mono: "i\<le>j \<Longrightarrow> Mset(i) \<subseteq> Mset(j)"
  using Mset_mono_le by (simp add: mono_le_subset_def leI)

text\<open>Awkward: we need a version of \<open>ClEx_def\<close> as an equality
      at the level of classes, which do not really exist\<close>
lemma ClEx_eq:
     "ClEx(P) \<equiv> \<lambda>a. Limit(a) \<and> normalize(FF(P),a) = a"
by (simp add: ClEx_def [symmetric])

subsection\<open>Easy Cases of the Reflection Theorem\<close>

theorem Triv_reflection [intro]:
  "Reflects(Ord, P, \<lambda>a x. P(x))"
  by (simp add: Reflects_def)

theorem Not_reflection [intro]:
  "Reflects(Cl,P,Q) \<Longrightarrow> Reflects(Cl, \<lambda>x. \<not>P(x), \<lambda>a x. \<not>Q(a,x))"
  by (simp add: Reflects_def)

theorem And_reflection [intro]:
  "\<lbrakk>Reflects(Cl,P,Q); Reflects(C',P',Q')\<rbrakk>
      \<Longrightarrow> Reflects(\<lambda>a. Cl(a) \<and> C'(a), \<lambda>x. P(x) \<and> P'(x),
                                      \<lambda>a x. Q(a,x) \<and> Q'(a,x))"
  by (simp add: Reflects_def Closed_Unbounded_Int, blast)

theorem Or_reflection [intro]:
     "\<lbrakk>Reflects(Cl,P,Q); Reflects(C',P',Q')\<rbrakk>
      \<Longrightarrow> Reflects(\<lambda>a. Cl(a) \<and> C'(a), \<lambda>x. P(x) \<or> P'(x),
                                      \<lambda>a x. Q(a,x) \<or> Q'(a,x))"
by (simp add: Reflects_def Closed_Unbounded_Int, blast)

theorem Imp_reflection [intro]:
     "\<lbrakk>Reflects(Cl,P,Q); Reflects(C',P',Q')\<rbrakk>
      \<Longrightarrow> Reflects(\<lambda>a. Cl(a) \<and> C'(a),
                   \<lambda>x. P(x) \<longrightarrow> P'(x),
                   \<lambda>a x. Q(a,x) \<longrightarrow> Q'(a,x))"
by (simp add: Reflects_def Closed_Unbounded_Int, blast)

theorem Iff_reflection [intro]:
     "\<lbrakk>Reflects(Cl,P,Q); Reflects(C',P',Q')\<rbrakk>
      \<Longrightarrow> Reflects(\<lambda>a. Cl(a) \<and> C'(a),
                   \<lambda>x. P(x) \<longleftrightarrow> P'(x),
                   \<lambda>a x. Q(a,x) \<longleftrightarrow> Q'(a,x))"
by (simp add: Reflects_def Closed_Unbounded_Int, blast)

subsection\<open>Reflection for Existential Quantifiers\<close>

lemma F0_works:
  "\<lbrakk>y\<in>Mset(a); Ord(a); M(z); P(\<langle>y,z\<rangle>)\<rbrakk> \<Longrightarrow> \<exists>z\<in>Mset(F0(P,y)). P(\<langle>y,z\<rangle>)"
  unfolding F0_def M_def
  apply clarify
  apply (rule LeastI2)
    apply (blast intro: Mset_mono [THEN subsetD])
   apply (blast intro: lt_Ord2, blast)
  done

lemma Ord_F0 [intro,simp]: "Ord(F0(P,y))"
  by (simp add: F0_def)

lemma Ord_FF [intro,simp]: "Ord(FF(P,y))"
  by (simp add: FF_def)

lemma cont_Ord_FF: "cont_Ord(FF(P))"
  using Mset_cont by (simp add: cont_Ord_def FF_def, blast)

text\<open>Recall that \<^term>\<open>F0\<close> depends upon \<^term>\<open>y\<in>Mset(a)\<close>,
while \<^term>\<open>FF\<close> depends only upon \<^term>\<open>a\<close>.\<close>
lemma FF_works:
  "\<lbrakk>M(z); y\<in>Mset(a); P(\<langle>y,z\<rangle>); Ord(a)\<rbrakk> \<Longrightarrow> \<exists>z\<in>Mset(FF(P,a)). P(\<langle>y,z\<rangle>)"
  apply (simp add: FF_def)
  apply (simp_all add: cont_Ord_Union [of concl: Mset]
      Mset_cont Mset_mono_le not_emptyI)
  apply (blast intro: F0_works)
  done

lemma FFN_works:
     "\<lbrakk>M(z); y\<in>Mset(a); P(\<langle>y,z\<rangle>); Ord(a)\<rbrakk>
      \<Longrightarrow> \<exists>z\<in>Mset(normalize(FF(P),a)). P(\<langle>y,z\<rangle>)"
apply (drule FF_works [of concl: P], assumption+)
apply (blast intro: cont_Ord_FF le_normalize [THEN Mset_mono, THEN subsetD])
done

end

text\<open>Locale for the induction hypothesis\<close>

locale ex_reflection = reflection +
  fixes P  \<comment> \<open>the original formula\<close>
  fixes Q  \<comment> \<open>the reflected formula\<close>
  fixes Cl \<comment> \<open>the class of reflecting ordinals\<close>
  assumes Cl_reflects: "\<lbrakk>Cl(a); Ord(a)\<rbrakk> \<Longrightarrow> \<forall>x\<in>Mset(a). P(x) \<longleftrightarrow> Q(a,x)"

begin

lemma ClEx_downward:
     "\<lbrakk>M(z); y\<in>Mset(a); P(\<langle>y,z\<rangle>); Cl(a); ClEx(P,a)\<rbrakk>
      \<Longrightarrow> \<exists>z\<in>Mset(a). Q(a,\<langle>y,z\<rangle>)"
apply (simp add: ClEx_def, clarify)
apply (frule Limit_is_Ord)
apply (frule FFN_works [of concl: P], assumption+)
apply (drule Cl_reflects, assumption+)
apply (auto simp add: Limit_is_Ord Pair_in_Mset)
done

lemma ClEx_upward:
     "\<lbrakk>z\<in>Mset(a); y\<in>Mset(a); Q(a,\<langle>y,z\<rangle>); Cl(a); ClEx(P,a)\<rbrakk>
      \<Longrightarrow> \<exists>z. M(z) \<and> P(\<langle>y,z\<rangle>)"
apply (simp add: ClEx_def M_def)
apply (blast dest: Cl_reflects
             intro: Limit_is_Ord Pair_in_Mset)
done

text\<open>Class \<open>ClEx\<close> indeed consists of reflecting ordinals...\<close>
lemma ZF_ClEx_iff:
     "\<lbrakk>y\<in>Mset(a); Cl(a); ClEx(P,a)\<rbrakk>
      \<Longrightarrow> (\<exists>z. M(z) \<and> P(\<langle>y,z\<rangle>)) \<longleftrightarrow> (\<exists>z\<in>Mset(a). Q(a,\<langle>y,z\<rangle>))"
by (blast intro: dest: ClEx_downward ClEx_upward)

text\<open>...and it is closed and unbounded\<close>
lemma ZF_Closed_Unbounded_ClEx:
     "Closed_Unbounded(ClEx(P))"
apply (simp add: ClEx_eq)
apply (fast intro: Closed_Unbounded_Int Normal_imp_fp_Closed_Unbounded
                   Closed_Unbounded_Limit Normal_normalize)
done

end

text\<open>The same two theorems, exported to locale \<open>reflection\<close>.\<close>

context reflection
begin

text\<open>Class \<open>ClEx\<close> indeed consists of reflecting ordinals...\<close>
lemma ClEx_iff:
     "\<lbrakk>y\<in>Mset(a); Cl(a); ClEx(P,a);
        \<And>a. \<lbrakk>Cl(a); Ord(a)\<rbrakk> \<Longrightarrow> \<forall>x\<in>Mset(a). P(x) \<longleftrightarrow> Q(a,x)\<rbrakk>
      \<Longrightarrow> (\<exists>z. M(z) \<and> P(\<langle>y,z\<rangle>)) \<longleftrightarrow> (\<exists>z\<in>Mset(a). Q(a,\<langle>y,z\<rangle>))"
  unfolding ClEx_def FF_def F0_def M_def
apply (rule ex_reflection.ZF_ClEx_iff
  [OF ex_reflection.intro, OF reflection.intro ex_reflection_axioms.intro,
    of Mset Cl])
apply (simp_all add: Mset_mono_le Mset_cont Pair_in_Mset)
done

(*Alternative proof, less unfolding:
apply (rule Reflection.ZF_ClEx_iff [of Mset _ _ Cl, folded M_def])
apply (fold ClEx_def FF_def F0_def)
apply (rule ex_reflection.intro, assumption)
apply (simp add: ex_reflection_axioms.intro, assumption+)
*)

lemma Closed_Unbounded_ClEx:
     "(\<And>a. \<lbrakk>Cl(a); Ord(a)\<rbrakk> \<Longrightarrow> \<forall>x\<in>Mset(a). P(x) \<longleftrightarrow> Q(a,x))
      \<Longrightarrow> Closed_Unbounded(ClEx(P))"
  unfolding ClEx_eq FF_def F0_def M_def
apply (rule ex_reflection.ZF_Closed_Unbounded_ClEx [of Mset _ _ Cl])
apply (rule ex_reflection.intro, rule reflection_axioms)
apply (blast intro: ex_reflection_axioms.intro)
done

subsection\<open>Packaging the Quantifier Reflection Rules\<close>

lemma Ex_reflection_0:
     "Reflects(Cl,P0,Q0)
      \<Longrightarrow> Reflects(\<lambda>a. Cl(a) \<and> ClEx(P0,a),
                   \<lambda>x. \<exists>z. M(z) \<and> P0(\<langle>x,z\<rangle>),
                   \<lambda>a x. \<exists>z\<in>Mset(a). Q0(a,\<langle>x,z\<rangle>))"
apply (simp add: Reflects_def)
apply (intro conjI Closed_Unbounded_Int)
  apply blast
 apply (rule Closed_Unbounded_ClEx [of Cl P0 Q0], blast, clarify)
apply (rule_tac Cl=Cl in  ClEx_iff, assumption+, blast)
done

lemma All_reflection_0:
     "Reflects(Cl,P0,Q0)
      \<Longrightarrow> Reflects(\<lambda>a. Cl(a) \<and> ClEx(\<lambda>x.\<not>P0(x), a),
                   \<lambda>x. \<forall>z. M(z) \<longrightarrow> P0(\<langle>x,z\<rangle>),
                   \<lambda>a x. \<forall>z\<in>Mset(a). Q0(a,\<langle>x,z\<rangle>))"
apply (simp only: all_iff_not_ex_not ball_iff_not_bex_not)
apply (rule Not_reflection, drule Not_reflection, simp)
apply (erule Ex_reflection_0)
done

theorem Ex_reflection [intro]:
     "Reflects(Cl, \<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x)))
      \<Longrightarrow> Reflects(\<lambda>a. Cl(a) \<and> ClEx(\<lambda>x. P(fst(x),snd(x)), a),
                   \<lambda>x. \<exists>z. M(z) \<and> P(x,z),
                   \<lambda>a x. \<exists>z\<in>Mset(a). Q(a,x,z))"
by (rule Ex_reflection_0 [of _ " \<lambda>x. P(fst(x),snd(x))"
                               "\<lambda>a x. Q(a,fst(x),snd(x))", simplified])

theorem All_reflection [intro]:
     "Reflects(Cl,  \<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x)))
      \<Longrightarrow> Reflects(\<lambda>a. Cl(a) \<and> ClEx(\<lambda>x. \<not>P(fst(x),snd(x)), a),
                   \<lambda>x. \<forall>z. M(z) \<longrightarrow> P(x,z),
                   \<lambda>a x. \<forall>z\<in>Mset(a). Q(a,x,z))"
by (rule All_reflection_0 [of _ "\<lambda>x. P(fst(x),snd(x))"
                                "\<lambda>a x. Q(a,fst(x),snd(x))", simplified])

text\<open>And again, this time using class-bounded quantifiers\<close>

theorem Rex_reflection [intro]:
     "Reflects(Cl, \<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x)))
      \<Longrightarrow> Reflects(\<lambda>a. Cl(a) \<and> ClEx(\<lambda>x. P(fst(x),snd(x)), a),
                   \<lambda>x. \<exists>z[M]. P(x,z),
                   \<lambda>a x. \<exists>z\<in>Mset(a). Q(a,x,z))"
by (unfold rex_def, blast)

theorem Rall_reflection [intro]:
     "Reflects(Cl,  \<lambda>x. P(fst(x),snd(x)), \<lambda>a x. Q(a,fst(x),snd(x)))
      \<Longrightarrow> Reflects(\<lambda>a. Cl(a) \<and> ClEx(\<lambda>x. \<not>P(fst(x),snd(x)), a),
                   \<lambda>x. \<forall>z[M]. P(x,z),
                   \<lambda>a x. \<forall>z\<in>Mset(a). Q(a,x,z))"
by (unfold rall_def, blast)

text\<open>No point considering bounded quantifiers, where reflection is trivial.\<close>

subsection\<open>Simple Examples of Reflection\<close>

text\<open>Example 1: reflecting a simple formula.  The reflecting class is first
given as the variable \<open>?Cl\<close> and later retrieved from the final
proof state.\<close>
schematic_goal
     "Reflects(?Cl,
               \<lambda>x. \<exists>y. M(y) \<and> x \<in> y,
               \<lambda>a x. \<exists>y\<in>Mset(a). x \<in> y)"
by fast

text\<open>Problem here: there needs to be a conjunction (class intersection)
in the class of reflecting ordinals.  The \<^term>\<open>Ord(a)\<close> is redundant,
though harmless.\<close>
lemma
     "Reflects(\<lambda>a. Ord(a) \<and> ClEx(\<lambda>x. fst(x) \<in> snd(x), a),
               \<lambda>x. \<exists>y. M(y) \<and> x \<in> y,
               \<lambda>a x. \<exists>y\<in>Mset(a). x \<in> y)"
by fast

text\<open>Example 2\<close>
schematic_goal
     "Reflects(?Cl,
               \<lambda>x. \<exists>y. M(y) \<and> (\<forall>z. M(z) \<longrightarrow> z \<subseteq> x \<longrightarrow> z \<in> y),
               \<lambda>a x. \<exists>y\<in>Mset(a). \<forall>z\<in>Mset(a). z \<subseteq> x \<longrightarrow> z \<in> y)"
by fast

text\<open>Example 2'.  We give the reflecting class explicitly.\<close>
lemma
  "Reflects
    (\<lambda>a. (Ord(a) \<and>
          ClEx(\<lambda>x. \<not> (snd(x) \<subseteq> fst(fst(x)) \<longrightarrow> snd(x) \<in> snd(fst(x))), a)) \<and>
          ClEx(\<lambda>x. \<forall>z. M(z) \<longrightarrow> z \<subseteq> fst(x) \<longrightarrow> z \<in> snd(x), a),
            \<lambda>x. \<exists>y. M(y) \<and> (\<forall>z. M(z) \<longrightarrow> z \<subseteq> x \<longrightarrow> z \<in> y),
            \<lambda>a x. \<exists>y\<in>Mset(a). \<forall>z\<in>Mset(a). z \<subseteq> x \<longrightarrow> z \<in> y)"
by fast

text\<open>Example 2''.  We expand the subset relation.\<close>
schematic_goal
  "Reflects(?Cl,
        \<lambda>x. \<exists>y. M(y) \<and> (\<forall>z. M(z) \<longrightarrow> (\<forall>w. M(w) \<longrightarrow> w\<in>z \<longrightarrow> w\<in>x) \<longrightarrow> z\<in>y),
        \<lambda>a x. \<exists>y\<in>Mset(a). \<forall>z\<in>Mset(a). (\<forall>w\<in>Mset(a). w\<in>z \<longrightarrow> w\<in>x) \<longrightarrow> z\<in>y)"
by fast

text\<open>Example 2'''.  Single-step version, to reveal the reflecting class.\<close>
schematic_goal
     "Reflects(?Cl,
               \<lambda>x. \<exists>y. M(y) \<and> (\<forall>z. M(z) \<longrightarrow> z \<subseteq> x \<longrightarrow> z \<in> y),
               \<lambda>a x. \<exists>y\<in>Mset(a). \<forall>z\<in>Mset(a). z \<subseteq> x \<longrightarrow> z \<in> y)"
apply (rule Ex_reflection)
txt\<open>
@{goals[display,indent=0,margin=60]}
\<close>
apply (rule All_reflection)
txt\<open>
@{goals[display,indent=0,margin=60]}
\<close>
apply (rule Triv_reflection)
txt\<open>
@{goals[display,indent=0,margin=60]}
\<close>
done

text\<open>Example 3.  Warning: the following examples make sense only
if \<^term>\<open>P\<close> is quantifier-free, since it is not being relativized.\<close>
schematic_goal
     "Reflects(?Cl,
               \<lambda>x. \<exists>y. M(y) \<and> (\<forall>z. M(z) \<longrightarrow> z \<in> y \<longleftrightarrow> z \<in> x \<and> P(z)),
               \<lambda>a x. \<exists>y\<in>Mset(a). \<forall>z\<in>Mset(a). z \<in> y \<longleftrightarrow> z \<in> x \<and> P(z))"
by fast

text\<open>Example 3'\<close>
schematic_goal
     "Reflects(?Cl,
               \<lambda>x. \<exists>y. M(y) \<and> y = Collect(x,P),
               \<lambda>a x. \<exists>y\<in>Mset(a). y = Collect(x,P))"
by fast

text\<open>Example 3''\<close>
schematic_goal
     "Reflects(?Cl,
               \<lambda>x. \<exists>y. M(y) \<and> y = Replace(x,P),
               \<lambda>a x. \<exists>y\<in>Mset(a). y = Replace(x,P))"
by fast

text\<open>Example 4: Axiom of Choice.  Possibly wrong, since \<open>\<Pi>\<close> needs
to be relativized.\<close>
schematic_goal
     "Reflects(?Cl,
               \<lambda>A. 0\<notin>A \<longrightarrow> (\<exists>f. M(f) \<and> f \<in> (\<Prod>X \<in> A. X)),
               \<lambda>a A. 0\<notin>A \<longrightarrow> (\<exists>f\<in>Mset(a). f \<in> (\<Prod>X \<in> A. X)))"
by fast

end

end


\<^marker>\<open>creator "Kevin Kappelmann"\<close>
subsection \<open>Injective\<close>
theory SBinary_Relations_Injective
  imports
    HOL_Basics.Functions_Monotone
    SBinary_Relation_Functions
begin

consts set_injective_on :: "'a \<Rightarrow> set \<Rightarrow> bool"

overloading
  set_injective_on_pred \<equiv> "set_injective_on :: (set \<Rightarrow> bool) \<Rightarrow> set \<Rightarrow> bool"
  set_injective_on_set \<equiv> "set_injective_on :: set \<Rightarrow> set \<Rightarrow> bool"
begin
  definition "set_injective_on_pred P R \<equiv>
    \<forall>x x' y. P x \<and> P x' \<and> \<langle>x, y\<rangle> \<in> R \<and> \<langle>x', y\<rangle> \<in> R \<longrightarrow> x = x'"
  definition "set_injective_on_set B R \<equiv> set_injective_on (mem_of B) R"
end

lemma set_injective_on_set_iff_set_injective_on [iff]:
  "set_injective_on B R \<longleftrightarrow> set_injective_on (mem_of B) R"
  unfolding set_injective_on_set_def by simp

lemma set_injective_onI [intro]:
  assumes "\<And>x x' y. P x \<Longrightarrow> P x' \<Longrightarrow> \<langle>x, y\<rangle> \<in> R \<Longrightarrow> \<langle>x', y\<rangle> \<in> R \<Longrightarrow> x = x'"
  shows "set_injective_on P R"
  using assms unfolding set_injective_on_pred_def by blast

lemma set_injective_onD:
  assumes "set_injective_on P R"
  and "P x" "P x'"
  and "\<langle>x, y\<rangle> \<in> R" "\<langle>x', y\<rangle> \<in> R"
  shows "x = x'"
  using assms unfolding set_injective_on_pred_def by blast

lemma antimono_set_injective_on_pred:
  "antimono (\<lambda>P. set_injective_on (P :: set \<Rightarrow> bool) R)"
  by (intro antimonoI) (auto dest: set_injective_onD)

lemma antimono_set_injective_on_set:
  "antimono (\<lambda>R. set_injective_on (P :: set \<Rightarrow> bool) R)"
  by (intro antimonoI) (auto dest: set_injective_onD)

lemma set_injective_on_compI:
  fixes P :: "set \<Rightarrow> bool"
  assumes "set_injective_on (dom R) R"
  and "set_injective_on (rng R \<inter> dom S) S"
  shows "set_injective_on P (S \<circ> R)"
  using assms by (auto dest: set_injective_onD)

end


header "Ramsey's Theorem"

theory Ramsey
imports Main "~~/src/HOL/Library/Infinite_Set"
begin

declare [[simp_depth_limit = 5]]

subsection "Library lemmas"

lemma infinite_inj_infinite_image: "infinite Z ==> inj_on f Z ==> infinite (f ` Z)"
  apply(rule ccontr)
  apply(simp)
  apply(force dest: finite_imageD)
  done

lemma infinite_dom_finite_rng: "[| infinite A; finite (f ` A) |] ==> ? b : f ` A. infinite {a : A. f a = b}"
  apply(rule ccontr) apply(simp)
  apply(subgoal_tac "UNION A (% b. {a : A. f a = f b}) = A") prefer 2 apply(blast)
  apply(subgoal_tac "(UN c : f ` A. {a : A. f a = c})= (UN b:A. {a : A. f a = f b})") prefer 2 apply(blast)
  apply(subgoal_tac "finite (UN c:f ` A. {a : A. f a = c})") apply(force)
  apply(rule finite_UN_I)
  apply(auto)
  done

lemma infinite_mem: "infinite X ==> ? x. x : X"
  apply(rule ccontr)
  apply(force)
  done

subsection "Dependent Choice Variant"

  -- "%%cut choice"
primrec choice :: "('a => bool) => ('a => 'a => bool) => nat => 'a" where
  "choice P R 0 = (SOME x. P x)"
| "choice P R (Suc n) = (let x = choice P R n in SOME y. P y & R x y)"
  -- "%%tuc"

lemma dc: "
  (! x y z. R x y & R y z --> R x z)
  & (? x0. P x0)
  & (! x. P x --> (? y. P y & R x y))
  --> (? f::nat=>'b. (! n. P (f n)) & (! n m. R (f n) (f (n+m+1))))
 "
  apply(intro allI impI, elim exE conjE)
  apply(rule_tac x="choice P R" in exI)
  apply(subgoal_tac "(ALL n. P (choice P R n))") prefer 2
  apply(rule, induct_tac n)
  apply(simp add: Let_def) apply(rule someI_ex) apply(blast)
  apply(simp add: Let_def) apply(subgoal_tac "P (SOME y. P y & R (choice P R na) y) & R (choice P R na) (SOME y. P y & R (choice P R na) y)") apply(blast) apply(rule someI_ex) apply(blast)
  apply(rule) apply(assumption)

  apply(subgoal_tac "! n. R (choice P R n) (choice P R (Suc n))") prefer 2
  apply(rule)
  apply(simp add: Let_def)
  apply(subgoal_tac "P (SOME y. P y & R (choice P R n) y) &  R (choice P R n) (SOME y. P y & R (choice P R n) y)") apply(blast)
  apply(rule someI_ex) apply(force)

  apply(rule) apply(rule)
  apply(induct_tac m)
  apply(force)
  apply(drule_tac x="n+na+1" in spec) back
  apply(force simp del: choice.simps)
  done

subsection "Partitions"

(* expect Y infinite *)
definition
  part :: "nat => nat => 'a set => ('a set => nat) => bool" where
  "part r s Y f = (! X. X <= Y & finite X & card X = r --> f X < s)"

lemma part: "[| infinite YY; part (Suc n) s YY f; yy : YY |] ==> part n s (YY - {yy}) (%u. f (insert yy u))"
  apply(simp add: part_def)
  apply(intro allI impI, elim exE conjE)
  apply(drule_tac x="insert yy X" in spec)
  apply(force simp:card_Diff_singleton_if)
  done

lemma part_subset: "part (Suc n) s YY f ==> Y <= YY ==> part (Suc n) s Y f"
  apply(simp add: part_def)
  apply(blast)
  done

subsection "Ramsey's theorem"

(* state theorem so it doesn't require part definition *)

  apply(intro allI impI)
  apply(rule_tac x="YY" in exI)
  apply(rule_tac x="f {}" in exI)
  apply(force simp: part_def)

  apply(intro allI impI) apply(elim exE conjE)

  (* now get the infinite g *)
  apply(subgoal_tac "
    ? g.
    (! m::nat. let (y,Y,t) = (g m) in
    y : YY & y ~: Y
    & Y <= YY & infinite Y
    & t < s
    & (! X. X <= Y & finite X & card X = nat --> (f o insert y) X = t))
    & (! m m'.
    let (y,Y,t) = (g m) in
    let (y',Y',t') =(g (m+m'+1)) in
    y' : Y
    & Y' <= Y
    )
    ")
   prefer 2
   apply(cut_tac

     P = "% gn.
     let (y,Y,t) = (gn) in
     y : YY & y ~: Y
     & Y <= YY & infinite Y
     & t < s
     & (! X. X <= Y & finite X & card X = nat --> (f o insert y) X = t)
     "

     and R = "% gn gn'.
     let (y,Y,t) = (gn) in
     let (y',Y',t') =(gn') in
     y' : Y
     & Y' <= Y
     "

     in dc)
   apply(erule impE)
   (* 3 *)
    apply(intro conjI)
      apply(intro allI impI, elim conjE) apply(simp add: Let_def split_beta) apply(blast)
     apply(subgoal_tac "? yy. yy : YY") prefer 2 apply(rule infinite_mem) apply(assumption)
     apply(elim exE conjE)
     apply(drule_tac x="YY - {yy}" in spec) apply(drule_tac x="f o insert yy" in spec)
     apply(erule impE) apply(simp) apply(rule part) apply(assumption+)
     apply(elim exE conjE)
     apply(rule_tac x="(yy,Y',t')" in exI) apply(simp) apply(blast)
    apply(intro allI impI)
    apply(case_tac x) apply(rename_tac yx b Yx tx)
    apply(subgoal_tac "? yx'. yx' : Yx") prefer 2 apply(rule infinite_mem) apply(force)
    apply(elim exE conjE)
    apply(drule_tac x="Yx - {yx'}" in spec)
    apply(drule_tac x="f o insert yx'" in spec)
    apply(erule impE) apply(simp) apply(elim exE conjE) apply(rule part) apply(assumption+)
    apply(rule part_subset) apply(assumption) apply(assumption) apply(assumption)
    apply(elim exE conjE)
    apply(rule_tac x="(yx',Y',t')" in exI) apply(simp) apply(blast)
   apply(assumption)

  apply(elim exE conjE)

  apply(subgoal_tac "? s'. s' < s & infinite {n. (% n. let (y,Y,t) = g n in t) n = s'}") prefer 2

  apply(subgoal_tac "? s' : ((% n. let (Y, y, t) = g n in t) ` UNIV). infinite {n : UNIV. (let (Y, y, t) = g n in t) = s'}") prefer 2
  apply(rule infinite_dom_finite_rng) apply(simp)
  apply(simp (no_asm) add: finite_nat_iff_bounded)
  apply(rule_tac x=s in exI)
  apply(rule)
  apply(simp add: image_iff) apply(elim exE conjE)
  apply(drule_tac x=xa in spec) apply(force simp add: Let_def split_beta)
  apply(elim bexE conjE) apply(rule_tac x=s' in exI) apply(simp)
  apply(simp add: image_iff) apply(elim exE conjE) apply(drule_tac x=x in spec) apply(force simp: Let_def split_beta)

  apply(elim exE conjE)
  apply(rule_tac x="(% n. let (y,Y,t) = g n in y) ` {n. (% n. let (y,Y,t) = g n in t) n = s'}" in exI)
  apply(rule_tac x=s' in exI)
  (* lift this because it is needed in later subgoals *)
  apply(subgoal_tac "inj (% n. let (y, Y, t) = g n in y)") prefer 2
  apply(simp add: inj_on_def)
  (* minor optimisation *)
  apply(subgoal_tac "ALL x y. x < y & (let (y, Y, t) = g x in y) = (let (y, Y, t) = g y in y) --> x = y")
  apply(intro allI impI)
  apply(subgoal_tac "x < y | x = y | y < x") prefer 2 apply(arith)
  apply(elim disjE)
  apply(drule_tac x=x in spec) back back apply(drule_tac x=y in spec) back back apply(force simp: Let_def)
  apply(assumption)
  apply(drule_tac x=y in spec) back back apply(drule_tac x=x in spec) back back apply(force simp: Let_def)
  apply(intro allI impI)
  apply(drule_tac x=x in spec) apply(drule_tac x=x in spec) apply(drule_tac x="y-(Suc x)" in spec) apply(force simp: Let_def)

  apply(intro allI conjI)

  apply(drule_tac x=xa in spec)
  apply(force simp add: Let_def split_beta)

  apply(rule infinite_inj_infinite_image) apply(assumption)
  apply(simp add: inj_on_def)

  apply(simp)

  (* difficult goal- need that the other members of X all occur in Ya *)
  apply(intro allI impI, elim exE conjE)
  apply(simp add: subset_image_iff) apply(elim exE conjE)
  apply(subgoal_tac "? a. a : AA & (! a'. a' : AA --> a <= a')") prefer 2 apply(rule not_empty_least) apply(force)
  apply(elim exE conjE)
  apply(case_tac "g a" rule: prod.exhaust)
  apply(rename_tac b) apply(case_tac b rule: prod.exhaust) apply(rename_tac ya b Ya ta)
  apply(subgoal_tac "ya : X") prefer 2 apply(force intro!: rev_image_eqI simp: Let_def)
  apply(drule_tac s=X in sym)
  apply(subgoal_tac "f X = (f o insert ya) (X - {ya})") apply(simp)
  apply(drule_tac x=a in spec)
  apply(simp add: Let_def) apply(elim exE conjE)
  apply(drule_tac x="X-{ya}" in spec) back apply(erule impE)
  apply(simp)
  apply(rule)
  apply(rule)
  apply(drule_tac t=X in sym) apply(simp)
  apply(simp add: image_iff) apply(elim bexE exE conjE) apply(rename_tac a')
  apply(subgoal_tac "a' ~= a") prefer 2 apply(force)
  apply(drule_tac x=a in spec)
  apply(drule_tac x="a'-Suc a" in spec) back
  apply(simp add: Let_def split_beta) apply(case_tac "g a'" rule: prod.exhaust) apply(case_tac ba rule: prod.exhaust) apply(rename_tac ya' ba Ya' ta') apply(simp add: Let_def split_beta)
  apply(drule_tac x=a' in spec) apply(erule impE) apply(force)
  apply(force)
  apply(force simp add: card_Diff_singleton_if)
  apply(subgoal_tac "ta = s'") apply(simp) apply(force)
  apply(simp) apply(rule_tac f=f in arg_cong) apply(force)
  done

end


section \<open>Shallow embedding of HyperCTL*\<close>

(*<*)
theory Shallow
imports Prelim
begin
(*>*)

text\<open>We define a notion of ``shallow'' HyperCTL* formula (sfmla) that captures
HyperCTL* binders as meta-level HOL binders. We also define a proof system for this
shallow embedding.\<close>

subsection\<open>Kripke structures and paths\<close>

type_synonym ('state,'aprop) path = "('state \<times> 'aprop set) stream"

abbreviation stateOf where "stateOf \<pi> \<equiv> fst (shd \<pi>)"
abbreviation apropsOf where "apropsOf \<pi> \<equiv> snd (shd \<pi>)"

locale Kripke =
  fixes S :: "'state set" and s0 :: 'state and \<delta> :: "'state \<Rightarrow> 'state set"
  and AP :: "'aprop set" and L :: "'state \<Rightarrow> 'aprop set"
  assumes s0: "s0 \<in> S" and \<delta>: "\<And> s. s \<in> S \<Longrightarrow> \<delta> s \<subseteq> S"
  and L : "\<And> s. s \<in> S \<Longrightarrow> L s \<subseteq> AP"
begin

text\<open>Well-formed paths\<close>

coinductive wfp :: "'aprop set \<Rightarrow> ('state,'aprop) path \<Rightarrow> bool"
for AP' :: "'aprop set"
where
intro:
"\<lbrakk>s \<in> S; A \<subseteq> AP'; A \<inter> AP = L s; stateOf \<pi> \<in> \<delta> s; wfp AP' \<pi>\<rbrakk>
 \<Longrightarrow>
 wfp AP' ((s,A) ## \<pi>)"

lemma wfp:
"wfp AP' \<pi> \<longleftrightarrow>
 (\<forall> i. fst (\<pi> !! i) \<in> S \<and> snd (\<pi> !! i) \<subseteq> AP' \<and>
       snd (\<pi> !! i) \<inter> AP = L (fst (\<pi> !! i)) \<and>
       fst (\<pi> !! (Suc i)) \<in> \<delta> (fst (\<pi> !! i))
 )"
(is "?L \<longleftrightarrow> (\<forall> i. ?R i)")
proof (intro iffI allI)
  fix i assume ?L thus "?R i"
  apply(induction i arbitrary: \<pi>)
  by (metis snth.simps fst_conv snd_conv stream.sel wfp.cases)+
next
  assume R: "\<forall> i. ?R i"  thus ?L
  apply (coinduct)
  using s0 fst_conv snd_conv snth.simps stream.sel
  by (metis inf_commute stream.collapse surj_pair)
qed

lemma wfp_sdrop[simp]:
"wfp AP' \<pi> \<Longrightarrow> wfp AP' (sdrop i \<pi>)"
unfolding wfp by simp (metis sdrop_add sdrop_simps(1))

(*<*)
end (* context Kripke *)
(*>*)

text\<open>end-of-context Kripke\<close>

subsection\<open>Shallow representations of formulas\<close>

text\<open>A shallow (representation of a) HyperCTL* formula will be a predicate on lists of paths.
The atomic formulas (operator $\textit{atom}$) are parameterized by atomic propositions (as customary in temporal logic),
and additionally by a number indicating the position, in the list of paths, of the path to which the atomic proposition
refers -- for example, $\textit{atom}\;a\;i$ holds for the list of paths $\pi l$ just in case proposition $a$ holds
at the first state of $\pi l!i$, the $i$'th path in $\pi l$.  The temporal operators $\textit{next}$ and $\textit{until}$ act on all the paths of the argument
list $\pi l$ synchronously.  Finally, the existential quantifier refers to the existence of a path whose origin state is that of
the last path in $\pi l$.

As an example: $\textit{exi}\; (\textit{exi}\; (\textit{until}\; (\textit{atom}\;a\;0)\;(\textit{atom}\;b\;1)))$ holds for the empty list
iff there exist two paths $\rho_0$ and $\rho_1$ such that, synchronously,
$a$ holds on $\rho_0$ until $b$ holds on $\rho_1$.  Another example will be the formula encoding Goguen-Meseguer noninterference.
\<close>

text\<open>Shallow HyperCTL* formulas:\<close>

type_synonym ('state,'aprop) sfmla = "('state,'aprop) path list \<Rightarrow> bool"

locale Shallow = Kripke S "s0" \<delta> AP L
  for S :: "'state set" and s0 :: 'state and \<delta> :: "'state \<Rightarrow> 'state set"
  and AP :: "'aprop set" and L :: "'state \<Rightarrow> 'aprop set"
+
  fixes AP' assumes AP_AP': "AP \<subseteq> AP'"
begin

text\<open>Primitive operators\<close>

(* I include false as a primitive since otherwise I would have to assume nonemptyness of
  the atomic propositions *)
definition fls :: "('state,'aprop) sfmla" where
"fls \<pi>l \<equiv> False"

definition atom :: "'aprop \<Rightarrow> nat \<Rightarrow> ('state,'aprop) sfmla" where
"atom a i \<pi>l \<equiv> a \<in> apropsOf (\<pi>l!i)"

definition neg :: "('state,'aprop) sfmla \<Rightarrow> ('state,'aprop) sfmla" where
"neg \<phi> \<pi>l \<equiv> \<not> \<phi> \<pi>l"

definition dis :: "('state,'aprop) sfmla \<Rightarrow> ('state,'aprop) sfmla \<Rightarrow> ('state,'aprop) sfmla" where
"dis \<phi> \<psi> \<pi>l \<equiv> \<phi> \<pi>l \<or> \<psi> \<pi>l"

definition "next" :: "('state,'aprop) sfmla \<Rightarrow> ('state,'aprop) sfmla" where
"next \<phi> \<pi>l \<equiv> \<phi> (map stl \<pi>l)"

definition until :: "('state,'aprop) sfmla \<Rightarrow> ('state,'aprop) sfmla \<Rightarrow> ('state,'aprop) sfmla" where
"until \<phi> \<psi> \<pi>l \<equiv>
 \<exists> i. \<psi> (map (sdrop i) \<pi>l) \<and> (\<forall> j \<in>{0..<i}. \<phi> (map (sdrop j) \<pi>l))"

definition exii :: "('state,'aprop) sfmla \<Rightarrow> ('state,'aprop) sfmla" where
"exii \<phi> \<pi>l \<equiv>
 \<exists> \<pi>. wfp AP' \<pi> \<and> stateOf \<pi> = (if \<pi>l \<noteq> [] then stateOf (last \<pi>l) else s0)
      \<and> \<phi> (\<pi>l @ [\<pi>])"

definition exi :: "(('state,'aprop) path \<Rightarrow> ('state,'aprop) sfmla) \<Rightarrow> ('state,'aprop) sfmla" where
"exi F \<pi>l \<equiv>
 \<exists> \<pi>. wfp AP' \<pi> \<and> stateOf \<pi> = (if \<pi>l \<noteq> [] then stateOf (last \<pi>l) else s0)
      \<and> F \<pi> \<pi>l"

text\<open>Derived operators\<close>

definition "tr \<equiv> neg fls"
definition "con \<phi> \<psi> \<equiv> neg (dis (neg \<phi>) (neg \<psi>))"
definition "imp \<phi> \<psi> \<equiv> dis (neg \<phi>) \<psi>"
definition "eq \<phi> \<psi> \<equiv> con (imp \<phi> \<psi>) (imp \<psi> \<phi>) "
definition "fall F \<equiv> neg (exi (\<lambda> \<pi>. neg (F \<pi>)))"
definition "ev \<phi> \<equiv> until tr \<phi>"
definition "alw \<phi> \<equiv> neg (ev (neg \<phi>))"
definition "wuntil \<phi> \<psi> \<equiv> dis (until \<phi> \<psi>) (alw \<phi>)"

lemmas main_op_defs =
fls_def atom_def neg_def dis_def next_def until_def exi_def

lemmas der_op_defs =
tr_def con_def imp_def eq_def ev_def alw_def wuntil_def fall_def

lemmas op_defs = main_op_defs der_op_defs

subsection\<open>Reasoning rules\<close>

text\<open>We provide introduction, elimination, unfolding and (co)induction rules
for the connectives and quantifiers.\<close>

text\<open>Boolean operators\<close>

lemma fls_elim[elim!]:
assumes "fls \<pi>l" shows \<phi>
using assms unfolding op_defs by auto

lemma tr_intro[intro!, simp]: "tr \<pi>l"
unfolding op_defs by auto

lemma dis_introL[intro]:
assumes "\<phi> \<pi>l" shows "dis \<phi> \<psi> \<pi>l"
using assms unfolding op_defs by auto

lemma dis_introR[intro]:
assumes "\<psi> \<pi>l" shows "dis \<phi> \<psi> \<pi>l"
using assms unfolding op_defs by auto

lemma dis_elim[elim]:
assumes "dis \<phi> \<psi> \<pi>l" and "\<phi> \<pi>l \<Longrightarrow> \<chi>" and "\<psi> \<pi>l \<Longrightarrow> \<chi>"
shows \<chi>
using assms unfolding op_defs by auto

lemma con_intro[intro!]:
assumes "\<phi> \<pi>l" and "\<psi> \<pi>l" shows "con \<phi> \<psi> \<pi>l"
using assms unfolding op_defs by auto

lemma con_elim[elim]:
assumes "con \<phi> \<psi> \<pi>l" and "\<phi> \<pi>l \<Longrightarrow> \<psi> \<pi>l \<Longrightarrow> \<chi>" shows \<chi>
using assms unfolding op_defs by auto

lemma neg_intro[intro!]:
assumes "\<phi> \<pi>l \<Longrightarrow> False"  shows "neg \<phi> \<pi>l"
using assms unfolding op_defs by auto

lemma neg_elim[elim]:
assumes "neg \<phi> \<pi>l" and "\<phi> \<pi>l"  shows \<chi>
using assms unfolding op_defs by auto

lemma imp_intro[intro!]:
assumes "\<phi> \<pi>l \<Longrightarrow> \<psi> \<pi>l"  shows "imp \<phi> \<psi> \<pi>l"
using assms unfolding op_defs by auto

lemma imp_elim[elim]:
assumes "imp \<phi> \<psi> \<pi>l" and "\<phi> \<pi>l" and "\<psi> \<pi>l \<Longrightarrow> \<chi>" shows \<chi>
using assms unfolding op_defs by auto

lemma imp_mp[elim]:
assumes "imp \<phi> \<psi> \<pi>l" and "\<phi> \<pi>l" shows "\<psi> \<pi>l"
using assms unfolding op_defs by auto

lemma eq_intro[intro!]:
assumes "\<phi> \<pi>l \<Longrightarrow> \<psi> \<pi>l" and "\<psi> \<pi>l \<Longrightarrow> \<phi> \<pi>l" shows "eq \<phi> \<psi> \<pi>l"
using assms unfolding op_defs by auto

lemma eq_elimL[elim]:
assumes "eq \<phi> \<psi> \<pi>l" and "\<phi> \<pi>l" and "\<psi> \<pi>l \<Longrightarrow> \<chi>" shows \<chi>
using assms unfolding op_defs by auto

lemma eq_elimR[elim]:
assumes "eq \<phi> \<psi> \<pi>l" and "\<psi> \<pi>l" and "\<phi> \<pi>l \<Longrightarrow> \<chi>" shows \<chi>
using assms unfolding op_defs by auto

lemma eq_equals: "eq \<phi> \<psi> \<pi>l \<longleftrightarrow> \<phi> \<pi>l = \<psi> \<pi>l"
by (metis eq_elimL eq_elimR eq_intro)

text\<open>Quantifiers\<close>

lemma exi_intro[intro]:
assumes "wfp AP' \<pi>"
and "\<pi>l \<noteq> [] \<Longrightarrow> stateOf \<pi> = stateOf (last \<pi>l)"
and "\<pi>l = [] \<Longrightarrow> stateOf \<pi> = s0"
and "F \<pi> \<pi>l"
shows "exi F \<pi>l"
using assms unfolding exi_def by auto

lemma exi_elim[elim]:
assumes "exi F \<pi>l"
and
"\<And> \<pi>. \<lbrakk>wfp AP' \<pi>; \<pi>l \<noteq> [] \<Longrightarrow> stateOf \<pi> = stateOf (last \<pi>l); \<pi>l = [] \<Longrightarrow> stateOf \<pi> = s0; F \<pi> \<pi>l\<rbrakk> \<Longrightarrow> \<chi>"
shows \<chi>
using assms unfolding exi_def by auto

lemma fall_intro[intro]:
assumes
"\<And> \<pi>. \<lbrakk>wfp AP' \<pi>; \<pi>l \<noteq> [] \<Longrightarrow> stateOf \<pi> = stateOf (last \<pi>l) ; \<pi>l = [] \<Longrightarrow> stateOf \<pi> = s0\<rbrakk>
       \<Longrightarrow>  F \<pi> \<pi>l"
shows "fall F \<pi>l"
using assms unfolding fall_def by (metis exi_def neg_def)

lemma fall_elim[elim]:
assumes "fall F \<pi>l"
and
"(\<And>\<pi>. \<lbrakk>wfp AP' \<pi>; \<pi>l \<noteq> [] \<Longrightarrow> stateOf \<pi> = stateOf (last \<pi>l); \<pi>l = [] \<Longrightarrow> stateOf \<pi> = s0\<rbrakk>
        \<Longrightarrow> F \<pi> \<pi>l)
  \<Longrightarrow> \<chi>"
shows \<chi>
using assms unfolding fall_def
by (metis exi_def neg_elim neg_intro)

text\<open>Temporal connectives\<close>

lemma next_intro[intro]:
assumes "\<phi> (map stl \<pi>l)"  shows "next \<phi> \<pi>l"
using assms unfolding op_defs by auto

lemma next_elim[elim]:
assumes "next \<phi> \<pi>l" and "\<phi> (map stl \<pi>l) \<Longrightarrow> \<chi>"  shows \<chi>
using assms unfolding op_defs by auto

lemma until_introR[intro]:
assumes "\<psi> \<pi>l" shows "until \<phi> \<psi> \<pi>l"
using assms unfolding op_defs by (auto intro: exI[of _ 0])

lemma until_introL[intro]:
assumes \<phi>: "\<phi> \<pi>l" and u: "until \<phi> \<psi> (map stl \<pi>l)"
shows "until \<phi> \<psi> \<pi>l"
proof-
  obtain i where \<psi>: "\<psi> (map (sdrop (Suc i)) \<pi>l)" and 1: "\<forall>j\<in>{0..<i}. \<phi> (map (sdrop (Suc j)) \<pi>l)"
  using u unfolding op_defs by auto
  {fix j assume "j \<in> {0..<Suc i}"
   hence "\<phi> (map (sdrop j) \<pi>l)" using 1 \<phi> by (cases j) auto
  }
  thus ?thesis using \<psi> unfolding op_defs by auto
qed

text\<open>The elimination rules for until and eventually are induction rules.\<close>

lemma until_induct[induct pred: until, consumes 1, case_names Base Step]:
assumes u: "until \<phi> \<psi> \<pi>l"
and b: "\<And> \<pi>l. \<psi> \<pi>l \<Longrightarrow> \<chi> \<pi>l"
and i: "\<And> \<pi>l. \<lbrakk>\<phi> \<pi>l; until \<phi> \<psi> (map stl \<pi>l); \<chi> (map stl \<pi>l)\<rbrakk> \<Longrightarrow> \<chi> \<pi>l"
shows "\<chi> \<pi>l"
proof-
  obtain i where \<psi>: "\<psi> (map (sdrop i) \<pi>l)" and 1:  "\<forall>j\<in>{0..<i}. \<phi> (map (sdrop j) \<pi>l)"
  using u unfolding until_def next_def by auto
  {fix k assume k: "k \<le> i"
   hence "until \<phi> \<psi> (map (sdrop k) \<pi>l) \<and> \<chi> (map (sdrop k) \<pi>l)"
   proof (induction "i-k" arbitrary: k)
     case 0 hence "k=i" by auto
     with b[OF \<psi>] u \<psi> show ?case by (auto intro: until_introR)
   next
     case (Suc ii)  let ?\<pi>l' = "map (sdrop k) \<pi>l"
     have "until \<phi> \<psi>  (map stl ?\<pi>l') \<and> \<chi> (map stl ?\<pi>l')" using Suc by auto
     moreover have "\<phi> ?\<pi>l'" using 1 Suc by auto
     ultimately show ?case using i by auto
   qed
  }
  from this[of 0] show ?thesis by simp
qed

lemma until_unfold:
"until \<phi> \<psi> \<pi>l = (\<psi> \<pi>l \<or> \<phi> \<pi>l \<and> until \<phi> \<psi> (map stl \<pi>l))" (is "?L = ?R")
proof
  assume ?L thus ?R by induct auto
qed auto

lemma ev_introR[intro]:
assumes "\<phi> \<pi>l" shows "ev \<phi> \<pi>l"
using assms unfolding ev_def by (auto intro: until_introR)

lemma ev_introL[intro]:
assumes "ev \<phi> (map stl \<pi>l)"  shows "ev \<phi> \<pi>l"
using assms unfolding ev_def by (auto intro: until_introL)

lemma ev_induct[induct pred: ev, consumes 1, case_names Base Step]:
assumes "ev \<phi> \<pi>l" and "\<And> \<pi>l. \<phi> \<pi>l \<Longrightarrow> \<chi> \<pi>l"
and "\<And> \<pi>l. \<lbrakk>ev \<phi> (map stl \<pi>l); \<chi> (map stl \<pi>l)\<rbrakk> \<Longrightarrow> \<chi> \<pi>l"
shows "\<chi> \<pi>l"
using assms unfolding ev_def by induct (auto simp: assms)

lemma ev_unfold:
"ev \<phi> \<pi>l = (\<phi> \<pi>l \<or> ev \<phi> (map stl \<pi>l))"
unfolding ev_def by (metis tr_intro until_unfold)

lemma ev: "ev \<phi> \<pi>l \<longleftrightarrow> (\<exists> i. \<phi> (map (sdrop i) \<pi>l))"
unfolding ev_def until_def by auto

text\<open>The introduction rules for always and weak until are coinduction rules.\<close>

lemma alw_coinduct[coinduct pred: alw, consumes 1, case_names Hyp]:
assumes "\<chi> \<pi>l"
and "\<And> \<pi>l. \<chi> \<pi>l \<Longrightarrow> alw \<phi> \<pi>l \<or> (\<phi> \<pi>l \<and> \<chi> (map stl \<pi>l))"
shows "alw \<phi> \<pi>l"
proof-
  {assume "ev (neg \<phi>) \<pi>l"
   hence "\<not> \<chi> \<pi>l"
   apply induct
   using assms unfolding op_defs by auto (metis assms alw_def ev_def neg_def until_introR)
  }
  thus ?thesis using assms unfolding op_defs by auto
qed

lemma alw_elim[elim]:
assumes "alw \<phi> \<pi>l"
and "\<lbrakk>\<phi> \<pi>l; alw \<phi> (map stl \<pi>l)\<rbrakk> \<Longrightarrow> \<chi>"
shows "\<chi>"
using assms unfolding alw_def by(auto elim: ev_introR simp: neg_def)

lemma alw_destL: "alw \<phi> \<pi>l \<Longrightarrow> \<phi> \<pi>l" by auto
lemma alw_destR: "alw \<phi> \<pi>l \<Longrightarrow> alw \<phi> (map stl \<pi>l)" by auto

lemma alw_unfold:
"alw \<phi> \<pi>l = (\<phi> \<pi>l \<and> alw \<phi> (map stl \<pi>l))"
by (metis alw_def ev_unfold neg_elim neg_intro)

lemma alw: "alw \<phi> \<pi>l \<longleftrightarrow> (\<forall> i. \<phi> (map (sdrop i) \<pi>l))"
unfolding alw_def ev neg_def by simp

lemma sdrop_imp_alw:
assumes "\<And> i. (\<And>j. j \<le> i \<Longrightarrow> \<phi> [sdrop j \<pi>, sdrop j \<pi>']) \<Longrightarrow> \<psi> [sdrop i \<pi>, sdrop i \<pi>']"
shows "imp (alw \<phi>) (alw \<psi>) [\<pi>, \<pi>']"
using assms by(auto simp: alw)

lemma wuntil_coinduct[coinduct pred: wuntil, consumes 1, case_names Hyp]:
assumes \<chi>: "\<chi> \<pi>l"
and 0: "\<And> \<pi>l. \<chi> \<pi>l \<Longrightarrow> \<psi> \<pi>l \<or> (\<phi> \<pi>l \<and> \<chi> (map stl \<pi>l))"
shows "wuntil \<phi> \<psi> \<pi>l"
proof-
  {assume "\<not> until \<phi> \<psi> \<pi>l \<and> \<chi> \<pi>l"
   hence "alw \<phi> \<pi>l"
   apply coinduct using 0 by (auto intro: until_introL until_introR)
  }
  thus ?thesis using \<chi> unfolding wuntil_def dis_def by auto
qed

lemma wuntil_elim[elim]:
assumes w: "wuntil \<phi> \<psi> \<pi>l"
and 1: "\<psi> \<pi>l \<Longrightarrow> \<chi>"
and 2: "\<lbrakk>\<phi> \<pi>l; wuntil \<phi> \<psi> (map stl \<pi>l)\<rbrakk> \<Longrightarrow> \<chi>"
shows \<chi>
proof(cases "alw \<phi> \<pi>l")
  case True
  thus ?thesis apply standard using 2 unfolding wuntil_def by auto
next
  case False
  hence "until \<phi> \<psi> \<pi>l" using w unfolding wuntil_def dis_def by auto
  thus ?thesis by (metis assms dis_introL until_unfold wuntil_def)
qed

lemma wuntil_unfold:
"wuntil \<phi> \<psi> \<pi>l = (\<psi> \<pi>l \<or> \<phi> \<pi>l \<and> wuntil \<phi> \<psi> (map stl \<pi>l))"
by (metis alw_unfold dis_def until_unfold wuntil_def)

subsection\<open>More derived operators\<close>

text\<open>The conjunction of an arbitrary set of formulas:\<close>

definition scon ::
"('state,'aprop) sfmla set \<Rightarrow> ('state,'aprop) sfmla" where
"scon \<phi>s \<pi>l \<equiv> \<forall> \<phi> \<in> \<phi>s. \<phi> \<pi>l"

lemma mcon_intro[intro!]:
assumes "\<And> \<phi>. \<phi> \<in> \<phi>s \<Longrightarrow> \<phi> \<pi>l" shows "scon \<phi>s \<pi>l"
using assms unfolding scon_def by auto

lemma scon_elim[elim]:
assumes "scon \<phi>s \<pi>l" and "(\<And> \<phi>. \<phi> \<in> \<phi>s \<Longrightarrow> \<phi> \<pi>l) \<Longrightarrow> \<chi>"
shows \<chi>
using assms unfolding scon_def by auto

text\<open>Double-binding forall:\<close>

definition "fall2 F \<equiv> fall (\<lambda> \<pi>. fall (F \<pi>))"

lemma fall2_intro[intro]:
assumes
"\<And> \<pi> \<pi>'. \<lbrakk>wfp AP' \<pi>; wfp AP' \<pi>';
           \<pi>l \<noteq> [] \<Longrightarrow> stateOf \<pi> = stateOf (last \<pi>l);
           \<pi>l = [] \<Longrightarrow> stateOf \<pi> = s0;
           stateOf \<pi>' = stateOf \<pi>
          \<rbrakk>
       \<Longrightarrow>  F \<pi> \<pi>' \<pi>l"
shows "fall2 F \<pi>l"
using assms unfolding fall2_def by (auto intro!: fall_intro)

lemma fall2_elim[elim]:
assumes "fall2 F \<pi>l"
and
"(\<And>\<pi> \<pi>'. \<lbrakk>wfp AP' \<pi>; wfp AP' \<pi>';
           \<pi>l \<noteq> [] \<Longrightarrow> stateOf \<pi> = stateOf (last \<pi>l); \<pi>l = [] \<Longrightarrow> stateOf \<pi> = s0;
           stateOf \<pi>' = stateOf \<pi>
          \<rbrakk>
          \<Longrightarrow> F \<pi> \<pi>' \<pi>l)
  \<Longrightarrow> \<chi>"
shows \<chi>
using assms unfolding fall2_def by (auto elim!: fall_elim) (metis fall_elim)

(*<*)
end (* context Shallow *)
(*>*)

text\<open>end-of-context Shallow\<close>

(*<*)
end
(*>*)


(*  Title:      HOL/HOLCF/Product_Cpo.thy
    Author:     Franz Regensburger
*)

section \<open>The cpo of cartesian products\<close>

theory Product_Cpo
imports Adm
begin

default_sort cpo

subsection \<open>Unit type is a pcpo\<close>

instantiation unit :: discrete_cpo
begin

definition
  below_unit_def [simp]: "x \<sqsubseteq> (y::unit) \<longleftrightarrow> True"

instance proof
qed simp

end

instance unit :: pcpo
by intro_classes simp

subsection \<open>Product type is a partial order\<close>

instantiation prod :: (below, below) below
begin

definition
  below_prod_def: "(op \<sqsubseteq>) \<equiv> \<lambda>p1 p2. (fst p1 \<sqsubseteq> fst p2 \<and> snd p1 \<sqsubseteq> snd p2)"

instance ..
end

instance prod :: (po, po) po
proof
  fix x :: "'a \<times> 'b"
  show "x \<sqsubseteq> x"
    unfolding below_prod_def by simp
next
  fix x y :: "'a \<times> 'b"
  assume "x \<sqsubseteq> y" "y \<sqsubseteq> x" thus "x = y"
    unfolding below_prod_def prod_eq_iff
    by (fast intro: below_antisym)
next
  fix x y z :: "'a \<times> 'b"
  assume "x \<sqsubseteq> y" "y \<sqsubseteq> z" thus "x \<sqsubseteq> z"
    unfolding below_prod_def
    by (fast intro: below_trans)
qed

subsection \<open>Monotonicity of \emph{Pair}, \emph{fst}, \emph{snd}\<close>

lemma prod_belowI: "\<lbrakk>fst p \<sqsubseteq> fst q; snd p \<sqsubseteq> snd q\<rbrakk> \<Longrightarrow> p \<sqsubseteq> q"
unfolding below_prod_def by simp

lemma Pair_below_iff [simp]: "(a, b) \<sqsubseteq> (c, d) \<longleftrightarrow> a \<sqsubseteq> c \<and> b \<sqsubseteq> d"
unfolding below_prod_def by simp

text \<open>Pair \<open>(_,_)\<close>  is monotone in both arguments\<close>

lemma monofun_pair1: "monofun (\<lambda>x. (x, y))"
by (simp add: monofun_def)

lemma monofun_pair2: "monofun (\<lambda>y. (x, y))"
by (simp add: monofun_def)

lemma monofun_pair:
  "\<lbrakk>x1 \<sqsubseteq> x2; y1 \<sqsubseteq> y2\<rbrakk> \<Longrightarrow> (x1, y1) \<sqsubseteq> (x2, y2)"
by simp

lemma ch2ch_Pair [simp]:
  "chain X \<Longrightarrow> chain Y \<Longrightarrow> chain (\<lambda>i. (X i, Y i))"
by (rule chainI, simp add: chainE)

text \<open>@{term fst} and @{term snd} are monotone\<close>

lemma fst_monofun: "x \<sqsubseteq> y \<Longrightarrow> fst x \<sqsubseteq> fst y"
unfolding below_prod_def by simp

lemma snd_monofun: "x \<sqsubseteq> y \<Longrightarrow> snd x \<sqsubseteq> snd y"
unfolding below_prod_def by simp

lemma monofun_fst: "monofun fst"
by (simp add: monofun_def below_prod_def)

lemma monofun_snd: "monofun snd"
by (simp add: monofun_def below_prod_def)

lemmas ch2ch_fst [simp] = ch2ch_monofun [OF monofun_fst]

lemmas ch2ch_snd [simp] = ch2ch_monofun [OF monofun_snd]

lemma prod_chain_cases:
  assumes "chain Y"
  obtains A B
  where "chain A" and "chain B" and "Y = (\<lambda>i. (A i, B i))"
proof
  from \<open>chain Y\<close> show "chain (\<lambda>i. fst (Y i))" by (rule ch2ch_fst)
  from \<open>chain Y\<close> show "chain (\<lambda>i. snd (Y i))" by (rule ch2ch_snd)
  show "Y = (\<lambda>i. (fst (Y i), snd (Y i)))" by simp
qed

subsection \<open>Product type is a cpo\<close>

lemma is_lub_Pair:
  "\<lbrakk>range A <<| x; range B <<| y\<rbrakk> \<Longrightarrow> range (\<lambda>i. (A i, B i)) <<| (x, y)"
unfolding is_lub_def is_ub_def ball_simps below_prod_def by simp

lemma lub_Pair:
  "\<lbrakk>chain (A::nat \<Rightarrow> 'a::cpo); chain (B::nat \<Rightarrow> 'b::cpo)\<rbrakk>
    \<Longrightarrow> (\<Squnion>i. (A i, B i)) = (\<Squnion>i. A i, \<Squnion>i. B i)"
by (fast intro: lub_eqI is_lub_Pair elim: thelubE)

lemma is_lub_prod:
  fixes S :: "nat \<Rightarrow> ('a::cpo \<times> 'b::cpo)"
  assumes S: "chain S"
  shows "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
using S by (auto elim: prod_chain_cases simp add: is_lub_Pair cpo_lubI)

lemma lub_prod:
  "chain (S::nat \<Rightarrow> 'a::cpo \<times> 'b::cpo)
    \<Longrightarrow> (\<Squnion>i. S i) = (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
by (rule is_lub_prod [THEN lub_eqI])

instance prod :: (cpo, cpo) cpo
proof
  fix S :: "nat \<Rightarrow> ('a \<times> 'b)"
  assume "chain S"
  hence "range S <<| (\<Squnion>i. fst (S i), \<Squnion>i. snd (S i))"
    by (rule is_lub_prod)
  thus "\<exists>x. range S <<| x" ..
qed

instance prod :: (discrete_cpo, discrete_cpo) discrete_cpo
proof
  fix x y :: "'a \<times> 'b"
  show "x \<sqsubseteq> y \<longleftrightarrow> x = y"
    unfolding below_prod_def prod_eq_iff
    by simp
qed

subsection \<open>Product type is pointed\<close>

lemma minimal_prod: "(\<bottom>, \<bottom>) \<sqsubseteq> p"
by (simp add: below_prod_def)

instance prod :: (pcpo, pcpo) pcpo
by intro_classes (fast intro: minimal_prod)

lemma inst_prod_pcpo: "\<bottom> = (\<bottom>, \<bottom>)"
by (rule minimal_prod [THEN bottomI, symmetric])

lemma Pair_bottom_iff [simp]: "(x, y) = \<bottom> \<longleftrightarrow> x = \<bottom> \<and> y = \<bottom>"
unfolding inst_prod_pcpo by simp

lemma fst_strict [simp]: "fst \<bottom> = \<bottom>"
unfolding inst_prod_pcpo by (rule fst_conv)

lemma snd_strict [simp]: "snd \<bottom> = \<bottom>"
unfolding inst_prod_pcpo by (rule snd_conv)

lemma Pair_strict [simp]: "(\<bottom>, \<bottom>) = \<bottom>"
by simp

lemma split_strict [simp]: "case_prod f \<bottom> = f \<bottom> \<bottom>"
unfolding split_def by simp

subsection \<open>Continuity of \emph{Pair}, \emph{fst}, \emph{snd}\<close>

lemma cont_pair1: "cont (\<lambda>x. (x, y))"
apply (rule contI)
apply (rule is_lub_Pair)
apply (erule cpo_lubI)
apply (rule is_lub_const)
done

lemma cont_pair2: "cont (\<lambda>y. (x, y))"
apply (rule contI)
apply (rule is_lub_Pair)
apply (rule is_lub_const)
apply (erule cpo_lubI)
done

lemma cont_fst: "cont fst"
apply (rule contI)
apply (simp add: lub_prod)
apply (erule cpo_lubI [OF ch2ch_fst])
done

lemma cont_snd: "cont snd"
apply (rule contI)
apply (simp add: lub_prod)
apply (erule cpo_lubI [OF ch2ch_snd])
done

lemma cont2cont_Pair [simp, cont2cont]:
  assumes f: "cont (\<lambda>x. f x)"
  assumes g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. (f x, g x))"
apply (rule cont_apply [OF f cont_pair1])
apply (rule cont_apply [OF g cont_pair2])
apply (rule cont_const)
done

lemmas cont2cont_fst [simp, cont2cont] = cont_compose [OF cont_fst]

lemmas cont2cont_snd [simp, cont2cont] = cont_compose [OF cont_snd]

lemma cont2cont_case_prod:
  assumes f1: "\<And>a b. cont (\<lambda>x. f x a b)"
  assumes f2: "\<And>x b. cont (\<lambda>a. f x a b)"
  assumes f3: "\<And>x a. cont (\<lambda>b. f x a b)"
  assumes g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. case g x of (a, b) \<Rightarrow> f x a b)"
unfolding split_def
apply (rule cont_apply [OF g])
apply (rule cont_apply [OF cont_fst f2])
apply (rule cont_apply [OF cont_snd f3])
apply (rule cont_const)
apply (rule f1)
done

lemma prod_contI:
  assumes f1: "\<And>y. cont (\<lambda>x. f (x, y))"
  assumes f2: "\<And>x. cont (\<lambda>y. f (x, y))"
  shows "cont f"
proof -
  have "cont (\<lambda>(x, y). f (x, y))"
    by (intro cont2cont_case_prod f1 f2 cont2cont)
  thus "cont f"
    by (simp only: case_prod_eta)
qed

lemma prod_cont_iff:
  "cont f \<longleftrightarrow> (\<forall>y. cont (\<lambda>x. f (x, y))) \<and> (\<forall>x. cont (\<lambda>y. f (x, y)))"
apply safe
apply (erule cont_compose [OF _ cont_pair1])
apply (erule cont_compose [OF _ cont_pair2])
apply (simp only: prod_contI)
done

lemma cont2cont_case_prod' [simp, cont2cont]:
  assumes f: "cont (\<lambda>p. f (fst p) (fst (snd p)) (snd (snd p)))"
  assumes g: "cont (\<lambda>x. g x)"
  shows "cont (\<lambda>x. case_prod (f x) (g x))"
using assms by (simp add: cont2cont_case_prod prod_cont_iff)

text \<open>The simple version (due to Joachim Breitner) is needed if
  either element type of the pair is not a cpo.\<close>

lemma cont2cont_split_simple [simp, cont2cont]:
 assumes "\<And>a b. cont (\<lambda>x. f x a b)"
 shows "cont (\<lambda>x. case p of (a, b) \<Rightarrow> f x a b)"
using assms by (cases p) auto

text \<open>Admissibility of predicates on product types.\<close>

lemma adm_case_prod [simp]:
  assumes "adm (\<lambda>x. P x (fst (f x)) (snd (f x)))"
  shows "adm (\<lambda>x. case f x of (a, b) \<Rightarrow> P x a b)"
unfolding case_prod_beta using assms .

subsection \<open>Compactness and chain-finiteness\<close>

lemma fst_below_iff: "fst (x::'a \<times> 'b) \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (y, snd x)"
unfolding below_prod_def by simp

lemma snd_below_iff: "snd (x::'a \<times> 'b) \<sqsubseteq> y \<longleftrightarrow> x \<sqsubseteq> (fst x, y)"
unfolding below_prod_def by simp

lemma compact_fst: "compact x \<Longrightarrow> compact (fst x)"
by (rule compactI, simp add: fst_below_iff)

lemma compact_snd: "compact x \<Longrightarrow> compact (snd x)"
by (rule compactI, simp add: snd_below_iff)

lemma compact_Pair: "\<lbrakk>compact x; compact y\<rbrakk> \<Longrightarrow> compact (x, y)"
by (rule compactI, simp add: below_prod_def)

lemma compact_Pair_iff [simp]: "compact (x, y) \<longleftrightarrow> compact x \<and> compact y"
apply (safe intro!: compact_Pair)
apply (drule compact_fst, simp)
apply (drule compact_snd, simp)
done

instance prod :: (chfin, chfin) chfin
apply intro_classes
apply (erule compact_imp_max_in_chain)
apply (case_tac "\<Squnion>i. Y i", simp)
done

end


section \<open>Sets with at Most 2 Elements\<close>

(*<*)
theory Bool_Bounded_Set
imports
  "HOL-Cardinals.Cardinals"
begin
(*>*)

typedef 'a bset =
  "{A :: 'a set. |A| \<le>o ctwo}"
  morphisms set_bset Abs_bset
  by (rule exI[of _ "{}"]) (auto simp: card_of_empty4 ctwo_def)

setup_lifting type_definition_bset

lift_definition map_bset ::
  "('a \<Rightarrow> 'b) \<Rightarrow> 'a bset \<Rightarrow> 'b bset" is image
  using card_of_image ordLeq_transitive by blast

inductive rel_bset :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> 'a bset \<Rightarrow> 'b bset \<Rightarrow> bool" for R where
  "set_bset x \<subseteq> {(x, y). R x y} \<Longrightarrow> rel_bset R (map_bset fst x) (map_bset snd x)"

lift_definition bempty :: "'a bset" is "{}"  by (auto simp: card_of_empty4 ctwo_def)
lift_definition bsingleton :: "'a \<Rightarrow> 'a bset" is "\<lambda>x. {x}" by (auto simp: ctwo_def)
lift_definition bdoubleton :: "'a \<Rightarrow> 'a \<Rightarrow> 'a bset" is "\<lambda>x y. {x, y}"
  by (auto simp: ctwo_def finite_card_of_iff_card2 card.insert_remove card_Diff_singleton_if)

lemma map_bset_bempty[simp]: "map_bset f bempty = bempty"
  by transfer simp

lemma map_bset_eq_bempty[simp]:
  "map_bset f x = bempty \<longleftrightarrow> x = bempty"
  "bempty = map_bset f x \<longleftrightarrow> x = bempty"
  by (transfer, simp)+

lemma map_bset_bsingleton[simp]: "map_bset f (bsingleton x) = bsingleton (f x)"
  by transfer simp

lemma map_bset_bdoubleton[simp]: "map_bset f (bdoubleton x y) = bdoubleton (f x) (f y)"
  by transfer simp

lemma bdoubleton_same[simp]: "bdoubleton x x = bsingleton x"
  by transfer simp

lemma bempty_neq_bdoubleton[simp]:
  "bempty \<noteq> bdoubleton x y"
  "bdoubleton x y \<noteq> bempty"
  by (transfer, simp)+

lemma bsinleton_eq_bdoubleton[simp]:
  "bsingleton x = bdoubleton y z \<longleftrightarrow> (x = y \<and> y = z)"
  "bdoubleton y z = bsingleton x \<longleftrightarrow> (x = y \<and> y = z)"
  by (transfer, auto)+

lemma bsinleton_inj[simp]:
  "bsingleton x = bsingleton y \<longleftrightarrow> (x = y)"
  by (transfer, simp)

lemma bdoubleton_eq_iff[simp]:
  "bdoubleton x y = bdoubleton z w \<longleftrightarrow> (x = z \<and> y = w \<or> x = w \<and> y = z)"
  by transfer (simp add: doubleton_eq_iff)

lemmas [simp] = bempty.rep_eq bsingleton.rep_eq bdoubleton.rep_eq

lemma bset_cases:
  "\<lbrakk>X = bempty \<Longrightarrow> P; \<And>x. X = bsingleton x \<Longrightarrow> P; \<And>x y. \<lbrakk>x \<noteq> y; X = bdoubleton x y\<rbrakk> \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
proof (transfer fixing: P)
  fix Z :: "'a set"
  assume "|Z| \<le>o ctwo"
  moreover then have "finite Z" by (metis card_of_ordLeq_infinite ctwo_def finite_code)
  ultimately have "card Z \<le> 2" unfolding ctwo_def by (subst (asm) finite_card_of_iff_card2) auto
  moreover assume "Z = {} \<Longrightarrow> P" "\<And>x. Z = {x} \<Longrightarrow> P" "\<And>x y. \<lbrakk>x \<noteq> y; Z = {x, y}\<rbrakk> \<Longrightarrow> P"
  ultimately show P using \<open>finite Z\<close>
  proof (induct "card Z")
    case (Suc m) from Suc(2)[symmetric] Suc(2-7) show P by (cases m) (auto simp: card_Suc_eq)
  qed simp
qed

bnf "'k bset"
  map: map_bset
  sets: set_bset
  bd: natLeq
  rel: rel_bset
proof (standard, goal_cases)
  case 1 then show ?case
    by transfer simp
next
  case 2 then show ?case
    apply (rule ext)
    apply transfer
    apply auto
    done
next
  case 3 then show ?case
    apply transfer
    apply (auto simp: image_iff)
    done
next
  case 4 then show ?case
    apply (rule ext)
    apply transfer
    apply simp
    done
next
  case 5 then show ?case by (simp add: card_order_csum natLeq_card_order)
next
  case 6 then show ?case by (simp add: cinfinite_csum natLeq_cinfinite)
next
  case 7 then show ?case by (simp add: regularCard_natLeq)
next
  case 8 then show ?case
    apply transfer
    apply (erule ordLeq_ordLess_trans[OF _ ctwo_ordLess_natLeq])
    done
next
  case (9 R S)
  then show ?case
  proof (safe elim!: rel_bset.cases, unfold rel_bset.simps)
    fix z1 z2
    assume "set_bset z1 \<subseteq> {(x, y). R x y}" "set_bset z2 \<subseteq> {(x, y). S x y}" "map_bset snd z1 = map_bset fst z2"
    then show "\<exists>x. map_bset fst z1 = map_bset fst x \<and> map_bset snd z2 = map_bset snd x \<and>
      set_bset x \<subseteq> {(x, y). (R OO S) x y}"
      by (cases z1 z2 rule: bset_cases[case_product bset_cases])
        (fastforce intro: exI[of _ "bsingleton (a, b)" for a b]
        dest: spec[of _ "bdoubleton (a, b) (c, d)" for a b c d])+
  qed
next
  case (10 R)
  then show ?case
    by (auto simp: fun_eq_iff intro: rel_bset.intros elim: rel_bset.cases)
qed

(*<*)
end
(*>*)