(*  Title:   Exponent_QuasiBorel.thy
    Author:  Michikazu Hirata, Tokyo Institute of Technology
*)

subsection \<open>Function Spaces\<close>

theory Exponent_QuasiBorel
  imports "CoProduct_QuasiBorel"
begin

subsubsection \<open> Function Spaces  \<close>
definition exp_qbs_Mx :: "['a quasi_borel, 'b quasi_borel] \<Rightarrow> (real \<Rightarrow> 'a => 'b) set" where
"exp_qbs_Mx X Y \<equiv> {g :: real \<Rightarrow> 'a \<Rightarrow> 'b. case_prod g \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q X \<rightarrow>\<^sub>Q Y} "

definition exp_qbs :: "['a quasi_borel, 'b quasi_borel] \<Rightarrow> ('a \<Rightarrow> 'b) quasi_borel" (infixr "\<Rightarrow>\<^sub>Q" 61) where
"X \<Rightarrow>\<^sub>Q Y \<equiv> Abs_quasi_borel (X \<rightarrow>\<^sub>Q Y, exp_qbs_Mx X Y)"

lemma exp_qbs_f[simp]: "exp_qbs_Mx X Y \<subseteq> UNIV \<rightarrow> (X :: 'a quasi_borel) \<rightarrow>\<^sub>Q (Y :: 'b quasi_borel)"
proof(auto intro!: qbs_morphismI)
  fix f \<alpha> r
  assume h:"f \<in> exp_qbs_Mx X Y"
           "\<alpha> \<in> qbs_Mx X"
  have "f r \<circ> \<alpha> = (\<lambda>y. case_prod f (r,y)) \<circ> \<alpha>"
    by auto
  also have "... \<in> qbs_Mx Y"
    using qbs_morphism_Pair1'[of r "\<real>\<^sub>Q" "case_prod f" X Y] h
    by(auto simp: exp_qbs_Mx_def)
  finally show "f r \<circ> \<alpha> \<in> qbs_Mx Y" .
qed

lemma exp_qbs_closed1: "qbs_closed1 (exp_qbs_Mx X Y)"
proof(rule qbs_closed1I)
  fix a
  fix f
  assume h:"a \<in> exp_qbs_Mx X Y"
           "f \<in> real_borel \<rightarrow>\<^sub>M real_borel"
  have "a \<circ> f = (\<lambda>r y. case_prod a (f r,y))" by auto
  moreover have "case_prod ... \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q X \<rightarrow>\<^sub>Q Y"
  proof -
    have "case_prod (\<lambda>r y. case_prod a (f r,y)) = case_prod a \<circ> map_prod f id"
      by auto
    also have "... \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q X \<rightarrow>\<^sub>Q Y"
      using h
      by(auto intro!: qbs_morphism_comp qbs_morphism_map_prod simp: exp_qbs_Mx_def)
    finally show ?thesis .
  qed
  ultimately show "a \<circ> f \<in> exp_qbs_Mx X Y"
    by (simp add: exp_qbs_Mx_def)
qed

lemma exp_qbs_closed2: "qbs_closed2 (X \<rightarrow>\<^sub>Q Y) (exp_qbs_Mx X Y)"
  by(auto intro!: qbs_closed2I qbs_morphism_snd'' simp: exp_qbs_Mx_def split_beta')

lemma exp_qbs_closed3:"qbs_closed3 (exp_qbs_Mx X Y)"
proof(rule qbs_closed3I)
  fix P :: "real \<Rightarrow> nat"
  fix Fi :: "nat \<Rightarrow> real \<Rightarrow> _"
  assume h:"\<And>i. P -` {i} \<in> sets real_borel"
           "\<And>i. Fi i \<in> exp_qbs_Mx X Y"
  show "(\<lambda>r. Fi (P r) r) \<in> exp_qbs_Mx X Y"
    unfolding exp_qbs_Mx_def
  proof(auto intro!: qbs_morphismI)
    fix \<alpha> \<beta>
    assume h':"\<alpha> \<in> pair_qbs_Mx \<real>\<^sub>Q X "
    have 1:"\<And>i. (\<lambda>(r,x). Fi i r x) \<circ> \<alpha> \<in> qbs_Mx Y"
      using qbs_morphismE(3)[OF h(2)[simplified exp_qbs_Mx_def,simplified]] h'
      by(simp add: exp_qbs_Mx_def)
    have 2:"\<And>i. (P \<circ> (\<lambda>r. fst (\<alpha> r)))  -` {i} \<in> sets real_borel"
      using separate_measurable[OF h(1)] h'
      by(auto intro!: measurable_separate simp: pair_qbs_Mx_def comp_def)
    show "(\<lambda>(r, y). Fi (P r) r y) \<circ> \<alpha> \<in> qbs_Mx Y"
      using qbs_closed3_dest[OF 2,of "\<lambda>i. (\<lambda>(r,x). Fi i r x) \<circ> \<alpha>",OF 1]
      by(simp add: comp_def split_beta')
  qed
qed

lemma exp_qbs_correct: "Rep_quasi_borel (exp_qbs X Y) = (X \<rightarrow>\<^sub>Q Y, exp_qbs_Mx X Y)"
  unfolding exp_qbs_def
  by(auto intro!: Abs_quasi_borel_inverse exp_qbs_f simp: exp_qbs_closed1 exp_qbs_closed2 exp_qbs_closed3)

lemma exp_qbs_space[simp]: "qbs_space (exp_qbs X Y) = X \<rightarrow>\<^sub>Q Y"
  by(simp add: qbs_space_def exp_qbs_correct)

lemma exp_qbs_Mx[simp]: "qbs_Mx (exp_qbs X Y) = exp_qbs_Mx X Y"
  by(simp add: qbs_Mx_def exp_qbs_correct)

lemma qbs_exp_morphismI:
  assumes "\<And>\<alpha> \<beta>. \<alpha> \<in> qbs_Mx X \<Longrightarrow>
                 \<beta> \<in> pair_qbs_Mx real_quasi_borel Y \<Longrightarrow>
                 (\<lambda>(r,x). (f \<circ> \<alpha>) r x) \<circ> \<beta> \<in> qbs_Mx Z"
   shows "f \<in> X \<rightarrow>\<^sub>Q exp_qbs Y Z"
  using assms
  by(auto intro!: qbs_morphismI simp: exp_qbs_Mx_def comp_def)

definition qbs_eval :: "(('a \<Rightarrow> 'b) \<times> 'a)  \<Rightarrow> 'b" where
"qbs_eval a \<equiv> (fst a) (snd a)"

lemma qbs_eval_morphism:
  "qbs_eval \<in> (exp_qbs X Y) \<Otimes>\<^sub>Q X \<rightarrow>\<^sub>Q Y"
proof(rule qbs_morphismI,simp)
  fix f
  assume "f \<in> pair_qbs_Mx (exp_qbs X Y) X"
  let ?f1 = "fst \<circ> f"
  let ?f2 = "snd \<circ> f"
  define g :: "real \<Rightarrow> real \<times> _"
    where "g \<equiv> \<lambda>r.(r,?f2 r)"
  have "g \<in> qbs_Mx (real_quasi_borel \<Otimes>\<^sub>Q X)"
  proof(auto simp add: pair_qbs_Mx_def)
    have "fst \<circ> g = id" by(auto simp add: g_def comp_def)
    thus "fst \<circ> g \<in> real_borel \<rightarrow>\<^sub>M real_borel" by(auto simp add: measurable_ident)
  next
    have "snd \<circ> g = ?f2" by(auto simp add: g_def)
    thus "snd \<circ> g \<in> qbs_Mx X"
      using \<open>f \<in> pair_qbs_Mx (exp_qbs X Y) X\<close> pair_qbs_Mx_def by auto
  qed
  moreover have "?f1 \<in> exp_qbs_Mx X Y"
    using \<open>f \<in> pair_qbs_Mx (exp_qbs X Y) X\<close>
    by(simp add: pair_qbs_Mx_def)
  ultimately have "(\<lambda>(r,x). (?f1 r x)) \<circ> g \<in> qbs_Mx Y"
    by (auto simp add: exp_qbs_Mx_def qbs_morphism_def)
       (metis (mono_tags, lifting) case_prod_conv comp_apply cond_case_prod_eta)
  moreover have "(\<lambda>(r,x). (?f1 r x)) \<circ> g = qbs_eval \<circ> f"
    by(auto simp add: case_prod_unfold g_def qbs_eval_def)
  ultimately show "qbs_eval \<circ> f \<in> qbs_Mx Y" by simp
qed

lemma curry_morphism:
 "curry \<in> exp_qbs (X \<Otimes>\<^sub>Q Y) Z \<rightarrow>\<^sub>Q exp_qbs X (exp_qbs Y Z)"
proof(auto intro!: qbs_morphismI simp: exp_qbs_Mx_def)
  fix k \<alpha> \<alpha>'
  assume h:"(\<lambda>(r, xy). k r xy) \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Z"
           "\<alpha> \<in> pair_qbs_Mx \<real>\<^sub>Q X"
           "\<alpha>' \<in> pair_qbs_Mx \<real>\<^sub>Q Y"
  define \<beta> where
   "\<beta> \<equiv> (\<lambda>r. (fst (\<alpha> (fst (\<alpha>' r))),(snd (\<alpha> (fst (\<alpha>' r))), snd (\<alpha>' r))))"
  have "(\<lambda>(x, y). ((\<lambda>(x, y). (curry \<circ> k) x y) \<circ> \<alpha>) x y) \<circ> \<alpha>' = (\<lambda>(r, xy). k r xy) \<circ> \<beta>"
    by(simp add: curry_def split_beta' comp_def \<beta>_def)
  also have "... \<in> qbs_Mx Z"
  proof -
    have "\<beta> \<in> qbs_Mx (\<real>\<^sub>Q \<Otimes>\<^sub>Q X \<Otimes>\<^sub>Q Y)"
      using h(2,3) qbs_closed1_dest[of _ _ "(\<lambda>x. fst (\<alpha>' x))"]
      by(auto simp: pair_qbs_Mx_def \<beta>_def comp_def)
    thus ?thesis
      using h by auto
  qed
  finally show "(\<lambda>(x, y). ((\<lambda>(x, y). (curry \<circ> k) x y) \<circ> \<alpha>) x y) \<circ> \<alpha>' \<in> qbs_Mx Z" .
qed

lemma curry_preserves_morphisms:
  assumes "f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Z"
  shows "curry f \<in> X \<rightarrow>\<^sub>Q exp_qbs Y Z"
  by(rule qbs_morphismE(2)[OF curry_morphism,simplified,OF assms])

lemma uncurry_morphism:
 "case_prod \<in> exp_qbs X (exp_qbs Y Z) \<rightarrow>\<^sub>Q exp_qbs (X \<Otimes>\<^sub>Q Y) Z"
proof(auto intro!: qbs_morphismI simp: exp_qbs_Mx_def)
  fix k \<alpha>
  assume h:"(\<lambda>(x, y). k x y) \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q X \<rightarrow>\<^sub>Q exp_qbs Y Z"
           "\<alpha> \<in> pair_qbs_Mx \<real>\<^sub>Q (X \<Otimes>\<^sub>Q Y)"
  have "(\<lambda>(x, y). (case_prod \<circ> k) x y) \<circ> \<alpha> = (\<lambda>(r,y). k (fst (\<alpha> r)) (fst (snd (\<alpha> r))) y) \<circ> (\<lambda>r. (r,snd (snd (\<alpha> r))))"
    by(simp add: split_beta' comp_def)
  also have "... \<in> qbs_Mx Z"
  proof(rule qbs_morphismE(3)[where X="\<real>\<^sub>Q \<Otimes>\<^sub>Q Y"])
    have "(\<lambda>r. k (fst (\<alpha> r)) (fst (snd (\<alpha> r)))) = (\<lambda>(x, y). k x y) \<circ> (\<lambda>r. (fst (\<alpha> r),fst (snd (\<alpha> r))))"
      by auto
    also have "... \<in> qbs_Mx (exp_qbs Y Z)"
      apply(rule qbs_morphismE(3)[where X="\<real>\<^sub>Q \<Otimes>\<^sub>Q X"])
      using h(2) by(auto simp: h(1) pair_qbs_Mx_def comp_def)
    finally show " (\<lambda>(r, y). k (fst (\<alpha> r)) (fst (snd (\<alpha> r))) y) \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Z"
      by(simp add: exp_qbs_Mx_def)
  next
    show "(\<lambda>r. (r, snd (snd (\<alpha> r)))) \<in> qbs_Mx (\<real>\<^sub>Q \<Otimes>\<^sub>Q Y)"
      using h(2) by(simp add: pair_qbs_Mx_def comp_def)
  qed
  finally show "(\<lambda>(x, y). (case_prod \<circ> k) x y) \<circ> \<alpha> \<in> qbs_Mx Z" .
qed

lemma uncurry_preserves_morphisms:
  assumes "f \<in> X \<rightarrow>\<^sub>Q exp_qbs Y Z"
  shows "case_prod f \<in> X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Z"
 by(rule qbs_morphismE(2)[OF uncurry_morphism,simplified,OF assms])

lemma arg_swap_morphism:
  assumes "f \<in> X \<rightarrow>\<^sub>Q exp_qbs Y Z"
  shows "(\<lambda>y x. f x y) \<in> Y \<rightarrow>\<^sub>Q exp_qbs X Z"
  using curry_preserves_morphisms[OF qbs_morphism_pair_swap[OF uncurry_preserves_morphisms[OF assms]]]
  by simp

lemma exp_qbs_comp_morphism:
  assumes "f \<in> W \<rightarrow>\<^sub>Q exp_qbs X Y"
      and "g \<in> W \<rightarrow>\<^sub>Q exp_qbs Y Z"
    shows "(\<lambda>w. g w \<circ> f w) \<in> W \<rightarrow>\<^sub>Q exp_qbs X Z"
proof(rule qbs_exp_morphismI)
  fix \<alpha> \<beta>
  assume h: "\<alpha> \<in> qbs_Mx W"
            "\<beta> \<in> pair_qbs_Mx \<real>\<^sub>Q X"
  have "(\<lambda>(r, x). ((\<lambda>w. g w \<circ> f w) \<circ> \<alpha>) r x) \<circ> \<beta>= case_prod g \<circ> (\<lambda>r. ((\<alpha> \<circ> (fst \<circ> \<beta>)) r, case_prod f ((\<alpha> \<circ> (fst \<circ> \<beta>)) r, (snd \<circ> \<beta>) r)))"
    by(simp add: split_beta' comp_def)
  also have "... \<in> qbs_Mx Z"
  proof -
    have "(\<lambda>r. ((\<alpha> \<circ> (fst \<circ> \<beta>)) r, case_prod f ((\<alpha> \<circ> (fst \<circ> \<beta>)) r, (snd \<circ> \<beta>) r))) \<in> qbs_Mx (W \<Otimes>\<^sub>Q Y)"
    proof(auto simp add: pair_qbs_Mx_def)
      have "fst \<circ> (\<lambda>r. (\<alpha> (fst (\<beta> r)), f (\<alpha> (fst (\<beta> r))) (snd (\<beta> r)))) = \<alpha> \<circ> (fst \<circ> \<beta>)"
        by (simp add: comp_def)
      also have "... \<in> qbs_Mx W"
        using qbs_decomp[of W] h
        by(simp add: pair_qbs_Mx_def qbs_closed1_def)
      finally show "fst \<circ> (\<lambda>r. (\<alpha> (fst (\<beta> r)), f (\<alpha> (fst (\<beta> r))) (snd (\<beta> r)))) \<in> qbs_Mx W" .
    next
      have [simp]:"snd \<circ> (\<lambda>r. (\<alpha> (fst (\<beta> r)), f (\<alpha> (fst (\<beta> r))) (snd (\<beta> r)))) =  case_prod f \<circ> (\<lambda>r. ((\<alpha> \<circ> (fst \<circ> \<beta>)) r, (snd \<circ> \<beta>) r))"
        by(simp add: comp_def)
      have "(\<lambda>r. ((\<alpha> \<circ> (fst \<circ> \<beta>)) r, (snd \<circ> \<beta>) r)) \<in> qbs_Mx (W \<Otimes>\<^sub>Q X)"
      proof(auto simp add: pair_qbs_Mx_def)
        have "fst \<circ> (\<lambda>r. (\<alpha> (fst (\<beta> r)), snd (\<beta> r)))= \<alpha> \<circ> (fst \<circ> \<beta>)"
          by (simp add: comp_def)
        also have "... \<in> qbs_Mx W"
          using qbs_decomp[of W] h
          by(simp add: pair_qbs_Mx_def qbs_closed1_def)
        finally show "fst \<circ> (\<lambda>r. (\<alpha> (fst (\<beta> r)), snd (\<beta> r))) \<in> qbs_Mx W" .
      next
        show "snd \<circ> (\<lambda>r. (\<alpha> (fst (\<beta> r)), snd (\<beta> r))) \<in> qbs_Mx X"
          using h
          by(simp add: pair_qbs_Mx_def comp_def)
      qed
      hence "case_prod f \<circ> (\<lambda>r. ((\<alpha> \<circ> (fst \<circ> \<beta>)) r, (snd \<circ> \<beta>) r)) \<in> qbs_Mx Y"
        using uncurry_preserves_morphisms[OF assms(1)] by auto
      thus "snd \<circ> (\<lambda>r. (\<alpha> (fst (\<beta> r)), f (\<alpha> (fst (\<beta> r))) (snd (\<beta> r)))) \<in> qbs_Mx Y"
        by simp
    qed
    thus ?thesis
      using uncurry_preserves_morphisms[OF assms(2)]
      by auto
  qed
  finally show "(\<lambda>(r, x). ((\<lambda>w. g w \<circ> f w) \<circ> \<alpha>) r x) \<circ> \<beta> \<in> qbs_Mx Z" .
qed

lemma case_sum_morphism:
 "case_prod case_sum \<in> exp_qbs X Z \<Otimes>\<^sub>Q exp_qbs Y Z  \<rightarrow>\<^sub>Q exp_qbs (X <+>\<^sub>Q Y) Z"
proof(rule qbs_exp_morphismI)
  fix \<alpha> \<beta>
  assume h0:"\<alpha> \<in> qbs_Mx (exp_qbs X Z \<Otimes>\<^sub>Q exp_qbs Y Z)"
            "\<beta> \<in> pair_qbs_Mx \<real>\<^sub>Q (X <+>\<^sub>Q Y)"
  let ?\<alpha>1 = "fst \<circ> \<alpha>"
  let ?\<alpha>2 = "snd \<circ> \<alpha>"
  let ?\<beta>1 = "fst \<circ> \<beta>"
  let ?\<beta>2 = "snd \<circ> \<beta>"
  have h:"?\<alpha>1 \<in> exp_qbs_Mx X Z"
         "?\<alpha>2 \<in> exp_qbs_Mx Y Z"
         "?\<beta>1 \<in> real_borel \<rightarrow>\<^sub>M real_borel"
         "?\<beta>2 \<in> copair_qbs_Mx X Y"
    using h0 by (auto simp add: pair_qbs_Mx_def)
  hence "\<exists>S\<in>sets real_borel. (S = {} \<longrightarrow> (\<exists>\<alpha>1\<in>qbs_Mx X. ?\<beta>2 = (\<lambda>r. Inl (\<alpha>1 r)))) \<and>
                             (S = UNIV \<longrightarrow> (\<exists>\<alpha>2\<in>qbs_Mx Y. ?\<beta>2 = (\<lambda>r. Inr (\<alpha>2 r)))) \<and>
                             (S \<noteq> {} \<and> S \<noteq> UNIV \<longrightarrow>
                            (\<exists>\<alpha>1\<in>qbs_Mx X. \<exists>\<alpha>2\<in>qbs_Mx Y. ?\<beta>2 = (\<lambda>r. if r \<in> S then Inl (\<alpha>1 r) else Inr (\<alpha>2 r))))"
    by(simp add: copair_qbs_Mx_def)
  then obtain S :: "real set" where hs:
   "S\<in>sets real_borel \<and> (S = {} \<longrightarrow> (\<exists>\<alpha>1\<in>qbs_Mx X. ?\<beta>2 = (\<lambda>r. Inl (\<alpha>1 r)))) \<and>
                         (S = UNIV \<longrightarrow> (\<exists>\<alpha>2\<in>qbs_Mx Y. ?\<beta>2 = (\<lambda>r. Inr (\<alpha>2 r)))) \<and>
                         (S \<noteq> {} \<and> S \<noteq> UNIV \<longrightarrow>
                          (\<exists>\<alpha>1\<in>qbs_Mx X. \<exists>\<alpha>2\<in>qbs_Mx Y. ?\<beta>2 = (\<lambda>r. if r \<in> S then Inl (\<alpha>1 r) else Inr (\<alpha>2 r))))"
    by auto
  show "(\<lambda>(r, x). ((\<lambda>(x, y). case_sum x y) \<circ> \<alpha>) r x) \<circ> \<beta> \<in> qbs_Mx Z"
  proof -
    have "(\<lambda>(r, x). ((\<lambda>(x, y). case_sum x y) \<circ> \<alpha>) r x) \<circ> \<beta> = (\<lambda>r. case_sum (?\<alpha>1 (?\<beta>1 r)) (?\<alpha>2 (?\<beta>1 r)) (?\<beta>2 r))"
          (is "?lhs = ?rhs")
      by(auto simp: split_beta' comp_def) (metis comp_apply)
    also have "... \<in> qbs_Mx Z"
         (is "?f \<in> _")
    proof -
      consider "S = {}" | "S = UNIV" | "S \<noteq> {} \<and> S \<noteq> UNIV" by auto
      then show ?thesis
      proof cases
        case 1
        then obtain \<alpha>1 where h1:
         "\<alpha>1\<in>qbs_Mx X \<and> ?\<beta>2 = (\<lambda>r. Inl (\<alpha>1 r))"
          using hs by auto
        then have "(\<lambda>r. case_sum (?\<alpha>1 (?\<beta>1 r)) (?\<alpha>2 (?\<beta>1 r)) (?\<beta>2 r)) = (\<lambda>r. ?\<alpha>1 (?\<beta>1 r) (\<alpha>1 r))"
          by simp
        also have "... = case_prod ?\<alpha>1 \<circ> (\<lambda>r. (?\<beta>1 r,\<alpha>1 r))"
          by auto
        also have "... \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q Z"
          apply(rule qbs_morphism_comp[of _ _ "\<real>\<^sub>Q \<Otimes>\<^sub>Q X"])
           apply(rule qbs_morphism_tuple)
          using h(3)
            apply blast
          using qbs_Mx_is_morphisms h1
           apply blast
          using qbs_Mx_is_morphisms[of "\<real>\<^sub>Q \<Otimes>\<^sub>Q X"] h(1)
          by (simp add: exp_qbs_Mx_def)
        finally show ?thesis
          using qbs_Mx_is_morphisms by auto
      next
        case 2
        then obtain \<alpha>2 where h2:
         "\<alpha>2\<in>qbs_Mx Y \<and> ?\<beta>2 = (\<lambda>r. Inr (\<alpha>2 r))"
          using hs by auto
        then have "(\<lambda>r. case_sum (?\<alpha>1 (?\<beta>1 r)) (?\<alpha>2 (?\<beta>1 r)) (?\<beta>2 r)) = (\<lambda>r. ?\<alpha>2 (?\<beta>1 r) (\<alpha>2 r))"
          by simp
        also have "... = case_prod ?\<alpha>2 \<circ> (\<lambda>r. (?\<beta>1 r,\<alpha>2 r))"
          by auto
        also have "... \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q Z"
          apply(rule qbs_morphism_comp[of _ _ "\<real>\<^sub>Q \<Otimes>\<^sub>Q Y"])
           apply(rule qbs_morphism_tuple)
          using h(3)
            apply blast
          using qbs_Mx_is_morphisms h2
           apply blast
          using qbs_Mx_is_morphisms[of "\<real>\<^sub>Q \<Otimes>\<^sub>Q Y"] h(2)
          by (simp add: exp_qbs_Mx_def)
        finally show ?thesis
          using qbs_Mx_is_morphisms by auto
      next
        case 3
        then obtain \<alpha>1 \<alpha>2 where h3:
          "\<alpha>1\<in>qbs_Mx X \<and> \<alpha>2\<in>qbs_Mx Y \<and> ?\<beta>2 = (\<lambda>r. if r \<in> S then Inl (\<alpha>1 r) else Inr (\<alpha>2 r))"
          using hs by auto
        define P :: "real \<Rightarrow> nat"
          where "P \<equiv> (\<lambda>r. if r \<in> S then 0 else 1)"
        define \<gamma> :: "nat \<Rightarrow> real \<Rightarrow> _"
          where "\<gamma> \<equiv> (\<lambda>n r. if n = 0 then ?\<alpha>1 (?\<beta>1 r) (\<alpha>1 r) else ?\<alpha>2 (?\<beta>1 r) (\<alpha>2 r))"
        then have "(\<lambda>r. case_sum (?\<alpha>1 (?\<beta>1 r)) (?\<alpha>2 (?\<beta>1 r)) (?\<beta>2 r)) =(\<lambda>r. \<gamma> (P r) r)"
          by(auto simp add: P_def \<gamma>_def h3)
        also have "... \<in> qbs_Mx Z"
        proof -
          have "\<forall>i. P -` {i} \<in> sets real_borel"
            using hs borel_comp[of S] by(simp add: P_def)
          moreover have"\<forall>i. \<gamma> i \<in> qbs_Mx Z"
          proof
            fix i :: nat
            consider "i = 0" | "i \<noteq> 0" by auto
            then show "\<gamma> i \<in> qbs_Mx Z"
            proof cases
              case 1
              then have "\<gamma> i = (\<lambda>r. ?\<alpha>1 (?\<beta>1 r) (\<alpha>1 r))"
                by(simp add: \<gamma>_def)
              also have "... = case_prod ?\<alpha>1 \<circ> (\<lambda>r. (?\<beta>1 r,\<alpha>1 r))"
                by auto
              also have "... \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q Z"
                apply(rule qbs_morphism_comp[of _ _ "\<real>\<^sub>Q \<Otimes>\<^sub>Q X"])
                 apply(rule qbs_morphism_tuple)
                using h(3)
                  apply blast
                using qbs_Mx_is_morphisms h3
                 apply blast
                using qbs_Mx_is_morphisms[of "\<real>\<^sub>Q \<Otimes>\<^sub>Q X"] h(1)
                by (simp add: exp_qbs_Mx_def)
              finally show ?thesis
                using qbs_Mx_is_morphisms by auto
            next
              case 2
              then have "\<gamma> i = (\<lambda>r. ?\<alpha>2 (?\<beta>1 r) (\<alpha>2 r))"
                by(simp add: \<gamma>_def)
              also have "... = case_prod ?\<alpha>2 \<circ> (\<lambda>r. (?\<beta>1 r,\<alpha>2 r))"
                by auto
              also have "... \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q Z"
                apply(rule qbs_morphism_comp[of _ _ "\<real>\<^sub>Q \<Otimes>\<^sub>Q Y"])
                 apply(rule qbs_morphism_tuple)
                using h(3)
                  apply blast
                using qbs_Mx_is_morphisms h3
                 apply blast
                using qbs_Mx_is_morphisms[of "\<real>\<^sub>Q \<Otimes>\<^sub>Q Y"] h(2)
                by (simp add: exp_qbs_Mx_def)
              finally show ?thesis
                using qbs_Mx_is_morphisms by auto
            qed
          qed
          ultimately show ?thesis
            using qbs_decomp[of Z]
            by(simp add: qbs_closed3_def)
        qed
        finally show ?thesis .
      qed
    qed
    finally show ?thesis .
  qed
qed

lemma not_qbs_morphism:
 "Not \<in> \<bool>\<^sub>Q \<rightarrow>\<^sub>Q \<bool>\<^sub>Q"
  by(auto intro!: bool_qbs_morphism)

lemma or_qbs_morphism:
 "(\<or>) \<in> \<bool>\<^sub>Q \<rightarrow>\<^sub>Q exp_qbs \<bool>\<^sub>Q \<bool>\<^sub>Q"
  by(auto intro!: bool_qbs_morphism)

lemma and_qbs_morphism:
 "(\<and>) \<in> \<bool>\<^sub>Q \<rightarrow>\<^sub>Q exp_qbs \<bool>\<^sub>Q \<bool>\<^sub>Q"
  by(auto intro!: bool_qbs_morphism)

lemma implies_qbs_morphism:
 "(\<longrightarrow>) \<in> \<bool>\<^sub>Q \<rightarrow>\<^sub>Q \<bool>\<^sub>Q \<Rightarrow>\<^sub>Q \<bool>\<^sub>Q"
  by(auto intro!: bool_qbs_morphism)

lemma less_nat_qbs_morphism:
 "(<) \<in> \<nat>\<^sub>Q \<rightarrow>\<^sub>Q exp_qbs \<nat>\<^sub>Q \<bool>\<^sub>Q"
  by(auto intro!: nat_qbs_morphism)

lemma less_real_qbs_morphism:
 "(<) \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q exp_qbs \<real>\<^sub>Q \<bool>\<^sub>Q"
proof(rule curry_preserves_morphisms[where f="(\<lambda>(z :: real \<times> real). fst z < snd z)",simplified curry_def,simplified])
  have "(\<lambda>z. fst z < snd z) \<in> real_borel \<Otimes>\<^sub>M real_borel \<rightarrow>\<^sub>M bool_borel"
    using borel_measurable_pred_less[OF measurable_fst measurable_snd,simplified measurable_cong_sets[OF refl sets_borel_eq_count_space[symmetric],of "borel \<Otimes>\<^sub>M borel"]]
    by simp
  thus "(\<lambda>z. fst z < snd z) \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q \<real>\<^sub>Q \<rightarrow>\<^sub>Q \<bool>\<^sub>Q"
    by auto
qed

lemma rec_list_morphism':
 "rec_list' \<in> qbs_space (exp_qbs Y (exp_qbs (exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) (exp_qbs (list_of X) Y)))"
  apply(simp,rule curry_preserves_morphisms[where f="\<lambda>yf. rec_list' (fst yf) (snd yf)",simplified curry_def, simplified])
  apply(rule arg_swap_morphism)
proof(rule coprod_qbs_canonical1')
  fix n
  show "(\<lambda>x y. rec_list' (fst y) (snd y) (n, x)) \<in> (\<Pi>\<^sub>Q i\<in>{..<n}. X) \<rightarrow>\<^sub>Q exp_qbs (Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) Y"
  proof(induction n)
    case 0
    show ?case
    proof(rule curry_preserves_morphisms[of " (\<lambda>(x,y). rec_list' (fst y) (snd y) (0, x))", simplified],rule qbs_morphismI)
      fix \<alpha>
      assume h:"\<alpha> \<in> qbs_Mx ((\<Pi>\<^sub>Q i\<in>{..<0::nat}. X) \<Otimes>\<^sub>Q Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)))"
      have "\<And>r. fst (\<alpha> r) = (\<lambda>n. undefined)"
      proof -
        fix r
        have "\<And>i. (\<lambda>r. fst (\<alpha> r) i) = (\<lambda>r. undefined)"
          using h by(auto simp: exp_qbs_Mx_def prod_qbs_Mx_def pair_qbs_Mx_def comp_def split_beta')
        thus "fst (\<alpha> r) = (\<lambda>n. undefined)"
          by(fastforce dest: fun_cong)
      qed
      hence "(\<lambda>(x, y). rec_list' (fst y) (snd y) (0, x)) \<circ> \<alpha> = (\<lambda>x. fst (snd (\<alpha> x)))"
        by(auto simp: rec_list'_simp1 comp_def split_beta')
      also have "... \<in> qbs_Mx Y"
        using h by(auto simp: pair_qbs_Mx_def comp_def)
      finally show "(\<lambda>(x, y). rec_list' (fst y) (snd y) (0, x)) \<circ> \<alpha> \<in> qbs_Mx Y" .
    qed
  next
    case ih:(Suc n)
    show ?case
    proof(rule qbs_morphismI)
      fix \<alpha>
      assume h:"\<alpha> \<in> qbs_Mx (\<Pi>\<^sub>Q i\<in>{..<Suc n}. X)"
      define \<alpha>' where "\<alpha>' \<equiv> (\<lambda>r. snd (list_tail (Suc n, \<alpha> r)))"
      define a where "a \<equiv> (\<lambda>r. \<alpha> r 0)"
      then have ha:"a \<in> qbs_Mx X"
        using h by(auto simp: prod_qbs_Mx_def)
      have 1:"\<alpha>' \<in> qbs_Mx (\<Pi>\<^sub>Q i\<in>{..<n}. X)"
        using h by(fastforce simp: prod_qbs_Mx_def list_tail_def \<alpha>'_def)
      hence 2: "\<And>r. (n, \<alpha>' r) \<in> qbs_space (list_of X)"
        using qbs_Mx_to_X[of \<alpha>'] by fastforce
      have 3: "\<And>r. (Suc n, \<alpha> r) \<in> qbs_space (list_of X)"
        using qbs_Mx_to_X[of \<alpha>] h by fastforce
      have 4: "\<And>r. (n, \<alpha>' r) = list_tail (Suc n, \<alpha> r)"
        by(simp add: list_tail_def \<alpha>'_def)
      have 5: "\<And>r. (Suc n, \<alpha> r) = list_cons (a r) (n, \<alpha>' r)"
        unfolding a_def by(simp add: list_simp5[OF 3,simplified 4[symmetric],simplified list_head_def]) auto
      have 6: "(\<lambda>r. (n, \<alpha>' r)) \<in> qbs_Mx (list_of X)"
        using 1 by(auto intro!: coprod_qbs_MxI)

      have "(\<lambda>x y. rec_list' (fst y) (snd y) (Suc n, x)) \<circ> \<alpha> = (\<lambda>r y. rec_list' (fst y) (snd y) (Suc n, \<alpha> r))"
        by auto
      also have "... = (\<lambda>r y. snd y (a r) (n, \<alpha>' r) (rec_list' (fst y) (snd y) (n, \<alpha>' r)))"
        by(simp only: 5 rec_list'_simp2[OF 2])
      also have "... \<in> qbs_Mx (exp_qbs (Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) Y)"
      proof -
        have "(\<lambda>(r,y). snd y (a r) (n, \<alpha>' r) (rec_list' (fst y) (snd y) (n, \<alpha>' r))) = (\<lambda>(y,x1,x2,x3). y x1 x2 x3) \<circ> (\<lambda>(r,y). (snd y, a r, (n, \<alpha>' r), rec_list' (fst y) (snd y) (n, \<alpha>' r)))"
          by auto
        also have "... \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q (Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) \<rightarrow>\<^sub>Q Y"
        proof(rule qbs_morphism_comp[where Y="exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) \<Otimes>\<^sub>Q X \<Otimes>\<^sub>Q list_of X \<Otimes>\<^sub>Q Y"])
          show "(\<lambda>(r, y). (snd y, a r, (n, \<alpha>' r), rec_list' (fst y) (snd y) (n, \<alpha>' r))) \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) \<rightarrow>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) \<Otimes>\<^sub>Q X \<Otimes>\<^sub>Q list_of X \<Otimes>\<^sub>Q Y"
          proof(auto simp: split_beta' intro!: qbs_morphism_tuple[OF qbs_morphism_snd''[OF snd_qbs_morphism] qbs_morphism_tuple[of "\<lambda>(r, y). a r" "\<real>\<^sub>Q \<Otimes>\<^sub>Q Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))" X], OF _ qbs_morphism_tuple[of "\<lambda>(r,y).  (n, \<alpha>' r)"],of "list_of X" "\<lambda>(r,y). rec_list' (fst y) (snd y) (n, \<alpha>' r)",simplified split_beta'])
            show "(\<lambda>x. a (fst x)) \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) \<rightarrow>\<^sub>Q X"
              using ha qbs_Mx_is_morphisms[of X] qbs_morphism_fst''[of a "\<real>\<^sub>Q" X] by auto
          next
            show "(\<lambda>x. (n, \<alpha>' (fst x))) \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) \<rightarrow>\<^sub>Q list_of X"
              using qbs_morphism_fst''[of "\<lambda>r. (n, \<alpha>' r)" "\<real>\<^sub>Q" "list_of X"] qbs_Mx_is_morphisms[of "list_of X"] 6 by auto
          next
            show "(\<lambda>x. rec_list' (fst (snd x)) (snd (snd x)) (n, \<alpha>' (fst x))) \<in> \<real>\<^sub>Q \<Otimes>\<^sub>Q Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) \<rightarrow>\<^sub>Q Y"
              using qbs_morphismE(3)[OF ih 1, simplified comp_def]  uncurry_preserves_morphisms[of "(\<lambda>x y. rec_list' (fst y) (snd y) (n, \<alpha>' x))" "\<real>\<^sub>Q" "Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))" Y] qbs_Mx_is_morphisms[of "exp_qbs (Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) Y"]
              by(fastforce simp: split_beta')
          qed
        next
          show "(\<lambda>(y, x1, x2, x3). y x1 x2 x3) \<in> exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) \<Otimes>\<^sub>Q X \<Otimes>\<^sub>Q list_of X \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Y"
          proof(rule qbs_morphismI)
            fix \<beta>
            assume "\<beta> \<in> qbs_Mx (exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)) \<Otimes>\<^sub>Q X \<Otimes>\<^sub>Q list_of X \<Otimes>\<^sub>Q Y)"
            then have "\<exists> \<beta>1 \<beta>2 \<beta>3 \<beta>4. \<beta> = (\<lambda>r. (\<beta>1 r, \<beta>2 r, \<beta>3 r, \<beta>4 r)) \<and> \<beta>1 \<in> qbs_Mx (exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) \<and> \<beta>2 \<in> qbs_Mx X \<and> \<beta>3 \<in> qbs_Mx (list_of X) \<and> \<beta>4 \<in> qbs_Mx Y"
              by(auto intro!: exI[where x="fst \<circ> \<beta>"] exI[where x="fst \<circ> snd \<circ> \<beta>"] exI[where x="fst \<circ> snd \<circ> snd \<circ> \<beta>"] exI[where x="snd \<circ> snd \<circ> snd \<circ> \<beta>"] simp:pair_qbs_Mx_def comp_def)
            then obtain \<beta>1 \<beta>2 \<beta>3 \<beta>4 where hb:
             "\<beta> = (\<lambda>r. (\<beta>1 r, \<beta>2 r, \<beta>3 r, \<beta>4 r))" "\<beta>1 \<in> qbs_Mx (exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y)))" "\<beta>2 \<in> qbs_Mx X" "\<beta>3 \<in> qbs_Mx (list_of X)" "\<beta>4 \<in> qbs_Mx Y"
              by auto
            hence hbq:"(\<lambda>(((r,x1),x2),x3). \<beta>1 r x1 x2 x3) \<in> ((\<real>\<^sub>Q \<Otimes>\<^sub>Q X) \<Otimes>\<^sub>Q list_of X) \<Otimes>\<^sub>Q Y \<rightarrow>\<^sub>Q Y"
              by(simp add: exp_qbs_Mx_def) (meson uncurry_preserves_morphisms)
            have "(\<lambda>(y, x1, x2, x3). y x1 x2 x3) \<circ> \<beta> = (\<lambda>(((r,x1),x2),x3). \<beta>1 r x1 x2 x3) \<circ> (\<lambda>r. (((r,\<beta>2 r), \<beta>3 r), \<beta>4 r))"
              by(auto simp: hb(1))
            also have "... \<in> \<real>\<^sub>Q \<rightarrow>\<^sub>Q Y"
              using hb(2-5)
              by(auto intro!: qbs_morphism_comp[OF qbs_morphism_tuple[OF qbs_morphism_tuple[OF qbs_morphism_tuple[OF qbs_morphism_ident']]] hbq] simp: qbs_Mx_is_morphisms)
            finally show "(\<lambda>(y, x1, x2, x3). y x1 x2 x3) \<circ> \<beta> \<in> qbs_Mx Y"
              by(simp add: qbs_Mx_is_morphisms)
          qed
        qed
        finally show ?thesis
          by(simp add: exp_qbs_Mx_def)
      qed
      finally show "(\<lambda>x y. rec_list' (fst y) (snd y) (Suc n, x)) \<circ> \<alpha> \<in> qbs_Mx (exp_qbs (Y \<Otimes>\<^sub>Q exp_qbs X (exp_qbs (list_of X) (exp_qbs Y Y))) Y)" .
    qed
  qed
qed simp

end


subsection \<open>Types\<close>

theory Types
  imports Syntax
begin

text\<open>We implement typing environments as (total) functions from natural numbers to types,
     following the approach of Stefan Berghofer in his formalisation of the simply typed
     $\lambda$-calculus in the Isabelle/HOL library.
     An empty typing environment may be represented by an arbitrary function of the correct type
     as it will never be queried when a typing judgement is valid. We split typing environments,
     dedicating one environment to $\lambda$-variables and another to $\mu$-variables, and
     use $\Gamma$ and $\Delta$ to range over the former and latter, respectively.\<close>

text\<open>From src/HOL/Proofs/LambdaType.thy\<close>

definition
  shift :: "(nat \<Rightarrow> 'a) \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a"  ("_\<langle>_:_\<rangle>" [90, 0, 0] 91) where
  "e\<langle>i:a\<rangle> = (\<lambda>j. if j < i then e j else if j = i then a else e (j-1))"

lemma shift_gt [simp]: "j < i \<Longrightarrow> (e\<langle>i:T\<rangle>) j = e j"
  by (simp add: shift_def)

lemma shift_lt [simp]: "i < j \<Longrightarrow> (e\<langle>i:T\<rangle>) j = e (j - 1)"
  by (simp add: shift_def)

lemma shift_commute [simp]: "e\<langle>i:U\<rangle>\<langle>0:T\<rangle> = e\<langle>0:T\<rangle>\<langle>Suc i:U\<rangle>"
  by (rule ext) (simp_all add: shift_def split: nat.split, force)

inductive typing_trm :: "(nat \<Rightarrow> type) \<Rightarrow> (nat \<Rightarrow> type) \<Rightarrow> trm \<Rightarrow> type \<Rightarrow> bool"
     ("_ , _ \<turnstile>\<^sub>T _ : _" [50, 50, 50, 50] 50)
and typing_cmd :: "(nat \<Rightarrow> type) \<Rightarrow> (nat \<Rightarrow> type) \<Rightarrow> cmd \<Rightarrow> bool"
     ("_ , _ \<turnstile>\<^sub>C _" [50, 50, 50] 50)
where
  var [intro!]: "\<lbrakk> \<Gamma> x = T \<rbrakk> \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile>\<^sub>T `x : T" |
  app [intro!]: "\<lbrakk> \<Gamma>, \<Delta> \<turnstile>\<^sub>T t : (T1\<rightarrow>T2); \<Gamma>, \<Delta> \<turnstile>\<^sub>T s : T1 \<rbrakk>
                    \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile>\<^sub>T (t\<degree>s) : T2" |
  lambda [intro!]: "\<lbrakk> \<Gamma>\<langle>0:T1\<rangle>, \<Delta> \<turnstile>\<^sub>T t : T2 \<rbrakk>
                    \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile>\<^sub>T (\<lambda> T1 : t) : (T1\<rightarrow>T2)" |
  activate [intro!]: "\<lbrakk> \<Gamma>, \<Delta>\<langle>0:T\<rangle> \<turnstile>\<^sub>C c \<rbrakk> \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile>\<^sub>T (\<mu> T : c) : T" |
  passivate [intro!]: "\<lbrakk> \<Gamma>, \<Delta> \<turnstile>\<^sub>T t : T; \<Delta> x = T\<rbrakk> \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile>\<^sub>C (<x> t)"

inductive_cases typing_elims [elim!]:
  "\<Gamma>, \<Delta> \<turnstile>\<^sub>T `x : T"
  "\<Gamma>, \<Delta> \<turnstile>\<^sub>T t\<degree>s : T"
  "\<Gamma>, \<Delta> \<turnstile>\<^sub>T \<lambda> T1 : t : T"
  "\<Gamma>, \<Delta> \<turnstile>\<^sub>T \<mu> T1 : t : T"
  "\<Gamma>, \<Delta> \<turnstile>\<^sub>C <x> t"

inductive_cases type_arrow_elim:
  "\<Gamma> , \<Delta> \<turnstile>\<^sub>T t : T1 \<rightarrow> T2"

lemma uniqueness:
  "\<Gamma>, \<Delta> \<turnstile>\<^sub>T t : T1 \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile>\<^sub>T t : T2 \<Longrightarrow> T1 = T2"
  "\<Gamma>, \<Delta> \<turnstile>\<^sub>C c \<Longrightarrow> \<Gamma>, \<Delta> \<turnstile>\<^sub>C c"
  apply(induct arbitrary: T2 rule: typing_trm_typing_cmd.inducts)
  using typing_cmd.cases apply blast+
done

end


(* Title: Examples/SML_Relativization/Topology/SML_Product_Topology.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section\<open>Relativization of the results about product topologies\<close>
theory SML_Product_Topology
  imports
    SML_Topological_Space
    "../Foundations/Product_Type_Ext"
begin

subsection\<open>Definitions and common properties\<close>

ud\<open>
  open_prod_inst.open_prod::
    ('a::topological_space \<times> 'b::topological_space) set \<Rightarrow> _
  \<close>
ud\<open>open::('a::topological_space \<times> 'b::topological_space) set \<Rightarrow> bool\<close>

ctr relativization
  synthesis ctr_simps
  assumes [transfer_domain_rule, transfer_rule]:
    "Domainp B = (\<lambda>x. x \<in> U\<^sub>1)" "Domainp A = (\<lambda>x. x \<in> U\<^sub>2)"
    and [transfer_rule]: "bi_unique A" "right_total A"
      "bi_unique B" "right_total B"
  trp (?'a A) and (?'b B)
  in open_ow: open_prod.with_def
    (\<open>'(/on _ _ with _ _ : \<guillemotleft>open\<guillemotright> _/')\<close> [1000, 999, 1000, 999, 1000] 10)

locale product_topology_ow =
  ts\<^sub>1: topological_space_ow U\<^sub>1 \<tau>\<^sub>1 + ts\<^sub>2: topological_space_ow U\<^sub>2 \<tau>\<^sub>2
  for U\<^sub>1 :: "'at set" and \<tau>\<^sub>1 :: "'at set \<Rightarrow> bool"
    and U\<^sub>2 :: "'bt set"and \<tau>\<^sub>2 :: "'bt set \<Rightarrow> bool" +
  fixes \<tau> :: "('at \<times> 'bt) set \<Rightarrow> bool"
  assumes open_prod[tts_implicit]: "\<tau> = open_ow U\<^sub>1 U\<^sub>2 \<tau>\<^sub>2 \<tau>\<^sub>1"
begin

sublocale topological_space_ow \<open>U\<^sub>1 \<times> U\<^sub>2\<close> \<tau>
proof
  let ?U = "U\<^sub>1 \<times> U\<^sub>2"
  have open_prod': "\<tau> S = open_ow U\<^sub>1 U\<^sub>2 \<tau>\<^sub>2 \<tau>\<^sub>1 S" for S
    by (simp only: open_prod)
  note op = open_prod'[unfolded open_ow_def, THEN iffD2, rule_format]
  show "\<tau> (U\<^sub>1 \<times> U\<^sub>2)" by (rule op) auto
  show "\<lbrakk> S \<subseteq> ?U; T \<subseteq> ?U; \<tau> S; \<tau> T \<rbrakk> \<Longrightarrow> \<tau> (S \<inter> T)" for S T
  proof-
    assume "S \<subseteq> ?U" and "T \<subseteq> ?U" and "\<tau> S" and "\<tau> T"
    from \<open>S \<subseteq> ?U\<close> \<open>T \<subseteq> ?U\<close> have "S \<inter> T \<subseteq> ?U" by auto
    show "\<tau> (S \<inter> T)"
    proof(rule op)
      fix x assume "x \<in> S \<inter> T"
      then have "x \<in> S" and "x \<in> T" by auto
      from open_prod'[
          unfolded open_ow_def, THEN iffD1, rule_format, OF \<open>\<tau> S\<close> \<open>x \<in> S\<close>
          ]
      obtain A\<^sub>S B\<^sub>S where
        "A\<^sub>S \<subseteq> U\<^sub>1" "B\<^sub>S \<subseteq> U\<^sub>2" "\<tau>\<^sub>1 A\<^sub>S" "\<tau>\<^sub>2 B\<^sub>S" "x \<in> A\<^sub>S \<times> B\<^sub>S" "A\<^sub>S \<times> B\<^sub>S \<subseteq> S"
        by auto
      from open_prod'[
          unfolded open_ow_def, THEN iffD1, rule_format,
          OF \<open>\<tau> T\<close> \<open>x \<in> T\<close>
          ]
      obtain A\<^sub>T B\<^sub>T where
        "A\<^sub>T \<subseteq> U\<^sub>1" "B\<^sub>T \<subseteq> U\<^sub>2" "\<tau>\<^sub>1 A\<^sub>T" "\<tau>\<^sub>2 B\<^sub>T" "x \<in> A\<^sub>T \<times> B\<^sub>T" "A\<^sub>T \<times> B\<^sub>T \<subseteq> T"
        by auto
      from \<open>A\<^sub>S \<subseteq> U\<^sub>1\<close> \<open>A\<^sub>T \<subseteq> U\<^sub>1\<close> have "A\<^sub>S \<inter> A\<^sub>T \<subseteq> U\<^sub>1" by auto
      moreover from \<open>B\<^sub>S \<subseteq> U\<^sub>2\<close> \<open>B\<^sub>T \<subseteq> U\<^sub>2\<close> have "B\<^sub>S \<inter> B\<^sub>T \<subseteq> U\<^sub>2" by auto
      moreover from \<open>A\<^sub>S \<subseteq> U\<^sub>1\<close> \<open>A\<^sub>T \<subseteq> U\<^sub>1\<close> \<open>\<tau>\<^sub>1 A\<^sub>S\<close> \<open>\<tau>\<^sub>1 A\<^sub>T\<close> have "\<tau>\<^sub>1 (A\<^sub>S \<inter> A\<^sub>T)"
        by auto
      moreover from \<open>B\<^sub>S \<subseteq> U\<^sub>2\<close> \<open>B\<^sub>T \<subseteq> U\<^sub>2\<close> \<open>\<tau>\<^sub>2 B\<^sub>S\<close> \<open>\<tau>\<^sub>2 B\<^sub>T\<close> have "\<tau>\<^sub>2 (B\<^sub>S \<inter> B\<^sub>T)"
        by auto
      moreover from \<open>x \<in> A\<^sub>S \<times> B\<^sub>S\<close> \<open>x \<in> A\<^sub>T \<times> B\<^sub>T\<close> have
        "x \<in> (A\<^sub>S \<inter> A\<^sub>T) \<times> (B\<^sub>S \<inter> B\<^sub>T)"
        by clarsimp
      moreover from \<open>A\<^sub>S \<times> B\<^sub>S \<subseteq> S\<close> \<open>A\<^sub>T \<times> B\<^sub>T \<subseteq> T\<close> have
        "(A\<^sub>S \<inter> A\<^sub>T) \<times> (B\<^sub>S \<inter> B\<^sub>T) \<subseteq> S \<inter> T"
        by auto
      ultimately show
        "\<exists>A\<in>Pow U\<^sub>1. \<exists>B\<in>Pow U\<^sub>2. \<tau>\<^sub>1 A \<and> \<tau>\<^sub>2 B \<and> A \<times> B \<subseteq> S \<inter> T \<and> x \<in> A \<times> B"
        by auto
    qed
  qed
  show "\<lbrakk> K \<subseteq> Pow ?U; \<forall>S\<in>K. \<tau> S \<rbrakk> \<Longrightarrow> \<tau> (\<Union>K)" for K
  proof -
    assume "K \<subseteq> Pow ?U" and "\<forall>S\<in>K. \<tau> S"
    from \<open>K \<subseteq> Pow ?U\<close> have "\<Union>K \<subseteq> ?U" by auto
    show "\<tau> (\<Union>K)"
    proof(rule op)
      fix x assume "x \<in> \<Union>K"
      then obtain k where k: "x \<in> k" and "k \<in> K" by clarsimp
      from \<open>k \<in> K\<close> have "k \<subseteq> \<Union>K" by auto
      from \<open>k \<in> K\<close> have "\<tau> k" by (rule \<open>\<forall>S\<in>K. \<tau> S\<close>[rule_format])
      from open_prod'[
          unfolded open_ow_def, THEN iffD1, rule_format,
          OF this \<open>x \<in> k\<close>
          ]
      obtain A B where
        "A \<subseteq> U\<^sub>1" "B \<subseteq> U\<^sub>2" "\<tau>\<^sub>1 A" "\<tau>\<^sub>2 B" "x \<in> A \<times> B" "A \<times> B \<subseteq> k"
        by auto
      from \<open>A \<times> B \<subseteq> k\<close> \<open>k \<subseteq> \<Union>K\<close> have "A \<times> B \<subseteq> \<Union>K" by simp
      from \<open>A \<subseteq> U\<^sub>1\<close> \<open>B \<subseteq> U\<^sub>2\<close> \<open>\<tau>\<^sub>1 A\<close> \<open>\<tau>\<^sub>2 B\<close> \<open>x \<in> A \<times> B\<close> this show
        " \<exists>A\<in>Pow U\<^sub>1. \<exists>B\<in>Pow U\<^sub>2. \<tau>\<^sub>1 A \<and> \<tau>\<^sub>2 B \<and> A \<times> B \<subseteq> \<Union> K \<and> x \<in> A \<times> B"
        by auto
    qed
  qed
qed

end

subsection\<open>Transfer rules\<close>

lemma (in product_topology_ow) open_with_oo_transfer[transfer_rule]:
  includes lifting_syntax
  fixes A :: "['at, 'a] \<Rightarrow> bool"
    and B :: "['bt, 'b] \<Rightarrow> bool"
  assumes tdr_U\<^sub>1[transfer_domain_rule]: "Domainp A = (\<lambda>x. x \<in> U\<^sub>1)"
    and [transfer_rule]: "bi_unique A" "right_total A"
    and tdr_U\<^sub>2[transfer_domain_rule]: "Domainp B = (\<lambda>x. x \<in> U\<^sub>2)"
    and [transfer_rule]: "bi_unique B" "right_total B"
    and \<tau>\<^sub>1\<tau>\<^sub>1'[transfer_rule]: "(rel_set A ===> (=)) \<tau>\<^sub>1 \<tau>\<^sub>1'"
    and \<tau>\<^sub>2\<tau>\<^sub>2'[transfer_rule]: "(rel_set B ===> (=)) \<tau>\<^sub>2 \<tau>\<^sub>2'"
  shows "(rel_set (rel_prod A B) ===> (=)) \<tau> (open_prod.with \<tau>\<^sub>2' \<tau>\<^sub>1')"
  unfolding open_prod.with_def
  apply transfer_prover_start
  apply transfer_step+
  apply simp
  apply(fold subset_eq)
  unfolding open_prod open_ow_def tdr_U\<^sub>1 tdr_U\<^sub>2
  by (meson Pow_iff)

subsection\<open>Relativization\<close>

context product_topology_ow
begin

tts_context
  tts: (?'a to U\<^sub>1) and (?'b to U\<^sub>2)
  rewriting ctr_simps
  substituting ts\<^sub>1.topological_space_ow_axioms
    and ts\<^sub>2.topological_space_ow_axioms
  eliminating \<open>?U \<noteq> {}\<close> through (fold tts_implicit, insert closed_empty, simp)
  applying [folded tts_implicit]
begin

tts_lemma open_prod_intro:
  assumes "S \<subseteq> U\<^sub>1 \<times> U\<^sub>2"
    and "\<And>x. \<lbrakk>x \<in> U\<^sub>1 \<times> U\<^sub>2; x \<in> S\<rbrakk> \<Longrightarrow>
      \<exists>A\<in>Pow U\<^sub>1. \<exists>B\<in>Pow U\<^sub>2. \<tau>\<^sub>1 A \<and> \<tau>\<^sub>2 B \<and> A \<times> B \<subseteq> S \<and> x \<in> A \<times> B"
  shows "\<tau> S"
    is open_prod_intro.

tts_lemma open_Times:
  assumes "S \<subseteq> U\<^sub>1" and "T \<subseteq> U\<^sub>2" and "\<tau>\<^sub>1 S" and "\<tau>\<^sub>2 T"
  shows "\<tau> (S \<times> T)"
    is open_Times.

tts_lemma open_vimage_fst:
  assumes "S \<subseteq> U\<^sub>1" and "\<tau>\<^sub>1 S"
  shows "\<tau> (fst -` S \<inter> U\<^sub>1 \<times> U\<^sub>2)"
    is open_vimage_fst.

tts_lemma closed_vimage_fst:
  assumes "S \<subseteq> U\<^sub>1" and "ts\<^sub>1.closed S"
  shows "closed (fst -` S \<inter> U\<^sub>1 \<times> U\<^sub>2)"
    is closed_vimage_fst.

tts_lemma closed_Times:
  assumes "S \<subseteq> U\<^sub>1" and "T \<subseteq> U\<^sub>2" and "ts\<^sub>1.closed S" and "ts\<^sub>2.closed T"
  shows "closed (S \<times> T)"
    is closed_Times.

tts_lemma open_image_fst:
  assumes "S \<subseteq> U\<^sub>1 \<times> U\<^sub>2" and "\<tau> S"
  shows "\<tau>\<^sub>1 (fst ` S)"
    is open_image_fst.

tts_lemma open_image_snd:
  assumes "S \<subseteq> U\<^sub>1 \<times> U\<^sub>2" and "\<tau> S"
  shows "\<tau>\<^sub>2 (snd ` S)"
    is open_image_snd.

end

tts_context
  tts: (?'a to U\<^sub>1) and (?'b to U\<^sub>2)
  rewriting ctr_simps
  substituting ts\<^sub>1.topological_space_ow_axioms
    and ts\<^sub>2.topological_space_ow_axioms
  eliminating \<open>?U \<noteq> {}\<close>
    through (fold tts_implicit, unfold connected_ow_def, simp)
  applying [folded tts_implicit]
begin

tts_lemma connected_Times:
  assumes "S \<subseteq> U\<^sub>1" and "T \<subseteq> U\<^sub>2" and "ts\<^sub>1.connected S" and "ts\<^sub>2.connected T"
  shows "connected (S \<times> T)"
    is connected_Times.

tts_lemma connected_Times_eq:
  assumes "S \<subseteq> U\<^sub>1" and "T \<subseteq> U\<^sub>2"
  shows
    "connected (S \<times> T) = (S = {} \<or> T = {} \<or> ts\<^sub>1.connected S \<and> ts\<^sub>2.connected T)"
  is connected_Times_eq.

end

tts_context
  tts: (?'b to U\<^sub>1) and (?'a to U\<^sub>2)
  rewriting ctr_simps
  substituting ts\<^sub>1.topological_space_ow_axioms
    and ts\<^sub>2.topological_space_ow_axioms
  eliminating \<open>?U \<noteq> {}\<close> through (fold tts_implicit, insert closed_empty, simp)
  applying [folded tts_implicit]
begin

tts_lemma open_vimage_snd:
  assumes "S \<subseteq> U\<^sub>2" and "\<tau>\<^sub>2 S"
  shows "\<tau> (snd -` S \<inter> U\<^sub>1 \<times> U\<^sub>2)"
    is open_vimage_snd.

tts_lemma closed_vimage_snd:
  assumes "S \<subseteq> U\<^sub>2" and "ts\<^sub>2.closed S"
  shows "closed (snd -` S \<inter> U\<^sub>1 \<times> U\<^sub>2)"
    is closed_vimage_snd.

end

end

text\<open>\newpage\<close>

end


(*  Title:      HOL/SET_Protocol/Message_SET.thy
    Author:     Giampaolo Bella
    Author:     Fabio Massacci
    Author:     Lawrence C Paulson
*)

section{*The Message Theory, Modified for SET*}

theory Message_SET
imports Main "~~/src/HOL/Library/Nat_Bijection"
begin

subsection{*General Lemmas*}

text{*Needed occasionally with @{text spy_analz_tac}, e.g. in
     @{text analz_insert_Key_newK}*}

lemma Un_absorb3 [simp] : "A \<union> (B \<union> A) = B \<union> A"
by blast

text{*Collapses redundant cases in the huge protocol proofs*}
lemmas disj_simps = disj_comms disj_left_absorb disj_assoc

text{*Effective with assumptions like @{term "K \<notin> range pubK"} and
   @{term "K \<notin> invKey`range pubK"}*}
lemma notin_image_iff: "(y \<notin> f`I) = (\<forall>i\<in>I. f i \<noteq> y)"
by blast

text{*Effective with the assumption @{term "KK \<subseteq> - (range(invKey o pubK))"} *}
lemma disjoint_image_iff: "(A <= - (f`I)) = (\<forall>i\<in>I. f i \<notin> A)"
by blast

type_synonym key = nat

consts
  all_symmetric :: bool        --{*true if all keys are symmetric*}
  invKey        :: "key=>key"  --{*inverse of a symmetric key*}

specification (invKey)
  invKey [simp]: "invKey (invKey K) = K"
  invKey_symmetric: "all_symmetric --> invKey = id"
    by (rule exI [of _ id], auto)

text{*The inverse of a symmetric key is itself; that of a public key
      is the private key and vice versa*}

definition symKeys :: "key set" where
  "symKeys == {K. invKey K = K}"

text{*Agents. We allow any number of certification authorities, cardholders
            merchants, and payment gateways.*}
datatype
  agent = CA nat | Cardholder nat | Merchant nat | PG nat | Spy

text{*Messages*}
datatype
     msg = Agent  agent     --{*Agent names*}
         | Number nat       --{*Ordinary integers, timestamps, ...*}
         | Nonce  nat       --{*Unguessable nonces*}
         | Pan    nat       --{*Unguessable Primary Account Numbers (??)*}
         | Key    key       --{*Crypto keys*}
         | Hash   msg       --{*Hashing*}
         | MPair  msg msg   --{*Compound messages*}
         | Crypt  key msg   --{*Encryption, public- or shared-key*}

(*Concrete syntax: messages appear as {|A,B,NA|}, etc...*)
syntax
  "_MTuple"      :: "['a, args] => 'a * 'b"       ("(2{|_,/ _|})")

syntax (xsymbols)
  "_MTuple"      :: "['a, args] => 'a * 'b"       ("(2\<lbrace>_,/ _\<rbrace>)")

translations
  "{|x, y, z|}"   == "{|x, {|y, z|}|}"
  "{|x, y|}"      == "CONST MPair x y"

definition nat_of_agent :: "agent => nat" where
   "nat_of_agent == case_agent (curry prod_encode 0)
                               (curry prod_encode 1)
                               (curry prod_encode 2)
                               (curry prod_encode 3)
                               (prod_encode (4,0))"
    --{*maps each agent to a unique natural number, for specifications*}

text{*The function is indeed injective*}
lemma inj_nat_of_agent: "inj nat_of_agent"
by (simp add: nat_of_agent_def inj_on_def curry_def prod_encode_eq split: agent.split)

definition
  (*Keys useful to decrypt elements of a message set*)
  keysFor :: "msg set => key set"
  where "keysFor H = invKey ` {K. \<exists>X. Crypt K X \<in> H}"

subsubsection{*Inductive definition of all "parts" of a message.*}

inductive_set
  parts :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj [intro]:               "X \<in> H ==> X \<in> parts H"
  | Fst:         "{|X,Y|}   \<in> parts H ==> X \<in> parts H"
  | Snd:         "{|X,Y|}   \<in> parts H ==> Y \<in> parts H"
  | Body:        "Crypt K X \<in> parts H ==> X \<in> parts H"

(*Monotonicity*)
lemma parts_mono: "G<=H ==> parts(G) <= parts(H)"
apply auto
apply (erule parts.induct)
apply (auto dest: Fst Snd Body)
done

subsubsection{*Inverse of keys*}

(*Equations hold because constructors are injective; cannot prove for all f*)
lemma Key_image_eq [simp]: "(Key x \<in> Key`A) = (x\<in>A)"
by auto

lemma Nonce_Key_image_eq [simp]: "(Nonce x \<notin> Key`A)"
by auto

lemma Cardholder_image_eq [simp]: "(Cardholder x \<in> Cardholder`A) = (x \<in> A)"
by auto

lemma CA_image_eq [simp]: "(CA x \<in> CA`A) = (x \<in> A)"
by auto

lemma Pan_image_eq [simp]: "(Pan x \<in> Pan`A) = (x \<in> A)"
by auto

lemma Pan_Key_image_eq [simp]: "(Pan x \<notin> Key`A)"
by auto

lemma Nonce_Pan_image_eq [simp]: "(Nonce x \<notin> Pan`A)"
by auto

lemma invKey_eq [simp]: "(invKey K = invKey K') = (K=K')"
apply safe
apply (drule_tac f = invKey in arg_cong, simp)
done

subsection{*keysFor operator*}

lemma keysFor_empty [simp]: "keysFor {} = {}"
by (unfold keysFor_def, blast)

lemma keysFor_Un [simp]: "keysFor (H \<union> H') = keysFor H \<union> keysFor H'"
by (unfold keysFor_def, blast)

lemma keysFor_UN [simp]: "keysFor (\<Union>i\<in>A. H i) = (\<Union>i\<in>A. keysFor (H i))"
by (unfold keysFor_def, blast)

(*Monotonicity*)
lemma keysFor_mono: "G\<subseteq>H ==> keysFor(G) \<subseteq> keysFor(H)"
by (unfold keysFor_def, blast)

lemma keysFor_insert_Agent [simp]: "keysFor (insert (Agent A) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Nonce [simp]: "keysFor (insert (Nonce N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Number [simp]: "keysFor (insert (Number N) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Key [simp]: "keysFor (insert (Key K) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Pan [simp]: "keysFor (insert (Pan A) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Hash [simp]: "keysFor (insert (Hash X) H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_MPair [simp]: "keysFor (insert {|X,Y|} H) = keysFor H"
by (unfold keysFor_def, auto)

lemma keysFor_insert_Crypt [simp]:
    "keysFor (insert (Crypt K X) H) = insert (invKey K) (keysFor H)"
by (unfold keysFor_def, auto)

lemma keysFor_image_Key [simp]: "keysFor (Key`E) = {}"
by (unfold keysFor_def, auto)

lemma Crypt_imp_invKey_keysFor: "Crypt K X \<in> H ==> invKey K \<in> keysFor H"
by (unfold keysFor_def, blast)

subsection{*Inductive relation "parts"*}

lemma MPair_parts:
     "[| {|X,Y|} \<in> parts H;
         [| X \<in> parts H; Y \<in> parts H |] ==> P |] ==> P"
by (blast dest: parts.Fst parts.Snd)

declare MPair_parts [elim!]  parts.Body [dest!]
text{*NB These two rules are UNSAFE in the formal sense, as they discard the
     compound message.  They work well on THIS FILE.
  @{text MPair_parts} is left as SAFE because it speeds up proofs.
  The Crypt rule is normally kept UNSAFE to avoid breaking up certificates.*}

lemma parts_increasing: "H \<subseteq> parts(H)"
by blast

lemmas parts_insertI = subset_insertI [THEN parts_mono, THEN subsetD]

lemma parts_empty [simp]: "parts{} = {}"
apply safe
apply (erule parts.induct, blast+)
done

lemma parts_emptyE [elim!]: "X\<in> parts{} ==> P"
by simp

(*WARNING: loops if H = {Y}, therefore must not be repeated!*)
lemma parts_singleton: "X\<in> parts H ==> \<exists>Y\<in>H. X\<in> parts {Y}"
by (erule parts.induct, fast+)

subsubsection{*Unions*}

lemma parts_Un_subset1: "parts(G) \<union> parts(H) \<subseteq> parts(G \<union> H)"
by (intro Un_least parts_mono Un_upper1 Un_upper2)

lemma parts_Un_subset2: "parts(G \<union> H) \<subseteq> parts(G) \<union> parts(H)"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_Un [simp]: "parts(G \<union> H) = parts(G) \<union> parts(H)"
by (intro equalityI parts_Un_subset1 parts_Un_subset2)

lemma parts_insert: "parts (insert X H) = parts {X} \<union> parts H"
apply (subst insert_is_Un [of _ H])
apply (simp only: parts_Un)
done

(*TWO inserts to avoid looping.  This rewrite is better than nothing.
  Not suitable for Addsimps: its behaviour can be strange.*)
lemma parts_insert2:
     "parts (insert X (insert Y H)) = parts {X} \<union> parts {Y} \<union> parts H"
apply (simp add: Un_assoc)
apply (simp add: parts_insert [symmetric])
done

lemma parts_UN_subset1: "(\<Union>x\<in>A. parts(H x)) \<subseteq> parts(\<Union>x\<in>A. H x)"
by (intro UN_least parts_mono UN_upper)

lemma parts_UN_subset2: "parts(\<Union>x\<in>A. H x) \<subseteq> (\<Union>x\<in>A. parts(H x))"
apply (rule subsetI)
apply (erule parts.induct, blast+)
done

lemma parts_UN [simp]: "parts(\<Union>x\<in>A. H x) = (\<Union>x\<in>A. parts(H x))"
by (intro equalityI parts_UN_subset1 parts_UN_subset2)

(*Added to simplify arguments to parts, analz and synth.
  NOTE: the UN versions are no longer used!*)

text{*This allows @{text blast} to simplify occurrences of
  @{term "parts(G\<union>H)"} in the assumption.*}
declare parts_Un [THEN equalityD1, THEN subsetD, THEN UnE, elim!]

lemma parts_insert_subset: "insert X (parts H) \<subseteq> parts(insert X H)"
by (blast intro: parts_mono [THEN [2] rev_subsetD])

subsubsection{*Idempotence and transitivity*}

lemma parts_partsD [dest!]: "X\<in> parts (parts H) ==> X\<in> parts H"
by (erule parts.induct, blast+)

lemma parts_idem [simp]: "parts (parts H) = parts H"
by blast

lemma parts_trans: "[| X\<in> parts G;  G \<subseteq> parts H |] ==> X\<in> parts H"
by (drule parts_mono, blast)

(*Cut*)
lemma parts_cut:
     "[| Y\<in> parts (insert X G);  X\<in> parts H |] ==> Y\<in> parts (G \<union> H)"
by (erule parts_trans, auto)

lemma parts_cut_eq [simp]: "X\<in> parts H ==> parts (insert X H) = parts H"
by (force dest!: parts_cut intro: parts_insertI)

subsubsection{*Rewrite rules for pulling out atomic messages*}

lemmas parts_insert_eq_I = equalityI [OF subsetI parts_insert_subset]

lemma parts_insert_Agent [simp]:
     "parts (insert (Agent agt) H) = insert (Agent agt) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Nonce [simp]:
     "parts (insert (Nonce N) H) = insert (Nonce N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Number [simp]:
     "parts (insert (Number N) H) = insert (Number N) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Key [simp]:
     "parts (insert (Key K) H) = insert (Key K) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Pan [simp]:
     "parts (insert (Pan A) H) = insert (Pan A) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Hash [simp]:
     "parts (insert (Hash X) H) = insert (Hash X) (parts H)"
apply (rule parts_insert_eq_I)
apply (erule parts.induct, auto)
done

lemma parts_insert_Crypt [simp]:
     "parts (insert (Crypt K X) H) =
          insert (Crypt K X) (parts (insert X H))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (erule parts.induct)
apply (blast intro: parts.Body)+
done

lemma parts_insert_MPair [simp]:
     "parts (insert {|X,Y|} H) =
          insert {|X,Y|} (parts (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct, auto)
apply (erule parts.induct)
apply (blast intro: parts.Fst parts.Snd)+
done

lemma parts_image_Key [simp]: "parts (Key`N) = Key`N"
apply auto
apply (erule parts.induct, auto)
done

lemma parts_image_Pan [simp]: "parts (Pan`A) = Pan`A"
apply auto
apply (erule parts.induct, auto)
done

(*In any message, there is an upper bound N on its greatest nonce.*)
lemma msg_Nonce_supply: "\<exists>N. \<forall>n. N\<le>n --> Nonce n \<notin> parts {msg}"
apply (induct_tac "msg")
apply (simp_all (no_asm_simp) add: exI parts_insert2)
(*MPair case: blast_tac works out the necessary sum itself!*)
prefer 2 apply (blast elim!: add_leE)
(*Nonce case*)
apply (rename_tac nat)
apply (rule_tac x = "N + Suc nat" in exI)
apply (auto elim!: add_leE)
done

(* Ditto, for numbers.*)
lemma msg_Number_supply: "\<exists>N. \<forall>n. N<=n --> Number n \<notin> parts {msg}"
apply (induct_tac "msg")
apply (simp_all (no_asm_simp) add: exI parts_insert2)
prefer 2 apply (blast elim!: add_leE)
apply (rename_tac nat)
apply (rule_tac x = "N + Suc nat" in exI, auto)
done

subsection{*Inductive relation "analz"*}

text{*Inductive definition of "analz" -- what can be broken down from a set of
    messages, including keys.  A form of downward closure.  Pairs can
    be taken apart; messages decrypted with known keys.*}

inductive_set
  analz :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj [intro,simp] :    "X \<in> H ==> X \<in> analz H"
  | Fst:     "{|X,Y|} \<in> analz H ==> X \<in> analz H"
  | Snd:     "{|X,Y|} \<in> analz H ==> Y \<in> analz H"
  | Decrypt [dest]:
             "[|Crypt K X \<in> analz H; Key(invKey K): analz H|] ==> X \<in> analz H"

(*Monotonicity; Lemma 1 of Lowe's paper*)
lemma analz_mono: "G<=H ==> analz(G) <= analz(H)"
apply auto
apply (erule analz.induct)
apply (auto dest: Fst Snd)
done

text{*Making it safe speeds up proofs*}
lemma MPair_analz [elim!]:
     "[| {|X,Y|} \<in> analz H;
             [| X \<in> analz H; Y \<in> analz H |] ==> P
          |] ==> P"
by (blast dest: analz.Fst analz.Snd)

lemma analz_increasing: "H \<subseteq> analz(H)"
by blast

lemma analz_subset_parts: "analz H \<subseteq> parts H"
apply (rule subsetI)
apply (erule analz.induct, blast+)
done

lemmas analz_into_parts = analz_subset_parts [THEN subsetD]

lemmas not_parts_not_analz = analz_subset_parts [THEN contra_subsetD]

lemma parts_analz [simp]: "parts (analz H) = parts H"
apply (rule equalityI)
apply (rule analz_subset_parts [THEN parts_mono, THEN subset_trans], simp)
apply (blast intro: analz_increasing [THEN parts_mono, THEN subsetD])
done

lemma analz_parts [simp]: "analz (parts H) = parts H"
apply auto
apply (erule analz.induct, auto)
done

lemmas analz_insertI = subset_insertI [THEN analz_mono, THEN [2] rev_subsetD]

subsubsection{*General equational properties*}

lemma analz_empty [simp]: "analz{} = {}"
apply safe
apply (erule analz.induct, blast+)
done

(*Converse fails: we can analz more from the union than from the
  separate parts, as a key in one might decrypt a message in the other*)
lemma analz_Un: "analz(G) \<union> analz(H) \<subseteq> analz(G \<union> H)"
by (intro Un_least analz_mono Un_upper1 Un_upper2)

lemma analz_insert: "insert X (analz H) \<subseteq> analz(insert X H)"
by (blast intro: analz_mono [THEN [2] rev_subsetD])

subsubsection{*Rewrite rules for pulling out atomic messages*}

lemmas analz_insert_eq_I = equalityI [OF subsetI analz_insert]

lemma analz_insert_Agent [simp]:
     "analz (insert (Agent agt) H) = insert (Agent agt) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Nonce [simp]:
     "analz (insert (Nonce N) H) = insert (Nonce N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Number [simp]:
     "analz (insert (Number N) H) = insert (Number N) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Hash [simp]:
     "analz (insert (Hash X) H) = insert (Hash X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

(*Can only pull out Keys if they are not needed to decrypt the rest*)
lemma analz_insert_Key [simp]:
    "K \<notin> keysFor (analz H) ==>
          analz (insert (Key K) H) = insert (Key K) (analz H)"
apply (unfold keysFor_def)
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_MPair [simp]:
     "analz (insert {|X,Y|} H) =
          insert {|X,Y|} (analz (insert X (insert Y H)))"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct, auto)
apply (erule analz.induct)
apply (blast intro: analz.Fst analz.Snd)+
done

(*Can pull out enCrypted message if the Key is not known*)
lemma analz_insert_Crypt:
     "Key (invKey K) \<notin> analz H
      ==> analz (insert (Crypt K X) H) = insert (Crypt K X) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma analz_insert_Pan [simp]:
     "analz (insert (Pan A) H) = insert (Pan A) (analz H)"
apply (rule analz_insert_eq_I)
apply (erule analz.induct, auto)
done

lemma lemma1: "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) \<subseteq>
               insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule_tac x = x in analz.induct, auto)
done

lemma lemma2: "Key (invKey K) \<in> analz H ==>
               insert (Crypt K X) (analz (insert X H)) \<subseteq>
               analz (insert (Crypt K X) H)"
apply auto
apply (erule_tac x = x in analz.induct, auto)
apply (blast intro: analz_insertI analz.Decrypt)
done

lemma analz_insert_Decrypt:
     "Key (invKey K) \<in> analz H ==>
               analz (insert (Crypt K X) H) =
               insert (Crypt K X) (analz (insert X H))"
by (intro equalityI lemma1 lemma2)

(*Case analysis: either the message is secure, or it is not!
  Effective, but can cause subgoals to blow up!
  Use with split_if;  apparently split_tac does not cope with patterns
  such as "analz (insert (Crypt K X) H)" *)
lemma analz_Crypt_if [simp]:
     "analz (insert (Crypt K X) H) =
          (if (Key (invKey K) \<in> analz H)
           then insert (Crypt K X) (analz (insert X H))
           else insert (Crypt K X) (analz H))"
by (simp add: analz_insert_Crypt analz_insert_Decrypt)

(*This rule supposes "for the sake of argument" that we have the key.*)
lemma analz_insert_Crypt_subset:
     "analz (insert (Crypt K X) H) \<subseteq>
           insert (Crypt K X) (analz (insert X H))"
apply (rule subsetI)
apply (erule analz.induct, auto)
done

lemma analz_image_Key [simp]: "analz (Key`N) = Key`N"
apply auto
apply (erule analz.induct, auto)
done

lemma analz_image_Pan [simp]: "analz (Pan`A) = Pan`A"
apply auto
apply (erule analz.induct, auto)
done

subsubsection{*Idempotence and transitivity*}

lemma analz_analzD [dest!]: "X\<in> analz (analz H) ==> X\<in> analz H"
by (erule analz.induct, blast+)

lemma analz_idem [simp]: "analz (analz H) = analz H"
by blast

lemma analz_trans: "[| X\<in> analz G;  G \<subseteq> analz H |] ==> X\<in> analz H"
by (drule analz_mono, blast)

(*Cut; Lemma 2 of Lowe*)
lemma analz_cut: "[| Y\<in> analz (insert X H);  X\<in> analz H |] ==> Y\<in> analz H"
by (erule analz_trans, blast)

(*Cut can be proved easily by induction on
   "Y: analz (insert X H) ==> X: analz H --> Y: analz H"
*)

(*This rewrite rule helps in the simplification of messages that involve
  the forwarding of unknown components (X).  Without it, removing occurrences
  of X can be very complicated. *)
lemma analz_insert_eq: "X\<in> analz H ==> analz (insert X H) = analz H"
by (blast intro: analz_cut analz_insertI)

text{*A congruence rule for "analz"*}

lemma analz_subset_cong:
     "[| analz G \<subseteq> analz G'; analz H \<subseteq> analz H'
               |] ==> analz (G \<union> H) \<subseteq> analz (G' \<union> H')"
apply clarify
apply (erule analz.induct)
apply (best intro: analz_mono [THEN subsetD])+
done

lemma analz_cong:
     "[| analz G = analz G'; analz H = analz H'
               |] ==> analz (G \<union> H) = analz (G' \<union> H')"
by (intro equalityI analz_subset_cong, simp_all)

lemma analz_insert_cong:
     "analz H = analz H' ==> analz(insert X H) = analz(insert X H')"
by (force simp only: insert_def intro!: analz_cong)

(*If there are no pairs or encryptions then analz does nothing*)
lemma analz_trivial:
     "[| \<forall>X Y. {|X,Y|} \<notin> H;  \<forall>X K. Crypt K X \<notin> H |] ==> analz H = H"
apply safe
apply (erule analz.induct, blast+)
done

(*These two are obsolete (with a single Spy) but cost little to prove...*)
lemma analz_UN_analz_lemma:
     "X\<in> analz (\<Union>i\<in>A. analz (H i)) ==> X\<in> analz (\<Union>i\<in>A. H i)"
apply (erule analz.induct)
apply (blast intro: analz_mono [THEN [2] rev_subsetD])+
done

lemma analz_UN_analz [simp]: "analz (\<Union>i\<in>A. analz (H i)) = analz (\<Union>i\<in>A. H i)"
by (blast intro: analz_UN_analz_lemma analz_mono [THEN [2] rev_subsetD])

subsection{*Inductive relation "synth"*}

text{*Inductive definition of "synth" -- what can be built up from a set of
    messages.  A form of upward closure.  Pairs can be built, messages
    encrypted with known keys.  Agent names are public domain.
    Numbers can be guessed, but Nonces cannot be.*}

inductive_set
  synth :: "msg set => msg set"
  for H :: "msg set"
  where
    Inj    [intro]:   "X \<in> H ==> X \<in> synth H"
  | Agent  [intro]:   "Agent agt \<in> synth H"
  | Number [intro]:   "Number n  \<in> synth H"
  | Hash   [intro]:   "X \<in> synth H ==> Hash X \<in> synth H"
  | MPair  [intro]:   "[|X \<in> synth H;  Y \<in> synth H|] ==> {|X,Y|} \<in> synth H"
  | Crypt  [intro]:   "[|X \<in> synth H;  Key(K) \<in> H|] ==> Crypt K X \<in> synth H"

(*Monotonicity*)
lemma synth_mono: "G<=H ==> synth(G) <= synth(H)"
apply auto
apply (erule synth.induct)
apply (auto dest: Fst Snd Body)
done

(*NO Agent_synth, as any Agent name can be synthesized.  Ditto for Number*)
inductive_cases Nonce_synth [elim!]: "Nonce n \<in> synth H"
inductive_cases Key_synth   [elim!]: "Key K \<in> synth H"
inductive_cases Hash_synth  [elim!]: "Hash X \<in> synth H"
inductive_cases MPair_synth [elim!]: "{|X,Y|} \<in> synth H"
inductive_cases Crypt_synth [elim!]: "Crypt K X \<in> synth H"
inductive_cases Pan_synth   [elim!]: "Pan A \<in> synth H"

lemma synth_increasing: "H \<subseteq> synth(H)"
by blast

subsubsection{*Unions*}

(*Converse fails: we can synth more from the union than from the
  separate parts, building a compound message using elements of each.*)
lemma synth_Un: "synth(G) \<union> synth(H) \<subseteq> synth(G \<union> H)"
by (intro Un_least synth_mono Un_upper1 Un_upper2)

lemma synth_insert: "insert X (synth H) \<subseteq> synth(insert X H)"
by (blast intro: synth_mono [THEN [2] rev_subsetD])

subsubsection{*Idempotence and transitivity*}

lemma synth_synthD [dest!]: "X\<in> synth (synth H) ==> X\<in> synth H"
by (erule synth.induct, blast+)

lemma synth_idem: "synth (synth H) = synth H"
by blast

lemma synth_trans: "[| X\<in> synth G;  G \<subseteq> synth H |] ==> X\<in> synth H"
by (drule synth_mono, blast)

(*Cut; Lemma 2 of Lowe*)
lemma synth_cut: "[| Y\<in> synth (insert X H);  X\<in> synth H |] ==> Y\<in> synth H"
by (erule synth_trans, blast)

lemma Agent_synth [simp]: "Agent A \<in> synth H"
by blast

lemma Number_synth [simp]: "Number n \<in> synth H"
by blast

lemma Nonce_synth_eq [simp]: "(Nonce N \<in> synth H) = (Nonce N \<in> H)"
by blast

lemma Crypt_synth_eq [simp]: "Key K \<notin> H ==> (Crypt K X \<in> synth H) = (Crypt K X \<in> H)"
by blast

lemma Pan_synth_eq [simp]: "(Pan A \<in> synth H) = (Pan A \<in> H)"
by blast

lemma keysFor_synth [simp]:
    "keysFor (synth H) = keysFor H \<union> invKey`{K. Key K \<in> H}"
by (unfold keysFor_def, blast)

subsubsection{*Combinations of parts, analz and synth*}

lemma parts_synth [simp]: "parts (synth H) = parts H \<union> synth H"
apply (rule equalityI)
apply (rule subsetI)
apply (erule parts.induct)
apply (blast intro: synth_increasing [THEN parts_mono, THEN subsetD]
                    parts.Fst parts.Snd parts.Body)+
done

lemma analz_analz_Un [simp]: "analz (analz G \<union> H) = analz (G \<union> H)"
apply (intro equalityI analz_subset_cong)+
apply simp_all
done

lemma analz_synth_Un [simp]: "analz (synth G \<union> H) = analz (G \<union> H) \<union> synth G"
apply (rule equalityI)
apply (rule subsetI)
apply (erule analz.induct)
prefer 5 apply (blast intro: analz_mono [THEN [2] rev_subsetD])
apply (blast intro: analz.Fst analz.Snd analz.Decrypt)+
done

lemma analz_synth [simp]: "analz (synth H) = analz H \<union> synth H"
apply (cut_tac H = "{}" in analz_synth_Un)
apply (simp (no_asm_use))
done

subsubsection{*For reasoning about the Fake rule in traces*}

lemma parts_insert_subset_Un: "X\<in> G ==> parts(insert X H) \<subseteq> parts G \<union> parts H"
by (rule subset_trans [OF parts_mono parts_Un_subset2], blast)

(*More specifically for Fake.  Very occasionally we could do with a version
  of the form  parts{X} \<subseteq> synth (analz H) \<union> parts H *)
lemma Fake_parts_insert: "X \<in> synth (analz H) ==>
      parts (insert X H) \<subseteq> synth (analz H) \<union> parts H"
apply (drule parts_insert_subset_Un)
apply (simp (no_asm_use))
apply blast
done

lemma Fake_parts_insert_in_Un:
     "[|Z \<in> parts (insert X H);  X: synth (analz H)|]
      ==> Z \<in>  synth (analz H) \<union> parts H"
by (blast dest: Fake_parts_insert [THEN subsetD, dest])

(*H is sometimes (Key ` KK \<union> spies evs), so can't put G=H*)
lemma Fake_analz_insert:
     "X\<in> synth (analz G) ==>
      analz (insert X H) \<subseteq> synth (analz G) \<union> analz (G \<union> H)"
apply (rule subsetI)
apply (subgoal_tac "x \<in> analz (synth (analz G) \<union> H) ")
prefer 2 apply (blast intro: analz_mono [THEN [2] rev_subsetD] analz_mono [THEN synth_mono, THEN [2] rev_subsetD])
apply (simp (no_asm_use))
apply blast
done

lemma analz_conj_parts [simp]:
     "(X \<in> analz H & X \<in> parts H) = (X \<in> analz H)"
by (blast intro: analz_subset_parts [THEN subsetD])

lemma analz_disj_parts [simp]:
     "(X \<in> analz H | X \<in> parts H) = (X \<in> parts H)"
by (blast intro: analz_subset_parts [THEN subsetD])

(*Without this equation, other rules for synth and analz would yield
  redundant cases*)
lemma MPair_synth_analz [iff]:
     "({|X,Y|} \<in> synth (analz H)) =
      (X \<in> synth (analz H) & Y \<in> synth (analz H))"
by blast

lemma Crypt_synth_analz:
     "[| Key K \<in> analz H;  Key (invKey K) \<in> analz H |]
       ==> (Crypt K X \<in> synth (analz H)) = (X \<in> synth (analz H))"
by blast

lemma Hash_synth_analz [simp]:
     "X \<notin> synth (analz H)
      ==> (Hash{|X,Y|} \<in> synth (analz H)) = (Hash{|X,Y|} \<in> analz H)"
by blast

(*We do NOT want Crypt... messages broken up in protocols!!*)
declare parts.Body [rule del]

text{*Rewrites to push in Key and Crypt messages, so that other messages can
    be pulled out using the @{text analz_insert} rules*}

lemmas pushKeys =
  insert_commute [of "Key K" "Agent C"]
  insert_commute [of "Key K" "Nonce N"]
  insert_commute [of "Key K" "Number N"]
  insert_commute [of "Key K" "Pan PAN"]
  insert_commute [of "Key K" "Hash X"]
  insert_commute [of "Key K" "MPair X Y"]
  insert_commute [of "Key K" "Crypt X K'"]
  for K C N PAN X Y K'

lemmas pushCrypts =
  insert_commute [of "Crypt X K" "Agent C"]
  insert_commute [of "Crypt X K" "Nonce N"]
  insert_commute [of "Crypt X K" "Number N"]
  insert_commute [of "Crypt X K" "Pan PAN"]
  insert_commute [of "Crypt X K" "Hash X'"]
  insert_commute [of "Crypt X K" "MPair X' Y"]
  for X K C N PAN X' Y

text{*Cannot be added with @{text "[simp]"} -- messages should not always be
  re-ordered.*}
lemmas pushes = pushKeys pushCrypts

subsection{*Tactics useful for many protocol proofs*}
(*<*)
ML
{*
(*Analysis of Fake cases.  Also works for messages that forward unknown parts,
  but this application is no longer necessary if analz_insert_eq is used.
  DEPENDS UPON "X" REFERRING TO THE FRADULENT MESSAGE *)

fun impOfSubs th = th RSN (2, @{thm rev_subsetD})

(*Apply rules to break down assumptions of the form
  Y \<in> parts(insert X H)  and  Y \<in> analz(insert X H)
*)
val Fake_insert_tac =
    dresolve_tac [impOfSubs @{thm Fake_analz_insert},
                  impOfSubs @{thm Fake_parts_insert}] THEN'
    eresolve_tac [asm_rl, @{thm synth.Inj}];

fun Fake_insert_simp_tac ctxt i =
  REPEAT (Fake_insert_tac i) THEN asm_full_simp_tac ctxt i;

fun atomic_spy_analz_tac ctxt =
  SELECT_GOAL
    (Fake_insert_simp_tac ctxt 1 THEN
      IF_UNSOLVED
        (Blast.depth_tac (ctxt addIs [@{thm analz_insertI},
            impOfSubs @{thm analz_subset_parts}]) 4 1));

fun spy_analz_tac ctxt i =
  DETERM
   (SELECT_GOAL
     (EVERY
      [  (*push in occurrences of X...*)
       (REPEAT o CHANGED)
           (res_inst_tac ctxt [(("x", 1), "X")] (insert_commute RS ssubst) 1),
       (*...allowing further simplifications*)
       simp_tac ctxt 1,
       REPEAT (FIRSTGOAL (resolve_tac [allI,impI,notI,conjI,iffI])),
       DEPTH_SOLVE (atomic_spy_analz_tac ctxt 1)]) i);
*}
(*>*)

(*By default only o_apply is built-in.  But in the presence of eta-expansion
  this means that some terms displayed as (f o g) will be rewritten, and others
  will not!*)
declare o_def [simp]

lemma Crypt_notin_image_Key [simp]: "Crypt K X \<notin> Key ` A"
by auto

lemma Hash_notin_image_Key [simp] :"Hash X \<notin> Key ` A"
by auto

lemma synth_analz_mono: "G<=H ==> synth (analz(G)) <= synth (analz(H))"
by (simp add: synth_mono analz_mono)

lemma Fake_analz_eq [simp]:
     "X \<in> synth(analz H) ==> synth (analz (insert X H)) = synth (analz H)"
apply (drule Fake_analz_insert[of _ _ "H"])
apply (simp add: synth_increasing[THEN Un_absorb2])
apply (drule synth_mono)
apply (simp add: synth_idem)
apply (blast intro: synth_analz_mono [THEN [2] rev_subsetD])
done

text{*Two generalizations of @{text analz_insert_eq}*}
lemma gen_analz_insert_eq [rule_format]:
     "X \<in> analz H ==> ALL G. H \<subseteq> G --> analz (insert X G) = analz G"
by (blast intro: analz_cut analz_insertI analz_mono [THEN [2] rev_subsetD])

lemma synth_analz_insert_eq [rule_format]:
     "X \<in> synth (analz H)
      ==> ALL G. H \<subseteq> G --> (Key K \<in> analz (insert X G)) = (Key K \<in> analz G)"
apply (erule synth.induct)
apply (simp_all add: gen_analz_insert_eq subset_trans [OF _ subset_insertI])
done

lemma Fake_parts_sing:
     "X \<in> synth (analz H) ==> parts{X} \<subseteq> synth (analz H) \<union> parts H"
apply (rule subset_trans)
 apply (erule_tac [2] Fake_parts_insert)
apply (simp add: parts_mono)
done

lemmas Fake_parts_sing_imp_Un = Fake_parts_sing [THEN [2] rev_subsetD]

method_setup spy_analz = {*
    Scan.succeed (SIMPLE_METHOD' o spy_analz_tac) *}
    "for proving the Fake case when analz is involved"

method_setup atomic_spy_analz = {*
    Scan.succeed (SIMPLE_METHOD' o atomic_spy_analz_tac) *}
    "for debugging spy_analz"

method_setup Fake_insert_simp = {*
    Scan.succeed (SIMPLE_METHOD' o Fake_insert_simp_tac) *}
    "for debugging spy_analz"

end


(* Author:     Tobias Nipkow
*)

section\<open>Tame Properties\<close>

theory TameProps
imports Tame RTranCl
begin

lemma length_disj_filter_le: "\<forall>x \<in> set xs. \<not>(P x \<and> Q x) \<Longrightarrow>
 length(filter P xs) + length(filter Q xs) \<le> length xs"
by(induct xs) auto

lemma tri_quad_le_degree: "tri g v + quad g v \<le> degree g v"
proof -
  let ?fins = "[f \<leftarrow> facesAt g v . final f]"
  have "tri g v + quad g v =
        |[f \<leftarrow> ?fins . triangle f]| + |[f \<leftarrow> ?fins. |vertices f| = 4]|"
    by(simp add:tri_def quad_def)
  also have "\<dots> \<le> |[f \<leftarrow> facesAt g v. final f]|"
    by(rule length_disj_filter_le) simp
  also have "\<dots> \<le> |facesAt g v|" by(rule length_filter_le)
  finally show ?thesis by(simp add:degree_def)
qed

lemma faceCountMax_bound:
 "\<lbrakk> tame g; v \<in> \<V> g \<rbrakk> \<Longrightarrow> tri g v + quad g v \<le> 7"
using tri_quad_le_degree[of g v]
by(auto simp:tame_def tame11b_def split:if_split_asm)

lemma filter_tame_succs:
assumes invP: "invariant P succs" and fin: "\<And>g. final g \<Longrightarrow> succs g = []"
and ok_untame: "\<And>g. P g \<Longrightarrow> \<not> ok g \<Longrightarrow> final g \<and> \<not> tame g"
and gg': "g [succs]\<rightarrow>* g'"
shows "P g \<Longrightarrow> final g' \<Longrightarrow> tame g' \<Longrightarrow> g [filter ok \<circ> succs]\<rightarrow>* g'"
using gg'
proof (induct rule:RTranCl.induct)
  case refl show ?case by(rule RTranCl.refl)
next
  case (succs h h' h'')
  hence "P h'"  using invP by(unfold invariant_def) blast
  show ?case
  proof cases
    assume "ok h'"
    thus ?thesis using succs \<open>P h'\<close> by(fastforce intro:RTranCl.succs)
  next
    assume "\<not> ok h'" note fin_tame = ok_untame[OF \<open>P h'\<close> \<open>\<not> ok h'\<close>]
    have "h'' = h'" using fin_tame
      by(rule_tac RTranCl.cases[OF succs(2)])(auto simp:fin)
    hence False using fin_tame succs by fast
    thus ?case ..
  qed
qed

definition untame :: "(graph \<Rightarrow> bool) \<Rightarrow> bool" where
"untame P \<equiv> \<forall>g. final g \<and> P g \<longrightarrow> \<not> tame g"

lemma filterout_untame_succs:
assumes invP: "invariant P f" and invPU: "invariant (\<lambda>g. P g \<and>  U g) f"
and untame: "untame(\<lambda>g. P g \<and> U g)"
and new_untame: "\<And>g g'. \<lbrakk> P g; g' \<in> set(f g); g' \<notin> set(f' g) \<rbrakk> \<Longrightarrow> U g'"
and gg': "g [f]\<rightarrow>* g'"
shows "P g \<Longrightarrow> final g' \<Longrightarrow> tame g' \<Longrightarrow> g [f']\<rightarrow>* g'"
using gg'
proof (induct rule:RTranCl.induct)
  case refl show ?case by(rule RTranCl.refl)
next
  case (succs h h' h'')
  hence Ph': "P h'"  using invP by(unfold invariant_def) blast
  show ?case
  proof cases
    assume "h' \<in> set(f' h)"
    thus ?thesis using succs Ph' by(blast intro:RTranCl.succs)
  next
    assume "h' \<notin> set(f' h)"
    with succs(4) succs(1) have "U h'" by (rule new_untame)
    hence False using Ph' RTranCl_inv[OF invPU] untame succs
      by (unfold untame_def) fast
    thus ?case ..
  qed
qed

end


(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics for Isabelle/Isar.

    Copyright (C) 2005, 2006  Slawomir Kolodynski

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT,
INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

*)

section \<open>Topology 1b\<close>

theory Topology_ZF_1b imports Topology_ZF_1

begin

text\<open>One of the facts demonstrated in every class on General Topology is that
  in a $T_2$ (Hausdorff) topological space compact sets are closed.
  Formalizing the proof of this fact gave me an interesting insight
  into the role of the Axiom of Choice (AC) in many informal proofs.

  A typical informal proof of this fact goes like this: we want to show
  that the complement of $K$ is open. To do this,
  choose an arbitrary point $y\in K^c$.
  Since $X$ is $T_2$, for every point $x\in K$ we can find an
  open set $U_x$ such that $y\notin \overline{U_x}$.
  Obviously $\{U_x\}_{x\in K}$ covers $K$, so select a finite subcollection
  that covers $K$, and so on. I had never realized that
  such reasoning requires the Axiom of Choice.
  Namely, suppose we have a lemma that states "In $T_2$ spaces,
  if $x\neq y$, then there is an open set
  $U$ such that $x\in U$ and $y\notin \overline{U}$" (like our
  lemma \<open>T2_cl_open_sep\<close> below). This only states that
  the set of such open sets $U$ is not empty. To get the collection
  $\{U_x \}_{x\in K}$ in this proof we have to select one such set
  among many for every $x\in K$ and this is where we use the Axiom of Choice.
  Probably in 99/100 cases when an informal calculus proof states something like
  $\forall \varepsilon \exists \delta_\varepsilon \cdots$ the proof uses AC.
  Most of the time the use of AC in such proofs can be avoided. This is also
  the case for the fact that in a $T_2$ space compact sets are closed.
\<close>

subsection\<open>Compact sets are closed - no need for AC\<close>

text\<open>In this section we show that in a $T_2$ topological
  space compact sets are closed.\<close>

text\<open>First we prove a lemma that in a $T_2$ space two points
  can be separated by the closure of an open set.\<close>

lemma (in topology0) T2_cl_open_sep:
  assumes "T {is T\<^sub>2}"  and "x \<in> \<Union>T"  "y \<in> \<Union>T"   "x\<noteq>y"
  shows "\<exists>U\<in>T. (x\<in>U \<and> y \<notin> cl(U))"
proof -
  from assms have "\<exists>U\<in>T. \<exists>V\<in>T. x\<in>U \<and> y\<in>V \<and> U\<inter>V=0"
    using isT2_def by simp
  then obtain U V where "U\<in>T"  "V\<in>T"  "x\<in>U"  "y\<in>V"  "U\<inter>V=0"
    by auto
  then have "U\<in>T \<and> x\<in>U \<and> y\<in> V \<and> cl(U) \<inter> V = 0"
    using  disj_open_cl_disj by auto
  thus "\<exists>U\<in>T. (x\<in>U \<and> y \<notin> cl(U))" by auto
qed

text\<open>AC-free proof that in a Hausdorff space compact sets
  are closed. To understand the notation recall that in Isabelle/ZF
  \<open>Pow(A)\<close> is the powerset (the set of subsets) of $A$
  and \<open>FinPow(A)\<close> denotes the set of finite subsets of $A$
  in IsarMathLib.\<close>

theorem (in topology0) in_t2_compact_is_cl:
  assumes A1: "T {is T\<^sub>2}" and A2: "K {is compact in} T"
  shows "K {is closed in} T"
proof -
  let ?X = "\<Union>T"
  have "\<forall>y \<in> ?X - K. \<exists>U\<in>T. y\<in>U \<and> U \<subseteq> ?X - K"
  proof -
    { fix y assume "y \<in> ?X"  "y\<notin>K"
      have "\<exists>U\<in>T. y\<in>U \<and> U \<subseteq> ?X - K"
      proof -
	let ?B = "\<Union>x\<in>K. {V\<in>T. x\<in>V \<and> y \<notin> cl(V)}"
	have I: "?B \<in> Pow(T)"  "FinPow(?B) \<subseteq> Pow(?B)"
	  using FinPow_def by auto
	from \<open>K {is compact in} T\<close> \<open>y \<in> ?X\<close>  \<open>y\<notin>K\<close> have
	  "\<forall>x\<in>K. x \<in> ?X \<and> y \<in> ?X \<and> x\<noteq>y"
	  using IsCompact_def by auto
	with \<open>T {is T\<^sub>2}\<close> have "\<forall>x\<in>K. {V\<in>T. x\<in>V \<and> y \<notin> cl(V)} \<noteq> 0"
	  using T2_cl_open_sep by auto
	hence "K \<subseteq> \<Union>?B" by blast
	with \<open>K {is compact in} T\<close> I have
	  "\<exists>N \<in> FinPow(?B). K \<subseteq> \<Union>N"
	  using IsCompact_def by auto
	then obtain N where "N \<in> FinPow(?B)"  "K \<subseteq> \<Union>N"
	  by auto
	with I have "N \<subseteq> ?B" by auto
	hence "\<forall>V\<in>N. V\<in>?B" by auto
	let ?M = "{cl(V). V\<in>N}"
	let ?C = "{D \<in> Pow(?X). D {is closed in} T}"
	from \<open>N \<in> FinPow(?B)\<close> have "\<forall>V\<in>?B. cl(V) \<in> ?C"  "N \<in> FinPow(?B)"
	  using cl_is_closed IsClosed_def by auto
	then have "?M \<in> FinPow(?C)" by (rule fin_image_fin)
	then have "?X - \<Union>?M \<in> T" using fin_union_cl_is_cl IsClosed_def
	  by simp
	moreover from \<open>y \<in> ?X\<close>  \<open>y\<notin>K\<close>  \<open>\<forall>V\<in>N. V\<in>?B\<close> have
	  "y \<in> ?X - \<Union>?M" by simp
	moreover have "?X - \<Union>?M \<subseteq> ?X - K"
	proof -
	  from \<open>\<forall>V\<in>N. V\<in>?B\<close> have "\<Union>N \<subseteq> \<Union>?M" using cl_contains_set by auto
	  with \<open>K \<subseteq> \<Union>N\<close> show "?X - \<Union>?M \<subseteq> ?X - K" by auto
	qed
	ultimately have "\<exists>U. U\<in>T \<and> y \<in> U \<and> U \<subseteq> ?X - K"
	  by auto
	thus "\<exists>U\<in>T. y\<in>U \<and> U \<subseteq> ?X - K" by auto
      qed
    } thus "\<forall>y \<in> ?X - K. \<exists>U\<in>T. y\<in>U \<and> U \<subseteq> ?X - K"
      by auto
  qed
  with A2 show "K {is closed in} T"
    using open_neigh_open IsCompact_def IsClosed_def by auto
qed

end


(*  Title:      HOL/Quotient_Examples/DList.thy
    Author:     Cezary Kaliszyk, University of Tsukuba

Based on typedef version "Library/Dlist" by Florian Haftmann
and theory morphism version by Maksym Bortin
*)

section \<open>Lists with distinct elements\<close>

theory DList
imports "HOL-Library.Quotient_List"
begin

text \<open>Some facts about lists\<close>

lemma remdups_removeAll_commute[simp]:
  "remdups (removeAll x l) = removeAll x (remdups l)"
  by (induct l) auto

lemma removeAll_distinct[simp]:
  assumes "distinct l"
  shows "distinct (removeAll x l)"
  using assms by (induct l) simp_all

lemma removeAll_commute:
  "removeAll x (removeAll y l) = removeAll y (removeAll x l)"
  by (induct l) auto

lemma remdups_hd_notin_tl:
  "remdups dl = h # t \<Longrightarrow> h \<notin> set t"
proof (induct dl arbitrary: h t)
  case Nil
  then show ?case by simp
next
  case (Cons a dl)
  then show ?case by (cases "a \<in> set dl") auto
qed

lemma remdups_repeat:
  "remdups dl = h # t \<Longrightarrow> t = remdups t"
proof (induct dl arbitrary: h t)
  case Nil
  then show ?case by simp
next
  case (Cons a dl)
  then show ?case by (cases "a \<in> set dl") (auto simp: remdups_remdups)
qed

lemma remdups_nil_noteq_cons:
  "remdups (h # t) \<noteq> remdups []"
  "remdups [] \<noteq> remdups (h # t)"
  by auto

lemma remdups_eq_map_eq:
  assumes "remdups xa = remdups ya"
    shows "remdups (map f xa) = remdups (map f ya)"
  using assms
  by (induct xa ya rule: list_induct2')
     (metis (full_types) remdups_nil_noteq_cons(2) remdups_map_remdups)+

lemma remdups_eq_member_eq:
  assumes "remdups xa = remdups ya"
    shows "List.member xa = List.member ya"
  using assms
  unfolding fun_eq_iff List.member_def
  by (induct xa ya rule: list_induct2')
     (metis remdups_nil_noteq_cons set_remdups)+

text \<open>Setting up the quotient type\<close>

definition
  dlist_eq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  [simp]: "dlist_eq xs ys \<longleftrightarrow> remdups xs = remdups ys"

lemma dlist_eq_reflp:
  "reflp dlist_eq"
  by (auto intro: reflpI)

lemma dlist_eq_symp:
  "symp dlist_eq"
  by (auto intro: sympI)

lemma dlist_eq_transp:
  "transp dlist_eq"
  by (auto intro: transpI)

lemma dlist_eq_equivp:
  "equivp dlist_eq"
  by (auto intro: equivpI dlist_eq_reflp dlist_eq_symp dlist_eq_transp)

quotient_type
  'a dlist = "'a list" / "dlist_eq"
  by (rule dlist_eq_equivp)

text \<open>respectfulness and constant definitions\<close>

definition [simp]: "card_remdups = length \<circ> remdups"
definition [simp]: "foldr_remdups f xs e = foldr f (remdups xs) e"

quotient_definition empty where "empty :: 'a dlist"
  is "Nil" .

quotient_definition insert where "insert :: 'a \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist"
  is "Cons" by (metis (mono_tags) List.insert_def dlist_eq_def remdups.simps(2) set_remdups)

quotient_definition "member :: 'a dlist \<Rightarrow> 'a \<Rightarrow> bool"
  is "List.member" by (metis dlist_eq_def remdups_eq_member_eq)

quotient_definition foldr where "foldr :: ('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a dlist \<Rightarrow> 'b \<Rightarrow> 'b"
  is "foldr_remdups" by auto

quotient_definition "remove :: 'a \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist"
  is "removeAll" by force

quotient_definition card where "card :: 'a dlist \<Rightarrow> nat"
  is "card_remdups" by fastforce

quotient_definition map where "map :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a dlist \<Rightarrow> 'b dlist"
  is "List.map :: ('a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list" by (metis dlist_eq_def remdups_eq_map_eq)

quotient_definition filter where "filter :: ('a \<Rightarrow> bool) \<Rightarrow> 'a dlist \<Rightarrow> 'a dlist"
  is "List.filter" by (metis dlist_eq_def remdups_filter)

quotient_definition "list_of_dlist :: 'a dlist \<Rightarrow> 'a list"
  is "remdups" by simp

text \<open>lifted theorems\<close>

lemma dlist_member_insert:
  "member dl x \<Longrightarrow> insert x dl = dl"
  by descending (simp add: List.member_def)

lemma dlist_member_insert_eq:
  "member (insert y dl) x = (x = y \<or> member dl x)"
  by descending (simp add: List.member_def)

lemma dlist_insert_idem:
  "insert x (insert x dl) = insert x dl"
  by descending simp

lemma dlist_insert_not_empty:
  "insert x dl \<noteq> empty"
  by descending auto

lemma not_dlist_member_empty:
  "\<not> member empty x"
  by descending (simp add: List.member_def)

lemma not_dlist_member_remove:
  "\<not> member (remove x dl) x"
  by descending (simp add: List.member_def)

lemma dlist_in_remove:
  "a \<noteq> b \<Longrightarrow> member (remove b dl) a = member dl a"
  by descending (simp add: List.member_def)

lemma dlist_not_memb_remove:
  "\<not> member dl x \<Longrightarrow> remove x dl = dl"
  by descending (simp add: List.member_def)

lemma dlist_no_memb_remove_insert:
  "\<not> member dl x \<Longrightarrow> remove x (insert x dl) = dl"
  by descending (simp add: List.member_def)

lemma dlist_remove_empty:
  "remove x empty = empty"
  by descending simp

lemma dlist_remove_insert_commute:
  "a \<noteq> b \<Longrightarrow> remove a (insert b dl) = insert b (remove a dl)"
  by descending simp

lemma dlist_remove_commute:
"remove a (remove b dl) = remove b (remove a dl)"
  by (lifting removeAll_commute)

lemma dlist_foldr_empty:
  "foldr f empty e = e"
  by descending simp

lemma dlist_no_memb_foldr:
  assumes "\<not> member dl x"
  shows "foldr f (insert x dl) e = f x (foldr f dl e)"
  using assms by descending (simp add: List.member_def)

lemma dlist_foldr_insert_not_memb:
  assumes "\<not>member t h"
  shows "foldr f (insert h t) e = f h (foldr f t e)"
  using assms by descending (simp add: List.member_def)

lemma list_of_dlist_empty[simp]:
  "list_of_dlist empty = []"
  by descending simp

lemma list_of_dlist_insert[simp]:
  "list_of_dlist (insert x xs) =
    (if member xs x then (remdups (list_of_dlist xs))
    else x # (remdups (list_of_dlist xs)))"
  by descending (simp add: List.member_def remdups_remdups)

lemma list_of_dlist_remove[simp]:
  "list_of_dlist (remove x dxs) = remove1 x (list_of_dlist dxs)"
  by descending (simp add: distinct_remove1_removeAll)

lemma list_of_dlist_map[simp]:
  "list_of_dlist (map f dxs) = remdups (List.map f (list_of_dlist dxs))"
  by descending (simp add: remdups_map_remdups)

lemma list_of_dlist_filter [simp]:
  "list_of_dlist (filter P dxs) = List.filter P (list_of_dlist dxs)"
  by descending (simp add: remdups_filter)

lemma dlist_map_empty:
  "map f empty = empty"
  by descending simp

lemma dlist_map_insert:
  "map f (insert x xs) = insert (f x) (map f xs)"
  by descending simp

lemma dlist_eq_iff:
  "dxs = dys \<longleftrightarrow> list_of_dlist dxs = list_of_dlist dys"
  by descending simp

lemma dlist_eqI:
  "list_of_dlist dxs = list_of_dlist dys \<Longrightarrow> dxs = dys"
  by (simp add: dlist_eq_iff)

abbreviation
  "dlist xs \<equiv> abs_dlist xs"

lemma distinct_list_of_dlist [simp, intro]:
  "distinct (list_of_dlist dxs)"
  by descending simp

lemma list_of_dlist_dlist [simp]:
  "list_of_dlist (dlist xs) = remdups xs"
  unfolding list_of_dlist_def map_fun_apply id_def
  by (metis Quotient3_rep_abs[OF Quotient3_dlist] dlist_eq_def)

lemma remdups_list_of_dlist [simp]:
  "remdups (list_of_dlist dxs) = list_of_dlist dxs"
  by simp

lemma dlist_list_of_dlist [simp, code abstype]:
  "dlist (list_of_dlist dxs) = dxs"
  by (simp add: list_of_dlist_def)
  (metis Quotient3_def Quotient3_dlist dlist_eqI list_of_dlist_dlist remdups_list_of_dlist)

lemma dlist_filter_simps:
  "filter P empty = empty"
  "filter P (insert x xs) = (if P x then insert x (filter P xs) else filter P xs)"
  by (lifting filter.simps)

lemma dlist_induct:
  assumes "P empty"
      and "\<And>a dl. P dl \<Longrightarrow> P (insert a dl)"
    shows "P dl"
  using assms by descending (drule list.induct, simp)

lemma dlist_induct_stronger:
  assumes a1: "P empty"
  and     a2: "\<And>x dl. \<lbrakk>\<not>member dl x; P dl\<rbrakk> \<Longrightarrow> P (insert x dl)"
  shows "P dl"
proof(induct dl rule: dlist_induct)
  show "P empty" using a1 by simp
next
  fix x dl
  assume "P dl"
  then show "P (insert x dl)" using a2
    by (cases "member dl x") (simp_all add: dlist_member_insert)
qed

lemma dlist_card_induct:
  assumes "\<And>xs. (\<And>ys. card ys < card xs \<Longrightarrow> P ys) \<Longrightarrow> P xs"
    shows "P xs"
  using assms
  by descending (rule measure_induct [of card_remdups], blast)

lemma dlist_cases:
  "dl = empty \<or> (\<exists>h t. dl = insert h t \<and> \<not> member t h)"
  by descending
    (metis List.member_def dlist_eq_def hd_Cons_tl list_of_dlist_dlist remdups_hd_notin_tl remdups_list_of_dlist)

lemma dlist_exhaust:
  obtains "y = empty" | a dl where "y = insert a dl"
  by (lifting list.exhaust)

lemma dlist_exhaust_stronger:
  obtains "y = empty" | a dl where "y = insert a dl" "\<not> member dl a"
  by (metis dlist_cases)

end