(*
  File:     Cotangent_PFD_Formula.thy
  Author:   Manuel Eberl, University of Innsbruck

  A proof of the "partial fraction decomposition"-style sum formula for the contangent function.
*)
section \<open>The Partial-Fraction Formula for the Cotangent Function\<close>
theory Cotangent_PFD_Formula
  imports "HOL-Complex_Analysis.Complex_Analysis" "HOL-Real_Asymp.Real_Asymp"
begin

subsection \<open>Auxiliary lemmas\<close>

(* TODO Move *)
text \<open>
  The following variant of the comparison test for showing summability allows us to use
  a `Big-O' estimate, which works well together with Isabelle's automation for real asymptotics.
\<close>
lemma summable_comparison_test_bigo:
  fixes f :: "nat \<Rightarrow> real"
  assumes "summable (\<lambda>n. norm (g n))" "f \<in> O(g)"
  shows   "summable f"
proof -
  from \<open>f \<in> O(g)\<close> obtain C where C: "eventually (\<lambda>x. norm (f x) \<le> C * norm (g x)) at_top"
    by (auto elim: landau_o.bigE)
  thus ?thesis
    by (rule summable_comparison_test_ev) (insert assms, auto intro: summable_mult)
qed

lemma uniformly_on_image:
  "uniformly_on (f ` A) g = filtercomap (\<lambda>h. h \<circ> f) (uniformly_on A (g \<circ> f))"
  unfolding uniformly_on_def by (simp add: filtercomap_INF)

lemma uniform_limit_image:
  "uniform_limit (f ` A) g h F \<longleftrightarrow> uniform_limit A (\<lambda>x y. g x (f y)) (\<lambda>x. h (f x)) F"
  by (simp add: uniformly_on_image filterlim_filtercomap_iff o_def)

lemma Ints_add_iff1 [simp]: "x \<in> \<int> \<Longrightarrow> x + y \<in> \<int> \<longleftrightarrow> y \<in> \<int>"
  by (metis Ints_add Ints_diff add.commute add_diff_cancel_right')

lemma Ints_add_iff2 [simp]: "y \<in> \<int> \<Longrightarrow> x + y \<in> \<int> \<longleftrightarrow> x \<in> \<int>"
  by (metis Ints_add Ints_diff add_diff_cancel_right')

text \<open>
  If a set is discrete (i.e. the difference between any two points is bounded from below),
  it has no limit points:
\<close>
lemma discrete_imp_not_islimpt:
  assumes e: "0 < e"
    and d: "\<forall>x \<in> S. \<forall>y \<in> S. dist y x < e \<longrightarrow> y = x"
  shows "\<not>x islimpt S"
proof
  assume "x islimpt S"
  hence "x islimpt S - {x}"
    by (meson islimpt_punctured)
  moreover from assms have "closed (S - {x})"
    by (intro discrete_imp_closed) auto
  ultimately show False
    unfolding closed_limpt by blast
qed

text \<open>
  In particular, the integers have no limit point:
\<close>
lemma Ints_not_limpt: "\<not>((x :: 'a :: real_normed_algebra_1) islimpt \<int>)"
  by (rule discrete_imp_not_islimpt[of 1]) (auto elim!: Ints_cases simp: dist_of_int)

text \<open>
  The following lemma allows evaluating telescoping sums of the form
  \[\sum\limits_{n=0}^\infty \left(f(n) - f(n + k)\right)\]
  where $f(n) \longrightarrow 0$, i.e.\ where all terms except for the first \<open>k\<close> are
  cancelled by later summands.
\<close>
lemma sums_long_telescope:
  fixes f :: "nat \<Rightarrow> 'a :: {topological_group_add, topological_comm_monoid_add, ab_group_add}"
  assumes lim: "f \<longlonglongrightarrow> 0"
  shows "(\<lambda>n. f n - f (n + c)) sums (\<Sum>k<c. f k)" (is "_ sums ?S")
proof -
  thm tendsto_diff
  have "(\<lambda>N. ?S - (\<Sum>n<c. f (N + n))) \<longlonglongrightarrow> ?S - 0"
    by (intro tendsto_intros tendsto_null_sum filterlim_compose[OF assms]; real_asymp)
  hence "(\<lambda>N. ?S - (\<Sum>n<c. f (N + n))) \<longlonglongrightarrow> ?S"
    by simp
  moreover have "eventually (\<lambda>N. ?S - (\<Sum>n<c. f (N + n)) = (\<Sum>n<N. f n - f (n + c))) sequentially"
    using eventually_ge_at_top[of c]
  proof eventually_elim
    case (elim N)
    have "(\<Sum>n<N. f n - f (n + c)) = (\<Sum>n<N. f n) - (\<Sum>n<N. f (n + c))"
      by (simp only: sum_subtractf)
    also have "(\<Sum>n<N. f n) = (\<Sum>n\<in>{..<c} \<union> {c..<N}. f n)"
      using elim by (intro sum.cong) auto
    also have "\<dots> = (\<Sum>n<c. f n) + (\<Sum>n\<in>{c..<N}. f n)"
      by (subst sum.union_disjoint) auto
    also have "(\<Sum>n<N. f (n + c)) = (\<Sum>n\<in>{c..<N+c}. f n)"
      using elim by (intro sum.reindex_bij_witness[of _ "\<lambda>n. n - c" "\<lambda>n. n + c"]) auto
    also have "\<dots> = (\<Sum>n\<in>{c..<N}\<union>{N..<N+c}. f n)"
      using elim by (intro sum.cong) auto
    also have "\<dots> = (\<Sum>n\<in>{c..<N}. f n) + (\<Sum>n\<in>{N..<N+c}. f n)"
      by (subst sum.union_disjoint) auto
    also have "(\<Sum>n\<in>{N..<N+c}. f n) = (\<Sum>n<c. f (N + n))"
      by (intro sum.reindex_bij_witness[of _ "\<lambda>n. n + N" "\<lambda>n. n - N"]) auto
    finally show ?case
      by simp
  qed
  ultimately show ?thesis
    unfolding sums_def by (rule Lim_transform_eventually)
qed

subsection \<open>Definition of auxiliary function\<close>

text \<open>
  The following function is the infinite sum appearing on the right-hand side of the
  cotangent formula. It can be written either as
  \[\sum_{n=1}^\infty\left(\frac{1}{x + n} + \frac{1}{x - n}\right)\]
  or as
  \[2x \sum_{n=1}^\infty \frac{1}{x^2 - n^2}\ .\]
\<close>
definition cot_pfd :: "'a :: {real_normed_field, banach} \<Rightarrow> 'a" where
  "cot_pfd x = (\<Sum>n. 2 * x / (x ^ 2 - of_nat (Suc n) ^ 2))"

text \<open>
  The sum in the definition of \<^const>\<open>cot_pfd\<close> converges uniformly on compact sets.
  This implies, in particular, that \<^const>\<open>cot_pfd\<close> is holomorphic (and thus also continuous).
\<close>
lemma uniform_limit_cot_pfd_complex:
  assumes "R \<ge> 0"
  shows   "uniform_limit (cball 0 R :: complex set)
             (\<lambda>N x. \<Sum>n<N. 2 * x / (x ^ 2 - of_nat (Suc n) ^ 2)) cot_pfd sequentially"
  unfolding cot_pfd_def
proof (rule Weierstrass_m_test_ev)
  have "eventually (\<lambda>N. of_nat (N + 1) > R) at_top"
    by real_asymp
  thus "\<forall>\<^sub>F N in sequentially. \<forall>(x::complex)\<in>cball 0 R. norm (2 * x / (x ^ 2 - of_nat (Suc N) ^ 2)) \<le>
          2 * R / (real (N + 1) ^ 2 - R ^ 2)"
  proof eventually_elim
    case (elim N)
    show ?case
    proof safe
      fix x :: complex assume x: "x \<in> cball 0 R"
      have "(1 + real N)\<^sup>2 - R\<^sup>2 \<le> norm ((1 + of_nat N :: complex) ^ 2) - norm (x ^ 2)"
        using x by (auto intro: power_mono simp: norm_power simp flip: of_nat_Suc)
      also have "\<dots> \<le> norm (x\<^sup>2 - (1 + of_nat N :: complex)\<^sup>2)"
        by (metis norm_minus_commute norm_triangle_ineq2)
      finally show "norm (2 * x / (x\<^sup>2 - (of_nat (Suc N))\<^sup>2)) \<le> 2 * R / (real (N + 1) ^ 2 - R ^ 2)"
        unfolding norm_mult norm_divide using \<open>R \<ge> 0\<close> x elim
        by (intro mult_mono frac_le) (auto intro: power_strict_mono)
    qed
  qed
next
  show "summable (\<lambda>N. 2 * R / (real (N + 1) ^ 2 - R ^ 2))"
  proof (rule summable_comparison_test_bigo)
    show "(\<lambda>N. 2 * R / (real (N + 1) ^ 2 - R ^ 2)) \<in> O(\<lambda>N. 1 / real N ^ 2)"
      by real_asymp
  next
    show "summable (\<lambda>n. norm (1 / real n ^ 2))"
      using inverse_power_summable[of 2] by (simp add: field_simps)
  qed
qed

lemma sums_cot_pfd_complex:
  fixes x :: complex
  shows "(\<lambda>n. 2 * x / (x ^ 2 - of_nat (Suc n) ^ 2)) sums cot_pfd x"
  using tendsto_uniform_limitI[OF uniform_limit_cot_pfd_complex[of "norm x"], of x]
  by (simp add: sums_def)

lemma sums_cot_pfd_complex':
  fixes x :: complex
  assumes "x \<notin> \<int>"
  shows   "(\<lambda>n. 1 / (x + of_nat (Suc n)) + 1 / (x - of_nat (Suc n))) sums cot_pfd x"
proof -
  have "(\<lambda>n. 2 * x / (x ^ 2 - of_nat (Suc n) ^ 2)) sums cot_pfd x"
    by (rule sums_cot_pfd_complex)
  also have "(\<lambda>n. 2 * x / (x ^ 2 - of_nat (Suc n) ^ 2)) =
             (\<lambda>n. 1 / (x + of_nat (Suc n)) + 1 / (x - of_nat (Suc n)))" (is "?lhs = ?rhs")
  proof
    fix n :: nat
    have neq1: "x + of_nat (Suc n) \<noteq> 0"
      using assms by (metis Ints_0 Ints_add_iff2 Ints_of_nat)
    have neq2: "x - of_nat (Suc n) \<noteq> 0"
      using assms by force
    have neq3: "x ^ 2 - of_nat (Suc n) ^ 2 \<noteq> 0"
     using assms by (metis Ints_of_nat eq_iff_diff_eq_0 minus_in_Ints_iff power2_eq_iff)
    show "?lhs n = ?rhs n" using neq1 neq2 neq3
      by (simp add: divide_simps del: of_nat_Suc) (auto simp: power2_eq_square algebra_simps)
  qed
  finally show ?thesis .
qed

lemma summable_cot_pfd_complex:
  fixes x :: complex
  shows "summable (\<lambda>n. 2 * x / (x ^ 2 - of_nat (Suc n) ^ 2))"
  using sums_cot_pfd_complex[of x] by (simp add: sums_iff)

lemma summable_cot_pfd_real:
  fixes x :: real
  shows "summable (\<lambda>n. 2 * x / (x ^ 2 - of_nat (Suc n) ^ 2))"
proof -
  have "summable (\<lambda>n. complex_of_real (2 * x / (x ^ 2 - of_nat (Suc n) ^ 2)))"
    using summable_cot_pfd_complex[of "of_real x"] by simp
  also have "?this \<longleftrightarrow> ?thesis"
    by (rule summable_of_real_iff)
  finally show ?thesis .
qed

lemma sums_cot_pfd_real:
  fixes x :: real
  shows "(\<lambda>n. 2 * x / (x ^ 2 - of_nat (Suc n) ^ 2)) sums cot_pfd x"
  using summable_cot_pfd_real[of x] by (simp add: cot_pfd_def sums_iff)

lemma cot_pfd_complex_of_real [simp]: "cot_pfd (complex_of_real x) = of_real (cot_pfd x)"
  using sums_of_real[OF sums_cot_pfd_real[of x], where ?'a = complex]
        sums_cot_pfd_complex[of "of_real x"] sums_unique2 by auto

lemma uniform_limit_cot_pfd_real:
  assumes "R \<ge> 0"
  shows   "uniform_limit (cball 0 R :: real set)
             (\<lambda>N x. \<Sum>n<N. 2 * x / (x ^ 2 - of_nat (Suc n) ^ 2)) cot_pfd sequentially"
proof -
  have "uniform_limit (cball 0 R)
          (\<lambda>N x. Re (\<Sum>n<N. 2 * x / (x ^ 2 - of_nat (Suc n) ^ 2))) (\<lambda>x. Re (cot_pfd x)) sequentially"
    by (intro uniform_limit_intros uniform_limit_cot_pfd_complex assms)
  hence "uniform_limit (of_real ` cball 0 R)
          (\<lambda>N x. Re (\<Sum>n<N. 2 * x / (x ^ 2 - of_nat (Suc n) ^ 2))) (\<lambda>x. Re (cot_pfd x)) sequentially"
    by (rule uniform_limit_on_subset) auto
  thus ?thesis
    by (simp add: uniform_limit_image)
qed

subsection \<open>Holomorphicity and continuity\<close>

lemma holomorphic_on_cot_pfd [holomorphic_intros]:
  assumes "A \<subseteq> -(\<int>-{0})"
  shows   "cot_pfd holomorphic_on A"
proof -
  have *: "open (-(\<int>-{0}) :: complex set)"
    by (intro open_Compl closed_subset_Ints) auto
  define f :: "nat \<Rightarrow> complex \<Rightarrow> complex"
    where "f = (\<lambda>N x. \<Sum>n<N. 2 * x / (x ^ 2 - of_nat (Suc n) ^ 2))"
  have "cot_pfd holomorphic_on -(\<int>-{0})"
  proof (rule holomorphic_uniform_sequence[OF *])
    fix n :: nat
    have **: "x\<^sup>2 - (of_nat (Suc n))\<^sup>2 \<noteq> 0" if "x \<in> -(\<int>-{0})" for x :: complex and n :: nat
    proof
      assume "x\<^sup>2 - (of_nat (Suc n))\<^sup>2 = 0"
      hence "(of_nat (Suc n))\<^sup>2 = x\<^sup>2"
        by algebra
      hence "x = of_nat (Suc n) \<or> x = -of_nat (Suc n)"
        by (subst (asm) eq_commute, subst (asm) power2_eq_iff) auto
      moreover have "(of_nat (Suc n) :: complex) \<in> \<int>" "(-of_nat (Suc n) :: complex) \<in> \<int>"
        by (intro Ints_minus Ints_of_nat)+
      ultimately show False using that
        by (auto simp del: of_nat_Suc)
    qed
    show "f n holomorphic_on -(\<int> - {0})"
      unfolding f_def by (intro holomorphic_intros **)
  next
    fix z :: complex assume z: "z \<in> -(\<int> - {0})"
    from * z obtain r where r: "r > 0" "cball z r \<subseteq> -(\<int>-{0})"
      using open_contains_cball by blast
    have "uniform_limit (cball z r) f cot_pfd sequentially"
      using uniform_limit_cot_pfd_complex[of "norm z + r"] unfolding f_def
    proof (rule uniform_limit_on_subset)
      show "cball z r \<subseteq> cball 0 (norm z + r)"
        unfolding cball_subset_cball_iff by (auto simp: dist_norm)
    qed (use \<open>r > 0\<close> in auto)
    with r show "\<exists>d>0. cball z d \<subseteq> - (\<int> - {0}) \<and> uniform_limit (cball z d) f cot_pfd sequentially"
      by blast
  qed
  thus ?thesis
    by (rule holomorphic_on_subset) fact
qed

lemma continuous_on_cot_pfd_complex [continuous_intros]:
  assumes "A \<subseteq> -(\<int>-{0})"
  shows   "continuous_on A (cot_pfd :: complex \<Rightarrow> complex)"
  by (rule holomorphic_on_imp_continuous_on holomorphic_intros assms)+

lemma continuous_on_cot_pfd_real [continuous_intros]:
  assumes "A \<subseteq> -(\<int>-{0})"
  shows   "continuous_on A (cot_pfd :: real \<Rightarrow> real)"
proof -
  have "continuous_on A (Re \<circ> cot_pfd \<circ> of_real)"
    by (intro continuous_intros) (use assms in auto)
  also have "Re \<circ> cot_pfd \<circ> of_real = cot_pfd"
    by auto
  finally show ?thesis .
qed

subsection \<open>Functional equations\<close>

text \<open>
  In this section, we will show three few functional equations for the function \<^const>\<open>cot_pfd\<close>.
  The first one is trivial; the other two are a bit tedious and not very insightful, so I
  will not comment on them.
\<close>

text \<open>\<^const>\<open>cot_pfd\<close> is an odd function:\<close>
lemma cot_pfd_complex_minus [simp]: "cot_pfd (-x :: complex) = -cot_pfd x"
proof -
  have "(\<lambda>n. 2 * (-x) / ((-x) ^ 2 - of_nat (Suc n) ^ 2)) =
        (\<lambda>n. - (2 * x / (x ^ 2 - of_nat (Suc n) ^ 2)))"
    by simp
  also have "\<dots> sums -cot_pfd x"
    by (intro sums_minus sums_cot_pfd_complex)
  finally show ?thesis
    using sums_cot_pfd_complex[of "-x"] sums_unique2 by blast
qed

lemma cot_pfd_real_minus [simp]: "cot_pfd (-x :: real) = -cot_pfd x"
  using cot_pfd_complex_minus[of "of_real x"]
  unfolding of_real_minus [symmetric] cot_pfd_complex_of_real of_real_eq_iff .

text \<open>\<^const>\<open>cot_pfd\<close> is periodic with period 1:\<close>
lemma cot_pfd_plus_1_complex:
  assumes "x \<notin> \<int>"
  shows   "cot_pfd (x + 1 :: complex) = cot_pfd x - 1 / (x + 1) + 1 / x"
proof -
  have *: "x ^ 2 \<noteq> of_nat n ^ 2" if "x \<notin> \<int>" for x :: complex and n
    using that by (metis Ints_of_nat minus_in_Ints_iff power2_eq_iff)
  have **: "x + of_nat n \<noteq> 0" if "x \<notin> \<int>" for x :: complex and n
    using that by (metis Ints_0 Ints_add_iff2 Ints_of_nat)
  have [simp]: "x \<noteq> 0"
    using assms by auto
  have [simp]: "x + 1 \<noteq> 0"
    using assms by (metis "**" of_nat_1)
  have [simp]: "x + 2 \<noteq> 0"
    using **[of x 2] assms by simp

  have lim: "(\<lambda>n. 1 / (x + of_nat (Suc n))) \<longlonglongrightarrow> 0"
    by (intro tendsto_divide_0[OF tendsto_const] tendsto_add_filterlim_at_infinity[OF tendsto_const]
              filterlim_compose[OF tendsto_of_nat] filterlim_Suc)
  have sum1: "(\<lambda>n. 1 / (x + of_nat (Suc n)) - 1 / (x + of_nat (Suc n + 2))) sums
          (\<Sum>n<2. 1 / (x + of_nat (Suc n)))"
    using sums_long_telescope[OF lim, of 2] by (simp add: algebra_simps)

  have "(\<lambda>n. 2 * x / (x\<^sup>2 - (of_nat (Suc n))\<^sup>2) - 2 * (x + 1) / ((x + 1)^2 - (of_nat (Suc (Suc n)))\<^sup>2))
          sums (cot_pfd x - (cot_pfd (x + 1) - 2 * (x + 1) / ((x + 1)^2 - (of_nat (Suc 0) ^ 2))))"
    using sums_cot_pfd_complex[of "x + 1"]
    by (intro sums_diff sums_cot_pfd_complex, subst sums_Suc_iff) auto
  also have "2 * (x + 1) / ((x + 1)^2 - (of_nat (Suc 0) ^ 2)) = 2 * (x + 1) / (x * (x + 2))"
    by (simp add: algebra_simps power2_eq_square)
  also have "(\<lambda>n. 2 * x / (x\<^sup>2 - (of_nat (Suc n))\<^sup>2) -
                  2 * (x + 1) / ((x + 1)\<^sup>2 - (of_nat (Suc (Suc n)))\<^sup>2)) =
             (\<lambda>n. 1 / (x + of_nat (Suc n)) - 1 / (x + of_nat (Suc n + 2)))"
    using *[of x] *[of "x + 1"] **[of x] **[of "x + 1"] assms
    apply (intro ext)
    apply (simp add: divide_simps del: of_nat_add of_nat_Suc)
    apply (simp add: algebra_simps power2_eq_square)
    done
  finally have sum2: "(\<lambda>n. 1 / (x + of_nat (Suc n)) - 1 / (x + of_nat (Suc n + 2))) sums
                         (cot_pfd x - cot_pfd (x + 1) + 2 * (x + 1) / (x * (x + 2)))"
    by (simp add: algebra_simps)

  have "cot_pfd x - cot_pfd (x + 1) + 2 * (x + 1) / (x * (x + 2)) =
        (\<Sum>n<2. 1 / (x + of_nat (Suc n)))"
    using sum1 sum2 sums_unique2 by blast
  hence "cot_pfd x - cot_pfd (x + 1) = -2 * (x + 1) / (x * (x + 2)) + 1 / (x + 1) + 1 / (x + 2)"
    by (simp add: eval_nat_numeral divide_simps) algebra?
  also have "\<dots> = 1 / (x + 1) - 1 / x"
    by (simp add: divide_simps) algebra?
  finally show ?thesis
    by algebra
qed

lemma cot_pfd_plus_1_real:
  assumes "x \<notin> \<int>"
  shows   "cot_pfd (x + 1 :: real) = cot_pfd x - 1 / (x + 1) + 1 / x"
proof -
  have "cot_pfd (complex_of_real (x + 1)) = cot_pfd (of_real x) - 1 / (of_real x + 1) + 1 / of_real x"
    using cot_pfd_plus_1_complex[of x] assms by simp
  also have "\<dots> = complex_of_real (cot_pfd x - 1 / (x + 1) + 1 / x)"
    by simp
  finally show ?thesis
    unfolding cot_pfd_complex_of_real of_real_eq_iff .
qed

text \<open>
  \<^const>\<open>cot_pfd\<close> satisfies the following functional equation:
  \[2 f(x) = f\left(\frac{x}{2}\right) + f\left(\frac{x+1}{2}\right) + \frac{2}{x+1}\]
\<close>
lemma cot_pfd_funeq_complex:
  fixes x :: complex
  assumes "x \<notin> \<int>"
  shows   "2 * cot_pfd x = cot_pfd (x / 2) + cot_pfd ((x + 1) / 2) + 2 / (x + 1)"
proof -
  define f :: "complex \<Rightarrow> nat \<Rightarrow> complex" where "f = (\<lambda>x n. 1 / (x + of_nat (Suc n)))"
  define g :: "complex \<Rightarrow> nat \<Rightarrow> complex" where "g = (\<lambda>x n. 1 / (x - of_nat (Suc n)))"
  define h :: "complex \<Rightarrow> nat \<Rightarrow> complex" where "h = (\<lambda>x n. 2 * (f x (n + 1) + g x n))"

  have sums: "(\<lambda>n. f x n + g x n) sums cot_pfd x" if "x \<notin> \<int>" for x
    unfolding f_def g_def by (intro sums_cot_pfd_complex' that)

  have "x / 2 \<notin> \<int>"
  proof
    assume "x / 2 \<in> \<int>"
    hence "2 * (x / 2) \<in> \<int>"
      by (intro Ints_mult) auto
    thus False using assms by simp
  qed
  moreover have "(x + 1) / 2 \<notin> \<int>"
  proof
    assume "(x + 1) / 2 \<in> \<int>"
    hence "2 * ((x + 1) / 2) - 1 \<in> \<int>"
      by (intro Ints_mult Ints_diff) auto
    thus False using assms by (simp add: field_simps)
  qed
  ultimately have "(\<lambda>n. (f (x / 2) n + g (x / 2) n) + (f ((x+1) / 2) n + g ((x+1) / 2) n)) sums
                     (cot_pfd (x / 2) + cot_pfd ((x + 1) / 2))"
    by (intro sums_add sums)

  also have "(\<lambda>n. (f (x / 2) n + g (x / 2) n) + (f ((x+1) / 2) n + g ((x+1) / 2) n)) =
             (\<lambda>n. h x (2 * n) + h x (2 * n + 1))"
  proof
    fix n :: nat
    have "(f (x / 2) n + g (x / 2) n) + (f ((x+1) / 2) n + g ((x+1) / 2) n) =
          (f (x / 2) n + f ((x+1) / 2) n) + (g (x / 2) n + g ((x+1) / 2) n)"
      by algebra
    also have "f (x / 2) n + f ((x+1) / 2) n = 2 * (f x (2 * n + 1) + f x (2 * n + 2))"
      by (simp add: f_def field_simps)
    also have "g (x / 2) n + g ((x+1) / 2) n = 2 * (g x (2 * n) + g x (2 * n + 1))"
      by (simp add: g_def field_simps)
    also have "2 * (f x (2 * n + 1) + f x (2 * n + 2)) + \<dots> =
               h x (2 * n) + h x (2 * n + 1)"
      unfolding h_def by (simp add: algebra_simps)
    finally show "(f (x / 2) n + g (x / 2) n) + (f ((x+1) / 2) n + g ((x+1) / 2) n) =
                  h x (2 * n) + h x (2 * n + 1)" .
  qed
  finally have sum1:
    "(\<lambda>n. h x (2 * n) + h x (2 * n + 1)) sums (cot_pfd (x / 2) + cot_pfd ((x + 1) / 2))" .

  have "f x \<longlonglongrightarrow> 0" unfolding f_def
    by (intro tendsto_divide_0[OF tendsto_const]
              tendsto_add_filterlim_at_infinity[OF tendsto_const]
              filterlim_compose[OF tendsto_of_nat] filterlim_Suc)
  hence "(\<lambda>n. 2 * (f x n + g x n) + 2 * (f x (Suc n) - f x n)) sums (2 * cot_pfd x + 2 * (0 - f x 0))"
    by (intro sums_add sums sums_mult telescope_sums assms)
  also have "(\<lambda>n. 2 * (f x n + g x n) + 2 * (f x (Suc n) - f x n)) = h x"
    by (simp add: h_def algebra_simps fun_eq_iff)
  finally have *: "h x sums (2 * cot_pfd x - 2 * f x 0)"
    by simp

  have "(\<lambda>n. sum (h x) {n * 2..<n * 2 + 2}) sums (2 * cot_pfd x - 2 * f x 0)"
    using sums_group[OF *, of 2] by simp
  also have "(\<lambda>n. sum (h x) {n*2..<n*2+2}) = (\<lambda>n. h x (2 * n) + h x (2 * n + 1))"
    by (simp add: mult_ac)
  finally have sum2: "(\<lambda>n. h x (2 * n) + h x (2 * n + 1)) sums (2 * cot_pfd x - 2 * f x 0)" .

  have "cot_pfd (x / 2) + cot_pfd ((x + 1) / 2) = 2 * cot_pfd x - 2 * f x 0"
    using sum1 sum2 sums_unique2 by blast
  also have "2 * f x 0 = 2 / (x + 1)"
    by (simp add: f_def)
  finally show ?thesis by algebra
qed

lemma cot_pfd_funeq_real:
  fixes x :: real
  assumes "x \<notin> \<int>"
  shows   "2 * cot_pfd x = cot_pfd (x / 2) + cot_pfd ((x + 1) / 2) + 2 / (x + 1)"
proof -
  have "complex_of_real (2 * cot_pfd x) = 2 * cot_pfd (complex_of_real x)"
    by simp
  also have "\<dots> = complex_of_real (cot_pfd (x / 2) + cot_pfd ((x + 1) / 2) + 2 / (x + 1))"
    using assms by (subst cot_pfd_funeq_complex) (auto simp flip: cot_pfd_complex_of_real)
  finally show ?thesis
    by (simp only: of_real_eq_iff)
qed

subsection \<open>The limit at 0\<close>

lemma cot_pfd_real_tendsto_0: "cot_pfd \<midarrow>0\<rightarrow> (0 :: real)"
proof -
  have "filterlim cot_pfd (nhds 0) (at (0 :: real) within ball 0 1)"
  proof (rule swap_uniform_limit)
    show "uniform_limit (ball 0 1)
            (\<lambda>N x. \<Sum>n<N. 2 * x / (x\<^sup>2 - (real (Suc n))\<^sup>2)) cot_pfd sequentially"
      using uniform_limit_cot_pfd_real[OF zero_le_one] by (rule uniform_limit_on_subset) auto
    have "((\<lambda>x. 2 * x / (x\<^sup>2 - (real (Suc n))\<^sup>2)) \<longlongrightarrow> 0) (at 0 within ball 0 1)" for n
    proof (rule filterlim_mono)
      show "((\<lambda>x. 2 * x / (x\<^sup>2 - (real (Suc n))\<^sup>2)) \<longlongrightarrow> 0) (at 0)"
        by real_asymp
    qed (auto simp: at_within_le_at)
    thus "\<forall>\<^sub>F N in sequentially.
             ((\<lambda>x. \<Sum>n<N. 2 * x / (x\<^sup>2 - (real (Suc n))\<^sup>2)) \<longlongrightarrow> 0) (at 0 within ball 0 1)"
      by (intro always_eventually allI tendsto_null_sum)
  qed auto
  thus ?thesis
    by (simp add: at_within_open_NO_MATCH)
qed

subsection \<open>Final result\<close>

text \<open>
  To show the final result, we first prove the real case using Herglotz's trick, following
  the presentation in `Proofs from {THE BOOK}'.~\<^cite>\<open>\<open>Chapter~23\<close> in "thebook"\<close>.
\<close>
lemma cot_pfd_formula_real:
  assumes "x \<notin> \<int>"
  shows   "pi * cot (pi * x) = 1 / x + cot_pfd x"
proof -
  have ev_not_int: "eventually (\<lambda>x. r x \<notin> \<int>) (at x)"
    if "filterlim r (at (r x)) (at x)" for r :: "real \<Rightarrow> real" and x :: real
  proof (rule eventually_compose_filterlim[OF _ that])
    show "eventually (\<lambda>x. x \<notin> \<int>) (at (r x))"
      using Ints_not_limpt[of "r x"] islimpt_iff_eventually by blast
  qed

  text \<open>
    We define the function $h(z)$ as the difference of the left-hand side and right-hand side.
    The left-hand side and right-hand side have singularities at the integers, but we will
    later see that these can be removed as \<open>h\<close> tends to \<open>0\<close> there.
  \<close>
  define f :: "real \<Rightarrow> real" where "f = (\<lambda>x. pi * cot (pi * x))"
  define g :: "real \<Rightarrow> real" where "g = (\<lambda>x. 1 / x + cot_pfd x)"
  define h where "h = (\<lambda>x. if x \<in> \<int> then 0 else f x - g x)"

  have [simp]: "h x = 0" if "x \<in> \<int>" for x
    using that by (simp add: h_def)

  text \<open>
    It is easy to see that the left-hand side and the right-hand side, and as a consequence
    also our function \<open>h\<close>, are odd and periodic with period 1.
  \<close>
  have odd_h: "h (-x) = -h x" for x
    by (simp add: h_def minus_in_Ints_iff f_def g_def)
  have per_f: "f (x + 1) = f x" for x
    by (simp add: f_def algebra_simps cot_def)
  have per_g: "g (x + 1) = g x" if "x \<notin> \<int>" for x
    using that by (simp add: g_def cot_pfd_plus_1_real)
  interpret h: periodic_fun_simple' h
    by standard (auto simp: h_def per_f per_g)

  text \<open>
    \<open>h\<close> tends to 0 at 0 (and thus at all the integers).
  \<close>
  have h_lim: "h \<midarrow>0\<rightarrow> 0"
  proof (rule Lim_transform_eventually)
    have "eventually (\<lambda>x. x \<notin> \<int>) (at (0 :: real))"
      by (rule ev_not_int) real_asymp
    thus "eventually (\<lambda>x::real. pi * cot (pi * x) - 1 / x - cot_pfd x = h x) (at 0)"
      by eventually_elim (simp add: h_def f_def g_def)
  next
    have "(\<lambda>x::real. pi * cot (pi * x) - 1 / x) \<midarrow>0\<rightarrow> 0"
      unfolding cot_def by real_asymp
    hence "(\<lambda>x::real. pi * cot (pi * x) - 1 / x - cot_pfd x) \<midarrow>0\<rightarrow> 0 - 0"
      by (intro tendsto_intros cot_pfd_real_tendsto_0)
    thus "(\<lambda>x. pi * cot (pi * x) - 1 / x - cot_pfd x) \<midarrow>0\<rightarrow> 0"
      by simp
  qed

  text \<open>
    This means that our \<open>h\<close> is in fact continuous everywhere:
  \<close>
  have cont_h: "continuous_on A h" for A
  proof -
    have "isCont h x" for x
    proof (cases "x \<in> \<int>")
      case True
      then obtain n where [simp]: "x = of_int n"
        by (auto elim: Ints_cases)
      show ?thesis unfolding isCont_def
        by (subst at_to_0) (use h_lim in \<open>simp add: filterlim_filtermap h.plus_of_int\<close>)
    next
      case False
      have "continuous_on (-\<int>) (\<lambda>x. f x - g x)"
        by (auto simp: f_def g_def sin_times_pi_eq_0 mult.commute[of pi] intro!: continuous_intros)
      hence "isCont (\<lambda>x. f x - g x) x"
        by (rule continuous_on_interior)
           (use False in \<open>auto simp: interior_open open_Compl[OF closed_Ints]\<close>)
      also have "eventually (\<lambda>y. y \<in> -\<int>) (nhds x)"
        using False by (intro eventually_nhds_in_open) auto
      hence "eventually (\<lambda>x. f x - g x = h x) (nhds x)"
        by eventually_elim (auto simp: h_def)
      hence "isCont (\<lambda>x. f x - g x) x \<longleftrightarrow> isCont h x"
        by (rule isCont_cong)
      finally show ?thesis .
    qed
    thus ?thesis
      by (simp add: continuous_at_imp_continuous_on)
  qed
  note [continuous_intros] = continuous_on_compose2[OF cont_h]

  text \<open>
    Through the functional equations of the sine and cosine function, we can derive
    the following functional equation for \<open>f\<close> that holds for all non-integer reals:
  \<close>
  have eq_f: "f x = (f (x / 2) + f ((x + 1) / 2)) / 2" if "x \<notin> \<int>" for x
  proof -
    have "x / 2 \<notin> \<int>"
      using that by (metis Ints_add field_sum_of_halves)
    hence nz1: "sin (x/2 * pi) \<noteq> 0"
      by (subst sin_times_pi_eq_0) auto

    have "(x + 1) / 2 \<notin> \<int>"
    proof
      assume "(x + 1) / 2 \<in> \<int>"
      hence "2 * ((x + 1) / 2) - 1 \<in> \<int>"
        by (intro Ints_mult Ints_diff) auto
      thus False using that by (simp add: field_simps)
    qed
    hence nz2: "sin ((x+1)/2 * pi) \<noteq> 0"
      by (subst sin_times_pi_eq_0) auto

    have nz3: "sin (x * pi) \<noteq> 0"
      using that by (subst sin_times_pi_eq_0) auto

    have eq: "sin (pi * x) = 2 * sin (pi * x / 2) * cos (pi * x / 2)"
             "cos (pi * x) = (cos (pi * x / 2))\<^sup>2 - (sin (pi * x / 2))\<^sup>2"
      using sin_double[of "pi * x / 2"] cos_double[of "pi * x / 2"] by simp_all
    show ?thesis using nz1 nz2 nz3
      apply (simp add: f_def cot_def field_simps )
      apply (simp add: add_divide_distrib sin_add cos_add power2_eq_square eq algebra_simps)
      done
  qed

  text \<open>
    The corresponding functional equation for \<^const>\<open>cot_pfd\<close> that we have already shown
    leads to the same functional equation for \<open>g\<close> as we just showed for \<open>f\<close>:
  \<close>
  have eq_g: "g x = (g (x / 2) + g ((x + 1) / 2)) / 2" if "x \<notin> \<int>" for x
    using cot_pfd_funeq_real[OF that] by (simp add: g_def)

  text \<open>
    This then leads to the same functional equation for \<open>h\<close>, and because \<open>h\<close> is continuous
    everywhere, we can extend the validity of the equation to the full domain.
  \<close>
  have eq_h: "h x = (h (x / 2) + h ((x + 1) / 2)) / 2" for x
  proof -
    have "eventually (\<lambda>x. x \<notin> \<int>) (at x)" "eventually (\<lambda>x. x / 2 \<notin> \<int>) (at x)"
         "eventually (\<lambda>x. (x + 1) / 2 \<notin> \<int>) (at x)"
      by (rule ev_not_int; real_asymp)+
    hence "eventually (\<lambda>x. h x - (h (x / 2) + h ((x + 1) / 2)) / 2 = 0) (at x)"
    proof eventually_elim
      case (elim x)
      thus ?case using eq_f[of x] eq_g[of x]
        by (simp add: h_def field_simps)
    qed
    hence "(\<lambda>x. h x - (h (x / 2) + h ((x + 1) / 2)) / 2) \<midarrow>x\<rightarrow> 0"
      by (simp add: tendsto_eventually)
    moreover have "continuous_on UNIV (\<lambda>x. h x - (h (x / 2) + h ((x + 1) / 2)) / 2)"
      by (auto intro!: continuous_intros)
    ultimately have "h x - (h (x / 2) + h ((x + 1) / 2)) / 2 = 0"
      by (meson LIM_unique UNIV_I continuous_on_def)
    thus ?thesis
      by simp
  qed

  text \<open>
    Since \<open>h\<close> is periodic with period 1 and continuous, it must attain a global maximum \<open>h\<close>
    somewhere in the interval $[0, 1]$. Let's call this maximum $m$ and let $x_0$ be some point
    in the interval $[0, 1]$ such that $h(x_0) = m$.
  \<close>
  define m where "m = Sup (h ` {0..1})"
  have "m \<in> h ` {0..1}"
    unfolding m_def
  proof (rule closed_contains_Sup)
    have "compact (h ` {0..1})"
      by (intro compact_continuous_image cont_h) auto
    thus "bdd_above (h ` {0..1})" "closed (h ` {0..1})"
      by (auto intro: compact_imp_closed compact_imp_bounded bounded_imp_bdd_above)
  qed auto
  then obtain x0 where x0: "x0 \<in> {0..1}" "h x0 = m"
    by blast

  have h_le_m: "h x \<le> m" for x
  proof -
    have "h x = h (frac x)"
      unfolding frac_def by (rule h.minus_of_int [symmetric])
    also have "\<dots> \<le> m" unfolding m_def
    proof (rule cSup_upper)
      have "frac x \<in> {0..1}"
        using frac_lt_1[of x] by auto
      thus "h (frac x) \<in> h ` {0..1}"
        by blast
    next
      have "compact (h ` {0..1})"
        by (intro compact_continuous_image cont_h) auto
      thus "bdd_above (h ` {0..1})"
        by (auto intro: compact_imp_bounded bounded_imp_bdd_above)
    qed
    finally show ?thesis .
  qed

  text \<open>
    Through the functional equation for \<open>h\<close>, we can show that if \<open>h\<close> attains its maximum at
    some point \<open>x\<close>, it also attains it at $\frac{1}{2} x$. By iterating this, it attains the
    maximum at all points of the form $2^{-n} x_0$.
  \<close>
  have h_eq_m_iter_aux: "h (x / 2) = m" if "h x = m" for x
    using eq_h[of x] that h_le_m[of "x / 2"] h_le_m[of "(x + 1) / 2"] by simp
  have h_eq_m_iter: "h (x0 / 2 ^ n) = m" for n
  proof (induction n)
    case (Suc n)
    have "h (x0 / 2 ^ Suc n) = h (x0 / 2 ^ n / 2)"
      by (simp add: field_simps)
    also have "\<dots> = m"
      by (rule h_eq_m_iter_aux) (use Suc.IH in auto)
    finally show ?case .
  qed (use x0 in auto)

  text \<open>
    Since the sequence $n \mapsto 2^{-n} x_0$ tends to 0 and \<open>h\<close> is continuous, we derive \<open>m = 0\<close>.
  \<close>
  have "(\<lambda>n. h (x0 / 2 ^ n)) \<longlonglongrightarrow> h 0"
    by (rule continuous_on_tendsto_compose[OF cont_h[of UNIV]]) (force | real_asymp)+
  moreover from h_eq_m_iter have "(\<lambda>n. h (x0 / 2 ^ n)) \<longlonglongrightarrow> m"
    by simp
  ultimately have "m = h 0"
    using tendsto_unique by force
  hence "m = 0"
    by simp

  text \<open>
    Since \<open>h\<close> is odd, this means that \<open>h\<close> is identically zero everywhere, and our result follows.
  \<close>
  have "h x = 0"
    using h_le_m[of x] h_le_m[of "-x"] \<open>m = 0\<close> odd_h[of x] by linarith
  thus ?thesis
    using assms by (simp add: h_def f_def g_def)
qed

text \<open>
  We now lift the result from the domain \<open>\<real>\<setminus>\<int>\<close> to \<open>\<complex>\<setminus>\<int>\<close>. We do this by noting that \<open>\<complex>\<setminus>\<int>\<close> is
  connected and the point $\frac{1}{2}$ is both in \<open>\<complex>\<setminus>\<int>\<close> and a limit point of \<open>\<real>\<setminus>\<int>\<close>.
\<close>
lemma one_half_limit_point_Reals_minus_Ints: "(1 / 2 :: complex) islimpt \<real> - \<int>"
proof (rule islimptI)
  fix T :: "complex set"
  assume "1 / 2 \<in> T" "open T"
  then obtain r where r: "r > 0" "ball (1 / 2) r \<subseteq> T"
    using open_contains_ball by blast
  define y where "y = 1 / 2 + min r (1 / 2) / 2"
  have "y \<in> {0<..<1}"
    using r by (auto simp: y_def)
  hence "complex_of_real y \<in> \<real> - \<int>"
    by (auto elim!: Ints_cases)
  moreover have "complex_of_real y \<noteq> 1 / 2"
  proof
    assume "complex_of_real y = 1 / 2"
    also have "1 / 2 = complex_of_real (1 / 2)"
      by simp
    finally have "y = 1 / 2"
      unfolding of_real_eq_iff .
    with r show False
      by (auto simp: y_def)
  qed
  moreover have "complex_of_real y \<in> ball (1 / 2) r"
    using \<open>r > 0\<close> by (auto simp: y_def dist_norm)
  with r have "complex_of_real y \<in> T"
    by blast
  ultimately show "\<exists>y\<in>\<real> - \<int>. y \<in> T \<and> y \<noteq> 1 / 2"
    by blast
qed

theorem cot_pfd_formula_complex:
  fixes z :: complex
  assumes "z \<notin> \<int>"
  shows   "pi * cot (pi * z) = 1 / z + cot_pfd z"
proof -
  let ?f = "\<lambda>z::complex. pi * cot (pi * z) - 1 / z - cot_pfd z"
  have "pi * cot (pi * z) - 1 / z - cot_pfd z = 0"
  proof (rule analytic_continuation[where f = ?f])
    show "?f holomorphic_on -\<int>"
      unfolding cot_def by (intro holomorphic_intros) (auto simp: sin_eq_0)
  next
    show "open (-\<int> :: complex set)" "connected (-\<int> :: complex set)"
      by (auto intro!: path_connected_imp_connected path_connected_complement_countable countable_int)
  next
    show "\<real> - \<int> \<subseteq> (-\<int> :: complex set)"
      by auto
  next
    show "(1 / 2 :: complex) islimpt \<real> - \<int>"
      by (rule one_half_limit_point_Reals_minus_Ints)
  next
    show "1 / (2 :: complex) \<in> -\<int>"
      using fraction_not_in_ints[of 2 1, where ?'a = complex] by auto
  next
    show "z \<in> -\<int>"
      using assms by simp
  next
    show "?f z = 0" if "z \<in> \<real> - \<int>" for z
    proof -
      have "complex_of_real pi * cot (complex_of_real pi * z) - 1 / z - cot_pfd z =
            complex_of_real (pi * cot (pi * Re z) - 1 / Re z - cot_pfd (Re z))"
        using that by (auto elim!: Reals_cases simp: cot_of_real)
      also have "\<dots> = 0"
        by (subst cot_pfd_formula_real) (use that in \<open>auto elim!: Reals_cases\<close>)
      finally show ?thesis .
    qed
  qed
  thus ?thesis
    by algebra
qed

end


(*  Title:       Logging-independent Message Anonymity in the Relational Method
    Author:      Pasquale Noce
                 Software Engineer at HID Global, Italy
                 pasquale dot noce dot lavoro at gmail dot com
                 pasquale dot noce at hidglobal dot com
*)

section "Anonymity of token pseudonymous identifiers"

theory Anonymity
  imports Definitions
begin

text \<open>
\null

This section contains a proof of anonymity property @{text id_anonymous}, which states that a token
pseudonymous identifier remains anonymous if its anonymity is not compromised by means other than
attacking the protocol and neither attack option described in section \ref{Protocol} is viable. As
shown here below, this property can be proven by applying rules @{thm [source] rtrancl_induct} and
@{text rtrancl_start} in a suitable combination \<^cite>\<open>"Noce20"\<close>.

\null
\<close>

proposition rtrancl_start [rule_format]:
 "(x, y) \<in> r\<^sup>* \<Longrightarrow> P y \<longrightarrow> \<not> P x \<longrightarrow>
    (\<exists>u v. (x, u) \<in> r\<^sup>* \<and> (u, v) \<in> r \<and> (v, y) \<in> r\<^sup>* \<and> \<not> P u \<and> P v)"
  (is "_ \<Longrightarrow> _ \<longrightarrow> _ \<longrightarrow> (\<exists>u v. ?P\<^sub>2 x y u v)")
proof (erule rtrancl_induct, simp, (rule impI)+)
  fix y z
  assume
    A: "(x, y) \<in> r\<^sup>*" and
    B: "(y, z) \<in> r" and
    C: "P z"
  assume "P y \<longrightarrow> \<not> P x \<longrightarrow>(\<exists>u v. ?P\<^sub>2 x y u v)" and "\<not> P x"
  hence D: "P y \<longrightarrow> (\<exists>u v. ?P\<^sub>2 x y u v)" by simp
  show "\<exists>u v. ?P\<^sub>2 x z u v"
  proof (cases "P y")
    case True
    with D obtain u v where "?P\<^sub>2 x y u v" by blast
    moreover from this and B have "(v, z) \<in> r\<^sup>*" by auto
    ultimately show ?thesis by blast
  next
    case False
    with A and B and C have "?P\<^sub>2 x z y z" by simp
    thus ?thesis by blast
  qed
qed

proposition state_subset:
 "s \<Turnstile> s' \<Longrightarrow> s \<subseteq> s'"
by (erule rtrancl_induct, auto simp add: rel_def image_def)

proposition spied_subset:
 "s \<Turnstile> s' \<Longrightarrow> spied s \<subseteq> spied s'"
by (rule Image_mono, erule state_subset, simp)

proposition parts_init:
 "parts (used s\<^sub>0) = used s\<^sub>0"
by (rule equalityI, rule_tac [!] subsetI, erule_tac [2] parts_used,
 erule parts.induct, auto)

proposition parts_idem [simp]:
 "parts (parts H) = parts H"
by (rule equalityI, rule subsetI, erule parts.induct, auto)

proposition parts_mono:
 "H \<subseteq> H' \<Longrightarrow> parts H \<subseteq> parts H'"
by (rule subsetI, erule parts.induct, auto)

lemma parts_union_1:
 "parts (H \<union> H') \<subseteq> parts H \<union> parts H'"
by (rule subsetI, erule parts.induct, auto)

lemma parts_union_2:
 "parts H \<union> parts H' \<subseteq> parts (H \<union> H')"
by (rule subsetI, erule UnE, erule_tac [!] parts.induct, auto)

proposition parts_union [simp]:
 "parts (H \<union> H') = parts H \<union> parts H'"
by (rule equalityI, rule parts_union_1, rule parts_union_2)

proposition parts_insert:
 "parts (insert X H) = parts_msg X \<union> parts H"
by (simp only: insert_def parts_union, subst parts_msg_def, simp)

proposition parts_msg_mono:
 "X \<in> H \<Longrightarrow> parts_msg X \<subseteq> parts H"
by (subgoal_tac "{X} \<subseteq> H", subst parts_msg_def, erule parts_mono, simp)

proposition parts_msg_agrkey [simp]:
 "parts_msg (AgrKey K) = {AgrKey K}"
by (subst parts_msg_def, rule equalityI, rule subsetI, erule parts.induct, auto)

proposition parts_msg_hash [simp]:
 "parts_msg (Hash X) = {Hash X}"
by (subst parts_msg_def, rule equalityI, rule subsetI, erule parts.induct, auto)

lemma parts_crypt_1:
 "parts {Crypt K X} \<subseteq> insert (Crypt K X) (parts {X})"
by (rule subsetI, erule parts.induct, auto)

lemma parts_crypt_2:
 "insert (Crypt K X) (parts {X}) \<subseteq> parts {Crypt K X}"
by (rule subsetI, simp, erule disjE, blast, erule parts.induct, auto)

proposition parts_msg_crypt [simp]:
 "parts_msg (Crypt K X) = insert (Crypt K X) (parts_msg X)"
by (simp add: parts_msg_def, rule equalityI, rule parts_crypt_1, rule parts_crypt_2)

lemma parts_mpair_1:
 "parts {\<lbrace>X, Y\<rbrace>} \<subseteq> insert \<lbrace>X, Y\<rbrace> (parts {X} \<union> parts {Y})"
by (rule subsetI, erule parts.induct, auto)

lemma parts_mpair_2:
 "insert \<lbrace>X, Y\<rbrace> (parts {X} \<union> parts {Y}) \<subseteq> parts {\<lbrace>X, Y\<rbrace>}"
by (rule subsetI, simp, erule disjE, blast, erule disjE, erule_tac [!] parts.induct,
 auto)

proposition parts_msg_mpair [simp]:
 "parts_msg \<lbrace>X, Y\<rbrace> = insert \<lbrace>X, Y\<rbrace> (parts_msg X \<union> parts_msg Y)"
by (simp add: parts_msg_def, rule equalityI, rule parts_mpair_1, rule parts_mpair_2)

proposition parts_msg_idinfo [simp]:
 "parts_msg \<langle>n, X\<rangle> = {\<langle>n, X\<rangle>}"
by (subst parts_msg_def, rule equalityI, rule subsetI, erule parts.induct, auto)

proposition parts_msg_parts:
 "\<lbrakk>(A, X) \<in> s; Y \<in> parts_msg X\<rbrakk> \<Longrightarrow> Y \<in> parts (used s)"
by (subgoal_tac "X \<in> parts (used s)", drule parts_msg_mono [of X], auto)

proposition prikey_spied:
 "\<lbrakk>s\<^sub>0 \<Turnstile> s; PriKey K \<in> parts (used s)\<rbrakk> \<Longrightarrow> PriKey K \<in> spied s"
by (induction rule: rtrancl_induct, subst (asm) parts_init,
 auto simp: rel_def parts_insert dest!: parts_msg_parts)

proposition prikey_crypt [simplified]:
 "\<lbrakk>(Spy, Crypt K (PriKey K')) \<in> s; s\<^sub>0 \<Turnstile> s\<rbrakk> \<Longrightarrow> PriKey K' \<in> spied s"
by (erule prikey_spied, blast)

proposition prikey_mpair_fst [simplified]:
 "\<lbrakk>(Spy, \<lbrace>PriKey K, Y\<rbrace>) \<in> s; s\<^sub>0 \<Turnstile> s\<rbrakk> \<Longrightarrow> PriKey K \<in> spied s"
by (erule prikey_spied, blast)

proposition prikey_mpair_snd [simplified]:
 "\<lbrakk>(Spy, \<lbrace>Y, PriKey K\<rbrace>) \<in> s; s\<^sub>0 \<Turnstile> s\<rbrakk> \<Longrightarrow> PriKey K \<in> spied s"
by (erule prikey_spied, blast)

proposition rev_prikey_secret:
 "s\<^sub>0 \<Turnstile> s \<Longrightarrow> Rev_PriKey \<notin> spied s"
by (induction rule: rtrancl_induct, insert sec_prik_rev tok_prik_rev,
 auto simp: rel_def dest: prikey_crypt prikey_mpair_fst prikey_mpair_snd)

proposition sec_prikey_secret:
 "\<lbrakk>s\<^sub>0 \<Turnstile> s; n \<notin> bad_sec_prik\<rbrakk> \<Longrightarrow> Sec_PriKey n \<notin> spied s"
by (induction rule: rtrancl_induct, insert sec_prik_inj sec_prik_tok_prik, auto simp:
 rel_def inj_on_def image_def dest: prikey_crypt prikey_mpair_fst prikey_mpair_snd)

proposition tok_prikey_secret:
 "\<lbrakk>s\<^sub>0 \<Turnstile> s; n \<notin> bad_tok_prik\<rbrakk> \<Longrightarrow> Tok_PriKey n \<notin> spied s"
by (induction rule: rtrancl_induct, insert tok_prik_inj sec_prik_tok_prik, auto simp:
 rel_def inj_on_def image_def dest: prikey_crypt prikey_mpair_fst prikey_mpair_snd)

proposition idinfo_spied:
 "\<lbrakk>s\<^sub>0 \<Turnstile> s; \<langle>n, X\<rangle> \<in> parts (used s)\<rbrakk> \<Longrightarrow> \<langle>n, X\<rangle> \<in> spied s"
by (induction rule: rtrancl_induct, subst (asm) parts_init,
 auto simp: rel_def parts_insert dest!: parts_msg_parts)

proposition idinfo_crypt:
 "\<lbrakk>(Spy, Crypt K \<langle>n, X\<rangle>) \<in> s; s\<^sub>0 \<Turnstile> s\<rbrakk> \<Longrightarrow> \<langle>n, X\<rangle> \<in> spied s"
by (erule idinfo_spied, blast)

proposition idinfo_mpair_fst:
 "\<lbrakk>(Spy, \<lbrace>\<langle>n, X\<rangle>, Y\<rbrace>) \<in> s; s\<^sub>0 \<Turnstile> s\<rbrakk> \<Longrightarrow> \<langle>n, X\<rangle> \<in> spied s"
by (erule idinfo_spied, blast)

proposition idinfo_mpair_snd:
 "\<lbrakk>(Spy, \<lbrace>Y, \<langle>n, X\<rangle>\<rbrace>) \<in> s; s\<^sub>0 \<Turnstile> s\<rbrakk> \<Longrightarrow> \<langle>n, X\<rangle> \<in> spied s"
by (erule idinfo_spied, blast)

proposition idinfo_hash_hash [rotated]:
 "\<lbrakk>s\<^sub>0 \<Turnstile> s; (Spy, \<langle>n, Hash (Hash X)\<rangle>) \<in> s\<rbrakk> \<Longrightarrow> \<langle>n, Hash X\<rangle> \<in> spied s"
by (induction arbitrary: X rule: rtrancl_induct, auto simp: rel_def
 dest: idinfo_crypt idinfo_mpair_fst idinfo_mpair_snd)

proposition sec_prik_eq:
 "{Tok_PriK n, Sec_PriK m, Rev_PriK} =
    {Tok_PriK n, Sec_PriK m', Rev_PriK} \<Longrightarrow> m' = m"
by (erule equalityE, drule subsetD [where c = "Sec_PriK m"], simp, insert
 sec_prik_inj sec_prik_rev sec_prik_tok_prik, auto simp: inj_on_def image_def)

proposition id_identified:
  assumes
    A: "s\<^sub>0 \<Turnstile> s" and
    B: "(n, m) \<notin> bad_id" and
    C: "n \<notin> bad_tok_prik" and
    D: "\<langle>n, Hash (ID n (Sec_PubKey m))\<rangle> \<in> spied s"
  shows "m \<in> bad_sec_prik \<and>
    (\<exists>m'. m' \<noteq> m \<and> m' \<in> bad_sec_prik \<and> (n, m') \<in> bad_id)"
proof -
  let ?P\<^sub>1 = "\<lambda>s. \<langle>n, Hash (ID n (Sec_PubKey m))\<rangle> \<in> spied s"
  let ?P\<^sub>2 = "\<lambda>s. \<exists>S. \<langle>n, PubKey S\<rangle> \<in> spied s \<and> Sec_PriK m \<in> S"
  let ?P\<^sub>3 = "\<lambda>S s. \<langle>n, Hash (PubKey S)\<rangle> \<in> spied s"
  let ?P\<^sub>4 = "\<lambda>S s. \<langle>n, PubKey S\<rangle> \<in> spied s \<and> Rev_PriK \<in> S \<and>
    (\<forall>m. Sec_PriK m \<in> S \<longrightarrow> (n, m) \<notin> bad_id)"
  have E: "\<forall>m. Sec_PriK m \<noteq> Rev_PriK"
    by (rule allI, rule notI, subgoal_tac "Rev_PriK \<in> range Sec_PriK",
     simp add: sec_prik_rev, rule range_eqI, rule sym)
  have "\<exists>u v. s\<^sub>0 \<Turnstile> u \<and> u \<turnstile> v \<and> v \<Turnstile> s \<and> \<not> ?P\<^sub>1 u \<and> ?P\<^sub>1 v"
    using A and B and D by (rule_tac rtrancl_start, auto dest: sec_prik_eq)
  then obtain u\<^sub>1 v\<^sub>1 where F: "s\<^sub>0 \<Turnstile> u\<^sub>1 \<and> u\<^sub>1 \<turnstile> v\<^sub>1 \<and> \<not> ?P\<^sub>1 u\<^sub>1 \<and> ?P\<^sub>1 v\<^sub>1"
    by blast
  moreover from this have G: "\<langle>n, ID n (Sec_PubKey m)\<rangle> \<in> spied u\<^sub>1"
    by (auto simp: rel_def dest: idinfo_crypt idinfo_mpair_fst idinfo_mpair_snd
     idinfo_hash_hash)
  ultimately have "\<exists>u v. s\<^sub>0 \<Turnstile> u \<and> u \<turnstile> v \<and> v \<Turnstile> u\<^sub>1 \<and> \<not> ?P\<^sub>2 u \<and> ?P\<^sub>2 v"
    using B and E by (rule_tac rtrancl_start, insert
     sec_prik_inj sec_prik_tok_prik, auto simp: inj_on_def image_def)
  then obtain u\<^sub>2 v\<^sub>2 where H: "s\<^sub>0 \<Turnstile> u\<^sub>2 \<and> u\<^sub>2 \<turnstile> v\<^sub>2 \<and> \<not> ?P\<^sub>2 u\<^sub>2 \<and> ?P\<^sub>2 v\<^sub>2"
    by blast
  moreover from this have "Tok_PriKey n \<notin> spied u\<^sub>2"
    using C by (rule_tac tok_prikey_secret, simp)
  ultimately have "Sec_PriKey m \<in> spied u\<^sub>2"
  proof (auto simp: rel_def dest: idinfo_crypt idinfo_mpair_fst idinfo_mpair_snd)
    fix S
    assume "(Spy, \<langle>n, Hash (AgrKey (PubK S))\<rangle>) \<in> u\<^sub>2"
    moreover assume I: "Sec_PriK m \<in> S"
    hence "\<langle>n, Hash (PubKey S)\<rangle> \<notin> spied s\<^sub>0"
      using B and E by (insert sec_prik_inj sec_prik_tok_prik,
       auto simp: inj_on_def image_def)
    ultimately have "\<exists>u v. s\<^sub>0 \<Turnstile> u \<and> u \<turnstile> v \<and> v \<Turnstile> u\<^sub>2 \<and> \<not> ?P\<^sub>3 S u \<and> ?P\<^sub>3 S v"
      using H by (rule_tac rtrancl_start, simp_all)
    then obtain u\<^sub>3 v\<^sub>3 where "s\<^sub>0 \<Turnstile> u\<^sub>3 \<and> u\<^sub>3 \<turnstile> v\<^sub>3 \<and> v\<^sub>3 \<Turnstile> u\<^sub>2 \<and>
      \<not> ?P\<^sub>3 S u\<^sub>3 \<and> ?P\<^sub>3 S v\<^sub>3"
      by blast
    moreover from this have "\<langle>n, PubKey S\<rangle> \<in> spied v\<^sub>3"
      by (auto simp: rel_def dest: idinfo_crypt idinfo_mpair_fst idinfo_mpair_snd
       idinfo_hash_hash)
    ultimately have "\<langle>n, PubKey S\<rangle> \<in> spied u\<^sub>2"
      by (rule_tac subsetD [of "spied v\<^sub>3"], rule_tac spied_subset, simp)
    hence "Sec_PriK m \<notin> S"
      using H by simp
    thus "(Spy, AgrKey (PriK (Sec_PriK m))) \<in> u\<^sub>2"
      using I by contradiction
  qed
  hence I: "m \<in> bad_sec_prik"
    using H by (erule_tac contrapos_pp, rule_tac sec_prikey_secret, simp)
  from B and E and G have "\<exists>S. ?P\<^sub>4 S u\<^sub>1"
    by (rule_tac exI [of _ "{Tok_PriK n, Sec_PriK m, Rev_PriK}"],
     insert sec_prik_inj sec_prik_tok_prik, auto simp: inj_on_def image_def)
  moreover have "\<not> (\<exists>S. ?P\<^sub>4 S s\<^sub>0)"
    by (insert tok_prik_rev, auto)
  ultimately have "\<exists>u v. s\<^sub>0 \<Turnstile> u \<and> u \<turnstile> v \<and> v \<Turnstile> u\<^sub>1 \<and>
    \<not> (\<exists>S. ?P\<^sub>4 S u) \<and> (\<exists>S. ?P\<^sub>4 S v)"
    using F by (rule_tac rtrancl_start, simp)
  then obtain u\<^sub>4 v\<^sub>4 S where
    J: "s\<^sub>0 \<Turnstile> u\<^sub>4" and K: "u\<^sub>4 \<turnstile> v\<^sub>4" and L: "\<not> (\<exists>S. ?P\<^sub>4 S u\<^sub>4) \<and> ?P\<^sub>4 S v\<^sub>4"
    by blast
  have M: "\<lbrakk>(Spy, \<langle>n, AgrKey (PubK S)\<rangle>) \<in> u\<^sub>4; Rev_PriK \<in> S;
    \<forall>m. Sec_PriK m \<in> S \<longrightarrow> (n, m) \<notin> bad_id;
    \<forall>S. Rev_PriK \<in> S \<longrightarrow> (Spy, \<langle>n, AgrKey (PubK S)\<rangle>) \<in> u\<^sub>4 \<longrightarrow>
      (\<exists>m. Sec_PriK m \<in> S \<and> (n, m) \<in> bad_id)\<rbrakk> \<Longrightarrow> False"
    by blast
  from K and L have "\<exists>m'. m' \<noteq> m \<and> m' \<in> bad_sec_prik \<and> (n, m') \<in> bad_id"
  proof (simp add: rel_def, (erule_tac disjE, (clarsimp, (erule_tac disjE,
   drule_tac sym, simp, (drule_tac idinfo_crypt [OF _ J] | drule_tac
   idinfo_mpair_fst [OF _ J] | drule_tac idinfo_mpair_snd [OF _ J]), blast)+)?,
   blast)+, (erule_tac disjE, erule_tac [2] disjE, erule_tac [3] disjE; clarsimp))
    fix n' S' A
    assume
      N: "\<forall>S. Rev_PriK \<in> S \<longrightarrow> (Spy, \<langle>n, AgrKey (PubK S)\<rangle>) \<in> u\<^sub>4 \<longrightarrow>
        (\<exists>m. Sec_PriK m \<in> S \<and> (n, m) \<in> bad_id)" and
      O: "\<forall>m. Sec_PriK m \<in> S \<longrightarrow> (n, m) \<notin> bad_id" and
      P: "Rev_PriK \<in> S" and
      Q: "(Spy, \<langle>n', AgrKey (PubK S')\<rangle>) \<in> u\<^sub>4" and
      R: "(Spy, AgrKey (PriK A)) \<in> u\<^sub>4"
    assume "n = n' \<and> S = S' - {A} \<or> (Spy, \<langle>n, AgrKey (PubK S)\<rangle>) \<in> u\<^sub>4"
    thus ?thesis
    proof (rule disjE, drule_tac [2] M [OF _ P O N]; clarsimp)
      assume S: "n = n'" and "S = S' - {A}"
      moreover from this obtain m' where
       "Sec_PriK m' \<in> S'" and T: "(n, m') \<in> bad_id"
        using N and P and Q by blast
      ultimately have "A = Sec_PriK m'"
        using O by (rule_tac ccontr, simp)
      hence "Sec_PriKey m' \<in> spied u\<^sub>4"
        using R by simp
      hence "m' \<in> bad_sec_prik"
        by (rule contrapos_pp, rule_tac sec_prikey_secret [OF J])
      thus "\<exists>m'. m' \<noteq> m \<and> m' \<in> bad_sec_prik \<and> (n', m') \<in> bad_id"
        using B and S and T by auto
    qed
  next
    fix n' S' A
    assume
      N: "\<forall>S. Rev_PriK \<in> S \<longrightarrow> (Spy, \<langle>n, AgrKey (PubK S)\<rangle>) \<in> u\<^sub>4 \<longrightarrow>
        (\<exists>m. Sec_PriK m \<in> S \<and> (n, m) \<in> bad_id)" and
      O: "\<forall>m. Sec_PriK m \<in> S \<longrightarrow> (n, m) \<notin> bad_id" and
      P: "Rev_PriK \<in> S" and
      Q: "(Spy, \<langle>n', AgrKey (PubK S')\<rangle>) \<in> u\<^sub>4" and
      R: "(Spy, AgrKey (PriK A)) \<in> u\<^sub>4"
    assume "n = n' \<and> S = insert A S' \<or> (Spy, \<langle>n, AgrKey (PubK S)\<rangle>) \<in> u\<^sub>4"
    thus ?thesis
    proof (rule disjE, drule_tac [2] M [OF _ P O N]; clarsimp)
      assume "n = n'" and S: "S = insert A S'"
      moreover have "A \<noteq> Rev_PriK"
        using R by (rule contrapos_pn, insert rev_prikey_secret [OF J], simp)
      ultimately obtain m' where "Sec_PriK m' \<in> S'" and T: "(n, m') \<in> bad_id"
        using N and P and Q by blast
      hence "(n, m') \<notin> bad_id"
        using O and S by simp
      thus "\<exists>m'. m' \<noteq> m \<and> m' \<in> bad_sec_prik \<and> (n', m') \<in> bad_id"
        using T by contradiction
    qed
  next
    fix n' S'
    assume
      N: "\<forall>S. Rev_PriK \<in> S \<longrightarrow> (Spy, \<langle>n, AgrKey (PubK S)\<rangle>) \<in> u\<^sub>4 \<longrightarrow>
        (\<exists>m. Sec_PriK m \<in> S \<and> (n, m) \<in> bad_id)" and
      O: "\<forall>m. Sec_PriK m \<in> S \<longrightarrow> (n, m) \<notin> bad_id" and
      P: "Rev_PriK \<in> S"
    assume "n = n' \<and> S = S' \<or> (Spy, \<langle>n, AgrKey (PubK S)\<rangle>) \<in> u\<^sub>4" and
      "(Spy, AgrKey (PriK (Tok_PriK n'))) \<in> u\<^sub>4"
    thus ?thesis
      by (erule_tac disjE, drule_tac [2] M [OF _ P O N],
       insert tok_prikey_secret [OF J C], simp_all)
  next
    fix n' X
    assume
      N: "\<forall>S. Rev_PriK \<in> S \<longrightarrow> (Spy, \<langle>n, AgrKey (PubK S)\<rangle>) \<in> u\<^sub>4 \<longrightarrow>
        (\<exists>m. Sec_PriK m \<in> S \<and> (n, m) \<in> bad_id)" and
      O: "\<forall>m. Sec_PriK m \<in> S \<longrightarrow> (n, m) \<notin> bad_id" and
      P: "Rev_PriK \<in> S" and
      Q: "(Spy, \<langle>n', X\<rangle>) \<in> u\<^sub>4 \<or> (Spy, \<langle>n', Hash X\<rangle>) \<in> u\<^sub>4"
    assume "n = n' \<and> AgrKey (PubK S) = X \<or>
      (Spy, \<langle>n, AgrKey (PubK S)\<rangle>) \<in> u\<^sub>4"
    thus ?thesis
    proof (rule disjE, drule_tac [2] M [OF _ P O N]; clarsimp)
      assume R: "n = n'" and S: "X = AgrKey (PubK S)"
      {
        assume "(Spy, \<langle>n', X\<rangle>) \<in> u\<^sub>4"
        hence "(Spy, \<langle>n, AgrKey (PubK S)\<rangle>) \<in> u\<^sub>4"
          using R and S by simp
      }
      moreover {
        assume "(Spy, \<langle>n', Hash X\<rangle>) \<in> u\<^sub>4"
        hence "?P\<^sub>3 S u\<^sub>4"
          using R and S by simp
        moreover have "\<not> ?P\<^sub>3 S s\<^sub>0"
          using O by auto
        ultimately have "\<exists>u v. s\<^sub>0 \<Turnstile> u \<and> u \<turnstile> v \<and> v \<Turnstile> u\<^sub>4 \<and> \<not> ?P\<^sub>3 S u \<and> ?P\<^sub>3 S v"
          using J by (rule_tac rtrancl_start)
        then obtain u\<^sub>3 v\<^sub>3 where "s\<^sub>0 \<Turnstile> u\<^sub>3 \<and> u\<^sub>3 \<turnstile> v\<^sub>3 \<and> v\<^sub>3 \<Turnstile> u\<^sub>4 \<and>
          \<not> ?P\<^sub>3 S u\<^sub>3 \<and> ?P\<^sub>3 S v\<^sub>3"
          by blast
        moreover from this have "\<langle>n, AgrKey (PubK S)\<rangle> \<in> spied v\<^sub>3"
          by (auto simp: rel_def dest: idinfo_crypt idinfo_mpair_fst idinfo_mpair_snd
           idinfo_hash_hash)
        ultimately have "\<langle>n, AgrKey (PubK S)\<rangle> \<in> spied u\<^sub>4"
          by (rule_tac subsetD [of "spied v\<^sub>3"], rule_tac spied_subset, simp)
      }
      ultimately have "(Spy, \<langle>n, AgrKey (PubK S)\<rangle>) \<in> u\<^sub>4"
        using Q by blast
      thus "\<exists>m'. m' \<noteq> m \<and> m' \<in> bad_sec_prik \<and> (n', m') \<in> bad_id"
        by (drule_tac M [OF _ P O N], simp)
    qed
  qed
  thus ?thesis
    using I by simp
qed

theorem id_anonymous [rotated]:
 "\<lbrakk>m \<notin> bad_sec_prik \<or> \<not> (\<exists>m'. m' \<noteq> m \<and> m' \<in> bad_sec_prik \<and> (n, m') \<in> bad_id);
    s\<^sub>0 \<Turnstile> s; (n, m) \<notin> bad_id; n \<notin> bad_tok_prik\<rbrakk> \<Longrightarrow>
  \<langle>n, Hash (ID n (Sec_PubKey m))\<rangle> \<notin> spied s"
by (erule contrapos_pn, drule id_identified, blast+)

end


(*  Title:      HOL/BNF_Greatest_Fixpoint.thy
    Author:     Dmitriy Traytel, TU Muenchen
    Author:     Lorenz Panny, TU Muenchen
    Author:     Jasmin Blanchette, TU Muenchen
    Copyright   2012, 2013, 2014

Greatest fixpoint (codatatype) operation on bounded natural functors.
*)

section \<open>Greatest Fixpoint (Codatatype) Operation on Bounded Natural Functors\<close>

theory BNF_Greatest_Fixpoint
imports BNF_Fixpoint_Base String
keywords
  "codatatype" :: thy_defn and
  "primcorecursive" :: thy_goal_defn and
  "primcorec" :: thy_defn
begin

alias proj = Equiv_Relations.proj

lemma one_pointE: "\<lbrakk>\<And>x. s = x \<Longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by simp

lemma obj_sumE: "\<lbrakk>\<forall>x. s = Inl x \<longrightarrow> P; \<forall>x. s = Inr x \<longrightarrow> P\<rbrakk> \<Longrightarrow> P"
  by (cases s) auto

lemma not_TrueE: "\<not> True \<Longrightarrow> P"
  by (erule notE, rule TrueI)

lemma neq_eq_eq_contradict: "\<lbrakk>t \<noteq> u; s = t; s = u\<rbrakk> \<Longrightarrow> P"
  by fast

lemma converse_Times: "(A \<times> B)\<inverse> = B \<times> A"
  by fast

lemma equiv_proj:
  assumes e: "equiv A R" and m: "z \<in> R"
  shows "(proj R \<circ> fst) z = (proj R \<circ> snd) z"
proof -
  from m have z: "(fst z, snd z) \<in> R" by auto
  with e have "\<And>x. (fst z, x) \<in> R \<Longrightarrow> (snd z, x) \<in> R" "\<And>x. (snd z, x) \<in> R \<Longrightarrow> (fst z, x) \<in> R"
    unfolding equiv_def sym_def trans_def by blast+
  then show ?thesis unfolding proj_def[abs_def] by auto
qed

(* Operators: *)
definition image2 where "image2 A f g = {(f a, g a) | a. a \<in> A}"

lemma Id_on_Gr: "Id_on A = Gr A id"
  unfolding Id_on_def Gr_def by auto

lemma image2_eqI: "\<lbrakk>b = f x; c = g x; x \<in> A\<rbrakk> \<Longrightarrow> (b, c) \<in> image2 A f g"
  unfolding image2_def by auto

lemma IdD: "(a, b) \<in> Id \<Longrightarrow> a = b"
  by auto

lemma image2_Gr: "image2 A f g = (Gr A f)\<inverse> O (Gr A g)"
  unfolding image2_def Gr_def by auto

lemma GrD1: "(x, fx) \<in> Gr A f \<Longrightarrow> x \<in> A"
  unfolding Gr_def by simp

lemma GrD2: "(x, fx) \<in> Gr A f \<Longrightarrow> f x = fx"
  unfolding Gr_def by simp

lemma Gr_incl: "Gr A f \<subseteq> A \<times> B \<longleftrightarrow> f ` A \<subseteq> B"
  unfolding Gr_def by auto

lemma subset_Collect_iff: "B \<subseteq> A \<Longrightarrow> (B \<subseteq> {x \<in> A. P x}) = (\<forall>x \<in> B. P x)"
  by blast

lemma subset_CollectI: "B \<subseteq> A \<Longrightarrow> (\<And>x. x \<in> B \<Longrightarrow> Q x \<Longrightarrow> P x) \<Longrightarrow> ({x \<in> B. Q x} \<subseteq> {x \<in> A. P x})"
  by blast

lemma in_rel_Collect_case_prod_eq: "in_rel (Collect (case_prod X)) = X"
  unfolding fun_eq_iff by auto

lemma Collect_case_prod_in_rel_leI: "X \<subseteq> Y \<Longrightarrow> X \<subseteq> Collect (case_prod (in_rel Y))"
  by auto

lemma Collect_case_prod_in_rel_leE: "X \<subseteq> Collect (case_prod (in_rel Y)) \<Longrightarrow> (X \<subseteq> Y \<Longrightarrow> R) \<Longrightarrow> R"
  by force

lemma conversep_in_rel: "(in_rel R)\<inverse>\<inverse> = in_rel (R\<inverse>)"
  unfolding fun_eq_iff by auto

lemma relcompp_in_rel: "in_rel R OO in_rel S = in_rel (R O S)"
  unfolding fun_eq_iff by auto

lemma in_rel_Gr: "in_rel (Gr A f) = Grp A f"
  unfolding Gr_def Grp_def fun_eq_iff by auto

definition relImage where
  "relImage R f \<equiv> {(f a1, f a2) | a1 a2. (a1,a2) \<in> R}"

definition relInvImage where
  "relInvImage A R f \<equiv> {(a1, a2) | a1 a2. a1 \<in> A \<and> a2 \<in> A \<and> (f a1, f a2) \<in> R}"

lemma relImage_Gr:
  "\<lbrakk>R \<subseteq> A \<times> A\<rbrakk> \<Longrightarrow> relImage R f = (Gr A f)\<inverse> O R O Gr A f"
  unfolding relImage_def Gr_def relcomp_def by auto

lemma relInvImage_Gr: "\<lbrakk>R \<subseteq> B \<times> B\<rbrakk> \<Longrightarrow> relInvImage A R f = Gr A f O R O (Gr A f)\<inverse>"
  unfolding Gr_def relcomp_def image_def relInvImage_def by auto

lemma relImage_mono:
  "R1 \<subseteq> R2 \<Longrightarrow> relImage R1 f \<subseteq> relImage R2 f"
  unfolding relImage_def by auto

lemma relInvImage_mono:
  "R1 \<subseteq> R2 \<Longrightarrow> relInvImage A R1 f \<subseteq> relInvImage A R2 f"
  unfolding relInvImage_def by auto

lemma relInvImage_Id_on:
  "(\<And>a1 a2. f a1 = f a2 \<longleftrightarrow> a1 = a2) \<Longrightarrow> relInvImage A (Id_on B) f \<subseteq> Id"
  unfolding relInvImage_def Id_on_def by auto

lemma relInvImage_UNIV_relImage:
  "R \<subseteq> relInvImage UNIV (relImage R f) f"
  unfolding relInvImage_def relImage_def by auto

lemma relImage_proj:
  assumes "equiv A R"
  shows "relImage R (proj R) \<subseteq> Id_on (A//R)"
  unfolding relImage_def Id_on_def
  using proj_iff[OF assms] equiv_class_eq_iff[OF assms]
  by (auto simp: proj_preserves)

lemma relImage_relInvImage:
  assumes "R \<subseteq> f ` A \<times> f ` A"
  shows "relImage (relInvImage A R f) f = R"
  using assms unfolding relImage_def relInvImage_def by fast

lemma subst_Pair: "P x y \<Longrightarrow> a = (x, y) \<Longrightarrow> P (fst a) (snd a)"
  by simp

lemma fst_diag_id: "(fst \<circ> (\<lambda>x. (x, x))) z = id z" by simp
lemma snd_diag_id: "(snd \<circ> (\<lambda>x. (x, x))) z = id z" by simp

lemma fst_diag_fst: "fst \<circ> ((\<lambda>x. (x, x)) \<circ> fst) = fst" by auto
lemma snd_diag_fst: "snd \<circ> ((\<lambda>x. (x, x)) \<circ> fst) = fst" by auto
lemma fst_diag_snd: "fst \<circ> ((\<lambda>x. (x, x)) \<circ> snd) = snd" by auto
lemma snd_diag_snd: "snd \<circ> ((\<lambda>x. (x, x)) \<circ> snd) = snd" by auto

definition Succ where "Succ Kl kl = {k . kl @ [k] \<in> Kl}"
definition Shift where "Shift Kl k = {kl. k # kl \<in> Kl}"
definition shift where "shift lab k = (\<lambda>kl. lab (k # kl))"

lemma empty_Shift: "\<lbrakk>[] \<in> Kl; k \<in> Succ Kl []\<rbrakk> \<Longrightarrow> [] \<in> Shift Kl k"
  unfolding Shift_def Succ_def by simp

lemma SuccD: "k \<in> Succ Kl kl \<Longrightarrow> kl @ [k] \<in> Kl"
  unfolding Succ_def by simp

lemmas SuccE = SuccD[elim_format]

lemma SuccI: "kl @ [k] \<in> Kl \<Longrightarrow> k \<in> Succ Kl kl"
  unfolding Succ_def by simp

lemma ShiftD: "kl \<in> Shift Kl k \<Longrightarrow> k # kl \<in> Kl"
  unfolding Shift_def by simp

lemma Succ_Shift: "Succ (Shift Kl k) kl = Succ Kl (k # kl)"
  unfolding Succ_def Shift_def by auto

lemma length_Cons: "length (x # xs) = Suc (length xs)"
  by simp

lemma length_append_singleton: "length (xs @ [x]) = Suc (length xs)"
  by simp

(*injection into the field of a cardinal*)
definition "toCard_pred A r f \<equiv> inj_on f A \<and> f ` A \<subseteq> Field r \<and> Card_order r"
definition "toCard A r \<equiv> SOME f. toCard_pred A r f"

lemma ex_toCard_pred:
  "\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> \<exists> f. toCard_pred A r f"
  unfolding toCard_pred_def
  using card_of_ordLeq[of A "Field r"]
    ordLeq_ordIso_trans[OF _ card_of_unique[of "Field r" r], of "|A|"]
  by blast

lemma toCard_pred_toCard:
  "\<lbrakk>|A| \<le>o r; Card_order r\<rbrakk> \<Longrightarrow> toCard_pred A r (toCard A r)"
  unfolding toCard_def using someI_ex[OF ex_toCard_pred] .

lemma toCard_inj: "\<lbrakk>|A| \<le>o r; Card_order r; x \<in> A; y \<in> A\<rbrakk> \<Longrightarrow> toCard A r x = toCard A r y \<longleftrightarrow> x = y"
  using toCard_pred_toCard unfolding inj_on_def toCard_pred_def by blast

definition "fromCard A r k \<equiv> SOME b. b \<in> A \<and> toCard A r b = k"

lemma fromCard_toCard:
  "\<lbrakk>|A| \<le>o r; Card_order r; b \<in> A\<rbrakk> \<Longrightarrow> fromCard A r (toCard A r b) = b"
  unfolding fromCard_def by (rule some_equality) (auto simp add: toCard_inj)

lemma Inl_Field_csum: "a \<in> Field r \<Longrightarrow> Inl a \<in> Field (r +c s)"
  unfolding Field_card_of csum_def by auto

lemma Inr_Field_csum: "a \<in> Field s \<Longrightarrow> Inr a \<in> Field (r +c s)"
  unfolding Field_card_of csum_def by auto

lemma rec_nat_0_imp: "f = rec_nat f1 (\<lambda>n rec. f2 n rec) \<Longrightarrow> f 0 = f1"
  by auto

lemma rec_nat_Suc_imp: "f = rec_nat f1 (\<lambda>n rec. f2 n rec) \<Longrightarrow> f (Suc n) = f2 n (f n)"
  by auto

lemma rec_list_Nil_imp: "f = rec_list f1 (\<lambda>x xs rec. f2 x xs rec) \<Longrightarrow> f [] = f1"
  by auto

lemma rec_list_Cons_imp: "f = rec_list f1 (\<lambda>x xs rec. f2 x xs rec) \<Longrightarrow> f (x # xs) = f2 x xs (f xs)"
  by auto

lemma not_arg_cong_Inr: "x \<noteq> y \<Longrightarrow> Inr x \<noteq> Inr y"
  by simp

definition image2p where
  "image2p f g R = (\<lambda>x y. \<exists>x' y'. R x' y' \<and> f x' = x \<and> g y' = y)"

lemma image2pI: "R x y \<Longrightarrow> image2p f g R (f x) (g y)"
  unfolding image2p_def by blast

lemma image2pE: "\<lbrakk>image2p f g R fx gy; (\<And>x y. fx = f x \<Longrightarrow> gy = g y \<Longrightarrow> R x y \<Longrightarrow> P)\<rbrakk> \<Longrightarrow> P"
  unfolding image2p_def by blast

lemma rel_fun_iff_geq_image2p: "rel_fun R S f g = (image2p f g R \<le> S)"
  unfolding rel_fun_def image2p_def by auto

lemma rel_fun_image2p: "rel_fun R (image2p f g R) f g"
  unfolding rel_fun_def image2p_def by auto

subsection \<open>Equivalence relations, quotients, and Hilbert's choice\<close>

lemma equiv_Eps_in:
"\<lbrakk>equiv A r; X \<in> A//r\<rbrakk> \<Longrightarrow> Eps (\<lambda>x. x \<in> X) \<in> X"
  apply (rule someI2_ex)
  using in_quotient_imp_non_empty by blast

lemma equiv_Eps_preserves:
  assumes ECH: "equiv A r" and X: "X \<in> A//r"
  shows "Eps (\<lambda>x. x \<in> X) \<in> A"
  apply (rule in_mono[rule_format])
   using assms apply (rule in_quotient_imp_subset)
  by (rule equiv_Eps_in) (rule assms)+

lemma proj_Eps:
  assumes "equiv A r" and "X \<in> A//r"
  shows "proj r (Eps (\<lambda>x. x \<in> X)) = X"
unfolding proj_def
proof auto
  fix x assume x: "x \<in> X"
  thus "(Eps (\<lambda>x. x \<in> X), x) \<in> r" using assms equiv_Eps_in in_quotient_imp_in_rel by fast
next
  fix x assume "(Eps (\<lambda>x. x \<in> X),x) \<in> r"
  thus "x \<in> X" using in_quotient_imp_closed[OF assms equiv_Eps_in[OF assms]] by fast
qed

definition univ where "univ f X == f (Eps (\<lambda>x. x \<in> X))"

lemma univ_commute:
assumes ECH: "equiv A r" and RES: "f respects r" and x: "x \<in> A"
shows "(univ f) (proj r x) = f x"
proof (unfold univ_def)
  have prj: "proj r x \<in> A//r" using x proj_preserves by fast
  hence "Eps (\<lambda>y. y \<in> proj r x) \<in> A" using ECH equiv_Eps_preserves by fast
  moreover have "proj r (Eps (\<lambda>y. y \<in> proj r x)) = proj r x" using ECH prj proj_Eps by fast
  ultimately have "(x, Eps (\<lambda>y. y \<in> proj r x)) \<in> r" using x ECH proj_iff by fast
  thus "f (Eps (\<lambda>y. y \<in> proj r x)) = f x" using RES unfolding congruent_def by fastforce
qed

lemma univ_preserves:
  assumes ECH: "equiv A r" and RES: "f respects r" and PRES: "\<forall>x \<in> A. f x \<in> B"
  shows "\<forall>X \<in> A//r. univ f X \<in> B"
proof
  fix X assume "X \<in> A//r"
  then obtain x where x: "x \<in> A" and X: "X = proj r x" using ECH proj_image[of r A] by blast
  hence "univ f X = f x" using ECH RES univ_commute by fastforce
  thus "univ f X \<in> B" using x PRES by simp
qed

lemma card_suc_ordLess_imp_ordLeq:
  assumes ORD: "Card_order r" "Card_order r'" "card_order r'"
  and LESS: "r <o card_suc r'"
shows "r \<le>o r'"
proof -
  have "Card_order (card_suc r')" by (rule Card_order_card_suc[OF ORD(3)])
  then have "cardSuc r \<le>o card_suc r'" using cardSuc_least ORD LESS by blast
  then have "cardSuc r \<le>o cardSuc r'" using cardSuc_ordIso_card_suc ordIso_symmetric
      ordLeq_ordIso_trans ORD(3) by blast
  then show ?thesis using cardSuc_mono_ordLeq ORD by blast
qed

lemma natLeq_ordLess_cinfinite: "\<lbrakk>Cinfinite r; card_order r\<rbrakk> \<Longrightarrow> natLeq <o card_suc r"
  using natLeq_ordLeq_cinfinite card_suc_greater ordLeq_ordLess_trans by blast

corollary natLeq_ordLess_cinfinite': "\<lbrakk>Cinfinite r'; card_order r'; r \<equiv> card_suc r'\<rbrakk> \<Longrightarrow> natLeq <o r"
  using natLeq_ordLess_cinfinite by blast

ML_file \<open>Tools/BNF/bnf_gfp_util.ML\<close>
ML_file \<open>Tools/BNF/bnf_gfp_tactics.ML\<close>
ML_file \<open>Tools/BNF/bnf_gfp.ML\<close>
ML_file \<open>Tools/BNF/bnf_gfp_rec_sugar_tactics.ML\<close>
ML_file \<open>Tools/BNF/bnf_gfp_rec_sugar.ML\<close>

end


section \<open>Irreducible terms (values)\<close>

theory Term_as_Value
imports Sterm
begin

section \<open>Viewing @{typ sterm} as values\<close>

(* FIXME why isn't this declared by BNF *)
declare list.pred_mono[mono]

context constructors begin

inductive is_value :: "sterm \<Rightarrow> bool" where
abs: "is_value (Sabs cs)" |
constr: "list_all is_value vs \<Longrightarrow> name |\<in>| C \<Longrightarrow> is_value (name $$ vs)"

lemma value_distinct:
  "Sabs cs \<noteq> name $$ ts" (is ?P)
  "name $$ ts \<noteq> Sabs cs" (is ?Q)
proof -
  show ?P
    apply (rule list_comb_cases'[where f = "const name" and xs = ts])
     apply (auto simp: const_sterm_def is_app_def elim: unapp_sterm.elims)
    done
  thus ?Q
    by simp
qed

abbreviation value_env :: "(name, sterm) fmap \<Rightarrow> bool" where
"value_env \<equiv> fmpred (\<lambda>_. is_value)"

lemma svar_value[simp]: "\<not> is_value (Svar name)"
proof
  assume "is_value (Svar name)"
  thus False
    apply (cases rule: is_value.cases)
    apply (fold free_sterm_def)
    by simp
qed

lemma value_cases:
  obtains (comb) name vs where "list_all is_value vs" "t = name $$ vs" "name |\<in>| C"
        | (abs) cs where "t = Sabs cs"
        | (nonvalue) "\<not> is_value t"
proof (cases t)
  case Svar
  thus thesis using nonvalue by simp
next
  case Sabs
  thus thesis using abs by (auto intro: is_value.abs)
next
  case (Sconst name)

  have "list_all is_value []" by simp
  have "t = name $$ []" unfolding Sconst by (simp add: const_sterm_def)
  show thesis
    using comb is_value.cases abs nonvalue by blast
next
  case Sapp

  show thesis
    proof (cases "is_value t")
      case False
      thus thesis using nonvalue by simp
    next
      case True
      then obtain name vs where "list_all is_value vs" "t = name $$ vs" "name |\<in>| C"
        unfolding Sapp
        by cases auto
      thus thesis using comb by simp
    qed
qed

end

fun smatch' :: "pat \<Rightarrow> sterm \<Rightarrow> (name, sterm) fmap option" where
"smatch' (Patvar name) t = Some (fmap_of_list [(name, t)])" |
"smatch' (Patconstr name ps) t =
  (case strip_comb t of
    (Sconst name', vs) \<Rightarrow>
      (if name = name' \<and> length ps = length vs then
        map_option (foldl (++\<^sub>f) fmempty) (those (map2 smatch' ps vs))
      else
        None)
  | _ \<Rightarrow> None)"

lemmas smatch'_induct = smatch'.induct[case_names var constr]

context constructors begin

context begin

private lemma smatch_list_comb_is_value:
  assumes "is_value t"
  shows "match (name $$ ps) t = (case strip_comb t of
    (Sconst name', vs) \<Rightarrow>
      (if name = name' \<and> length ps = length vs then
        map_option (foldl (++\<^sub>f) fmempty) (those (map2 match ps vs))
      else
        None)
  | _ \<Rightarrow> None)"
using assms
apply cases
apply (auto simp: strip_list_comb split: option.splits)
apply (subst (2) const_sterm_def)
apply (auto simp: matchs_alt_def)
done

lemma smatch_smatch'_eq:
  assumes "linear pat" "is_value t"
  shows "match pat t = smatch' (mk_pat pat) t"
using assms
proof (induction pat arbitrary: t rule: linear_pat_induct)
  case (comb name args)

  show ?case
    using \<open>is_value t\<close>
    proof (cases rule: is_value.cases)
      case (abs cs)
      thus ?thesis
        by (force simp: strip_list_comb_const)
    next
      case (constr args' name')

      have "map2 match args args' = map2 smatch' (map mk_pat args) args'" if "length args = length args'"
        using that constr(2) comb(2)
        by (induct args args' rule: list_induct2) auto

      thus ?thesis
        using constr
        apply (auto
                simp: smatch_list_comb_is_value strip_list_comb map_option_case strip_list_comb_const
                intro: is_value.intros)
        apply (subst (2) const_sterm_def)
        apply (auto simp: matchs_alt_def)
        done
    qed
qed simp

end

end

end


theory ResMap
  imports WellTypedExp GenSubEnv
begin

    (* ## NEW RES MAP DEFINITION ## *)

type_synonym nres_map = "string \<Rightarrow> perm_use_env option"

definition full_nres_map :: "'a state_env \<Rightarrow> nres_map \<Rightarrow> bool" where
  "full_nres_map s s_map = (\<forall> x. (s x = None) = (s_map x = None))"

definition nres_lookup where
  "nres_lookup rs_map x = (case rs_map x of
    None \<Rightarrow> empty_use_env
    | Some r_s \<Rightarrow> r_s
  )"

lemma nres_add_same: "nres_lookup (add_env rs_map x r_s) x = r_s"
  apply (simp add: nres_lookup_def)
  apply (simp add: add_env_def)
  done

lemma nres_add_diff: "\<lbrakk> x \<noteq> y \<rbrakk> \<Longrightarrow> nres_lookup (add_env rs_map x r_s) y = nres_lookup rs_map y"
  apply (simp add: nres_lookup_def)
  apply (simp add: add_env_def)
  done

lemma nres_rem_same: "nres_lookup (rem_env rs_map x) x = empty_use_env"
  apply (simp add: nres_lookup_def)
  apply (simp add: rem_env_def)
  done

lemma nres_rem_diff: "\<lbrakk> x \<noteq> y \<rbrakk> \<Longrightarrow> nres_lookup (rem_env rs_map x) y = nres_lookup rs_map y"
  apply (simp add: nres_lookup_def)
  apply (simp add: rem_env_def)
  done

lemma add_full_nres_map: "\<lbrakk> full_nres_map s rs_map \<rbrakk> \<Longrightarrow> full_nres_map (add_env s x v) (add_env rs_map x r_s)"
  apply (simp add: add_env_def)
  apply (simp add: full_nres_map_def)
  done

definition sub_nres_map :: "'a state_env \<Rightarrow> nres_map \<Rightarrow> bool" where
  "sub_nres_map s s_map = (\<forall> x. sub_use_env s (nres_lookup s_map x))"

lemma add_sub_nres_map2: "\<lbrakk> sub_nres_map s rs_map; s x = None \<rbrakk> \<Longrightarrow> sub_nres_map (add_env s x v) rs_map "
  apply (simp add: sub_nres_map_def)
  apply (auto)
  apply (erule_tac x="xa" in allE)
  apply (rule_tac s="s" in contain_sub_use_env)
   apply (simp)
  apply (rule_tac add_contain_env)
  apply (simp)
  done

lemma add_sub_nres_map1: "\<lbrakk> sub_nres_map s rs_map; sub_use_env s r_s \<rbrakk> \<Longrightarrow> sub_nres_map s (add_env rs_map x r_s) "
  apply (simp add: sub_nres_map_def)
  apply (auto)
  apply (case_tac "x = xa")
   apply (cut_tac rs_map="rs_map" and x="x" and r_s="r_s" in nres_add_same)
   apply (auto)
  apply (cut_tac rs_map="rs_map" and x="x" and r_s="r_s" in nres_add_diff)
   apply (auto)
  done

lemma dist_add_sub_nres_map: "\<lbrakk> sub_nres_map s rs_map; sub_use_env s r_s \<rbrakk> \<Longrightarrow> sub_nres_map (add_env s x v) (add_env rs_map x r_s) "
  apply (simp add: sub_nres_map_def)
  apply (auto)
  apply (case_tac "x = xa")
   apply (cut_tac rs_map="rs_map" and x="x" and r_s="r_s" in nres_add_same)
   apply (auto)
   apply (rule_tac add_sub_use_env)
   apply (simp)
  apply (cut_tac rs_map="rs_map" and x="x" and r_s="r_s" in nres_add_diff)
   apply (auto)
  apply (rule_tac add_sub_use_env)
  apply (simp)
  done

end


(*
    File:        dB.thy
    Time-stamp:  <2016-01-06T12:59:06Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: ZF (of Isabelle2015)
*)

theory dB imports dAlpha LAlpha begin

definition dB :: "i=>i" where
"dB(M) == LTerm_rec(%x. dVar(x), %x M r. dLam(dAbst(r, x, 0)),
                    %M N rm rn. dApp(rm, rn), M)"

definition LAlpha3 :: "[i,i] => o" where
"LAlpha3(M, N) == M: LTerm & N: LTerm & dB(M) = dB(N)"

definition dsubst :: "[i, i, i]=>i" where
"dsubst(M, x, N) == dSubst(dAbst(M, x, 0), 0, N)"

definition isSubst1 :: "[i,i,i,i]=>o" where
"isSubst1(A, x, B, C) == EX A'. LAlpha(A, A') & LFreeForIn(B, x, A') &
    LAlpha(Lsubst(A', x, B), C)"

definition isSubst2 :: "[i,i,i,i]=>o" where
"isSubst2(A, x, B, C) == A: LTerm & B: LTerm & C: LTerm & x: LVariable &
    dsubst(dB(A), x, dB(B)) = dB(C)"

lemma dB_eqns:
  "dB(LVar(x)) = dVar(x)"
  "dB(LLam(x, M)) = dLam(dAbst(dB(M), x, 0))"
  "dB(LApp(A, B)) = dApp(dB(A), dB(B))"
apply (unfold dB_def)
apply simp_all
done

lemma dB_type:
  "M: LTerm ==> dB(M): dProp"
apply (erule LTerm.induct)
apply (simp_all only: dB_eqns)
apply (case_tac [2] "x : dFV(dB(M))")
apply (erule_tac [2] dPropE)
apply (rule_tac [2] dProp_dLamI2)
prefer 3 apply (simp add: dDeg_dAbst_lemma2)
apply (frule_tac [3] dPropD1)
prefer 3 apply (simp add: dDeg_dAbst_lemma1)
apply (erule dProp_dLamI1)
apply (assumption | rule dProp_dTermIs dAbst_type nat_0I)+
done

lemma LFreeIn_imp_dFreeIn:
  assumes prem: "LFreeIn(<l, TLVar(x)>, M)"
  shows "<l, TdVar(x)>: dOcc(dB(M))"
apply (rule prem [THEN rev_mp])
apply (rule_tac x="l" in spec)
apply (rule prem [THEN LFreeInD1, THEN LTerm.induct])
apply (simp_all only: dB_eqns)
apply (safe elim!: LFreeIn_LTermEs LTag.free_elims
            intro!: dOcc_dTermIs)
apply (rule dOcc_dAbstI2)
apply (erule_tac [3] dB_type [THEN dPropD1])
apply (rule_tac [3] nat_0I)
prefer 2 apply (blast elim!: dTag.free_elims)
apply simp_all
done

lemma dFreeIn_imp_LFreeIn:
  assumes prem1: "<l, TdVar(x)>: dOcc(dB(M))"
  and prem2: "M: LTerm"
  shows "LFreeIn(<l, TLVar(x)>, M)"
apply (rule prem1 [THEN rev_mp])
apply (rule_tac x="l" in spec)
apply (rule prem2 [THEN LTerm.induct])
apply (simp_all only: dB_eqns)
apply (safe elim!: dOcc_dTermEs dTag.free_elims)
apply (frule_tac [2] dOcc_dAbst_lemma1)
apply (erule_tac [4] dOcc_dAbstE)
apply (erule_tac [2] dB_type [THEN dPropD1]
       | rule_tac [2] nat_0I)+
apply (blast intro!: LFreeIn_LTermIs elim!: dTag.free_elims)+
done

lemma dBoundBy_imp_LBoundBy:
  assumes prem1: "dBoundBy(<l, T>, <m, U>, dB(M))"
  and prem2: "M: LTerm"
  shows "EX T U. LBoundBy(<l, T>, <m, U>, M)"
apply (rule prem1 [THEN rev_mp])
apply (rule_tac x="m" in spec)
apply (rule_tac x="l" in spec)
apply (rule prem2 [THEN LTerm.induct])
apply (simp_all only: dB_eqns)
apply (safe elim!: dBoundBy_dTermEs dTag.free_elims)
apply (subgoal_tac "EX T. <m, T>: dOcc(dB(M))")
apply (erule_tac [2] dOcc_dAbstE)
apply (rule_tac [5] exI)
apply (rule_tac [4] exI)
apply (erule_tac [2] asm_rl
       | rule_tac [2] dB_type [THEN dPropD1] nat_0I)+
apply (erule exE)
apply (rule_tac n1="0" and x1="x" in dLamDeg_dAbst_lemma [THEN revcut_rl])
apply (erule dB_type [THEN dPropD1])
apply (assumption | rule nat_0I)+
apply (rotate_tac 6)
apply simp
apply (drule dOcc_dAbst_lemma3 [THEN dFreeIn_imp_LFreeIn])
apply (assumption | rule dB_type)+
apply (rule exI [THEN exI])
apply (erule LBoundBy_LLamI1)
apply (drule dBoundBy_dAbstD)
apply (assumption | rule dB_type [THEN dPropD1] nat_0I)+
apply (drule_tac [3] spec [THEN spec, THEN mp], erule_tac [3] asm_rl)
apply (drule_tac [2] spec [THEN spec, THEN mp], erule_tac [2] asm_rl)
apply (drule_tac [1] spec [THEN spec, THEN mp], erule_tac [1] asm_rl)
apply safe
apply (assumption | rule exI [THEN exI]
       | erule LBoundBy_LTermIs)+
done

lemma LBoundBy_imp_dBoundBy:
  assumes prem1: "LBoundBy(<l, T>, <m, U>, M)"
  shows "EX T U. dBoundBy(<l, T>, <m, U>, dB(M))"
apply (rule prem1 [THEN rev_mp])
apply (rule_tac x="m" in spec)
apply (rule_tac x="l" in spec)
apply (rule prem1 [THEN LBoundByD1, THEN LBindingD1, THEN LTerm.induct])
apply (simp_all only: dB_eqns)
apply (safe elim!: LBoundBy_LTermEs LTag.free_elims)
apply (drule LFreeIn_imp_dFreeIn)
apply (rule exI [THEN exI])
apply (rule dBoundBy_dLamI1)
apply (erule_tac [3] dOcc_dAbstI1)
apply (rule_tac [2] add_0 [THEN ssubst])
apply (assumption | rule dAbst_type dB_type [THEN dPropD1]
         dLamDeg_dAbst_lemma nat_0I dLamDeg_type)+
apply (drule_tac [3] spec [THEN spec, THEN mp], erule_tac [3] asm_rl)
apply (drule_tac [2] spec [THEN spec, THEN mp], erule_tac [2] asm_rl)
apply (drule_tac [1] spec [THEN spec, THEN mp], erule_tac [1] asm_rl)
apply safe
apply (assumption | rule dBoundBy_dTermIs dBoundBy_dAbstI
         nat_0I dB_type [THEN dPropD1] exI)+
done

lemma dOcc_TdLam_imp_LOcc_TLLam:
  assumes major: "<l, TdLam>: dOcc(dB(M))"
  and prem: "M: LTerm"
  shows "EX x. <l, TLLam(x)>: LOcc(M)"
apply (rule major [THEN rev_mp])
apply (rule_tac x="l" in spec)
apply (rule prem [THEN LTerm.induct])
apply (simp_all only: dB_eqns)
apply (safe elim!: dOcc_dTermEs dOcc_dAbstE dTag.free_elims)
apply (erule_tac [2] asm_rl
       | rule_tac [2] dB_type [THEN dPropD1] nat_0I)+
apply (drule_tac [4] spec [THEN mp], erule_tac [4] asm_rl)
apply (drule_tac [3] spec [THEN mp], erule_tac [3] asm_rl)
apply (drule_tac [2] spec [THEN mp], erule_tac [2] asm_rl)
apply safe
apply (assumption | rule exI LOcc_LTermIs)+
done

lemma LOcc_TLLam_imp_dOcc_TdLam:
  assumes major: "<l, TLLam(x)>: LOcc(M)"
  and prem: "M: LTerm"
  shows "<l, TdLam>: dOcc(dB(M))"
apply (rule major [THEN rev_mp])
apply (rule_tac x="l" in spec)
apply (rule prem [THEN LTerm.induct])
apply (simp_all only: dB_eqns)
apply (safe elim!: LOcc_LTermEs LTag.free_elims)
apply (drule_tac [4] spec [THEN mp], erule_tac [4] asm_rl)
apply (drule_tac [3] spec [THEN mp], erule_tac [3] asm_rl)
apply (drule_tac [2] spec [THEN mp], erule_tac [2] asm_rl)
apply (rule_tac [2] dOcc_dTermIs)
apply (erule_tac [2] dOcc_dAbstI2)
prefer 2 apply (blast elim!: dTag.free_elims)
apply (assumption | rule exI dB_type [THEN dPropD1] nat_0I
         dOcc_dTermIs)+
done

lemma dOcc_TdApp_imp_LOcc_TLApp:
  assumes major: "<l, TdApp>: dOcc(dB(M))"
  and prem: "M: LTerm"
  shows "<l, TLApp>: LOcc(M)"
apply (rule major [THEN rev_mp])
apply (rule_tac x="l" in spec)
apply (rule prem [THEN LTerm.induct])
apply (simp_all only: dB_eqns)
apply (safe elim!: dOcc_dTermEs dOcc_dAbstE dTag.free_elims)
apply (assumption | rule dB_type [THEN dPropD1] nat_0I)+
apply (drule_tac [4] spec [THEN mp], erule_tac [4] asm_rl)
apply (drule_tac [3] spec [THEN mp], erule_tac [3] asm_rl)
apply (drule_tac [1] spec [THEN mp], erule_tac [1] asm_rl)
apply (assumption | rule exI LOcc_LTermIs)+
done

lemma LOcc_TLApp_imp_dOcc_TdApp:
  assumes major: "<l, TLApp>: LOcc(M)"
  and prem: "M: LTerm"
  shows "<l, TdApp>: dOcc(dB(M))"
apply (rule major [THEN rev_mp])
apply (rule_tac x="l" in spec)
apply (rule prem [THEN LTerm.induct])
apply (simp_all only: dB_eqns)
apply (safe elim!: LOcc_LTermEs LTag.free_elims)
apply (drule_tac [4] spec [THEN mp], erule_tac [4] asm_rl)
apply (drule_tac [3] spec [THEN mp], erule_tac [3] asm_rl)
apply (drule_tac [1] spec [THEN mp], erule_tac [1] asm_rl)
apply (rule dOcc_dTermIs)
apply (erule dOcc_dAbstI2)
apply (blast elim!: dTag.free_elims)
apply (assumption | rule exI dB_type [THEN dPropD1] nat_0I
         dOcc_dTermIs)+
done

lemma LAlpha_imp_dAlpha:
  assumes major: "LAlpha(M, N)"
  shows "dAlpha(dB(M), dB(N))"
apply (insert major [THEN LAlphaD1, THEN LSkeltonEqD1]
              major [THEN LAlphaD1, THEN LSkeltonEqD2])
apply (rule dAlpha_dPropI)
apply (assumption | rule dB_type)+
apply safe
apply (drule_tac [8] dBoundBy_imp_LBoundBy)
apply (drule_tac [7] dBoundBy_imp_LBoundBy)
apply (drule_tac [6] dFreeIn_imp_LFreeIn)
apply (drule_tac [5] dFreeIn_imp_LFreeIn)
apply (drule_tac [4] dOcc_TdApp_imp_LOcc_TLApp)
apply (drule_tac [3] dOcc_TdApp_imp_LOcc_TLApp)
apply (drule_tac [2] dOcc_TdLam_imp_LOcc_TLLam)
apply (drule_tac [1] dOcc_TdLam_imp_LOcc_TLLam)
apply safe
apply (drule_tac [8] major [THEN LAlpha_sym, THEN LAlphaD3])
apply (drule_tac [7] major [THEN LAlphaD3])
apply (drule_tac [6] major [THEN LAlpha_sym, THEN LAlphaD2])
apply (drule_tac [5] major [THEN LAlphaD2])
apply (drule_tac [4] major [THEN LAlpha_sym, THEN LAlphaD1,
                            THEN LSkeltonEq_TLAppD])
apply (drule_tac [3] major [THEN LAlphaD1,
                            THEN LSkeltonEq_TLAppD])
apply (drule_tac [2] major [THEN LAlpha_sym, THEN LAlphaD1,
                            THEN LSkeltonEq_TLLamD])
apply (drule_tac [1] major [THEN LAlphaD1,
                            THEN LSkeltonEq_TLLamD])
apply safe
apply (drule_tac [8] LBoundBy_imp_dBoundBy)
apply (drule_tac [7] LBoundBy_imp_dBoundBy)
apply (drule_tac [6] LFreeIn_imp_dFreeIn)
apply (drule_tac [5] LFreeIn_imp_dFreeIn)
apply (drule_tac [4] LOcc_TLApp_imp_dOcc_TdApp)
apply (drule_tac [3] LOcc_TLApp_imp_dOcc_TdApp)
apply (drule_tac [2] LOcc_TLLam_imp_dOcc_TdLam)
apply (drule_tac [1] LOcc_TLLam_imp_dOcc_TdLam)
apply safe
apply (blast elim!: dBoundByE intro: dBoundByI)+
done

lemma dAlpha_imp_LAlpha:
  assumes major: "dAlpha(dB(M), dB(N))"
  and prem1: "M: LTerm"
  and prem2: "N: LTerm"
  shows "LAlpha(M, N)"
apply (insert prem1 prem2)
apply (rule LAlphaI2)
apply safe
apply (drule_tac [8] LBoundBy_imp_dBoundBy)
apply (drule_tac [7] LBoundBy_imp_dBoundBy)
apply (drule_tac [6] LFreeIn_imp_dFreeIn)
apply (drule_tac [5] LFreeIn_imp_dFreeIn)
apply (drule_tac [4] LOcc_TLApp_imp_dOcc_TdApp)
apply (drule_tac [3] LOcc_TLApp_imp_dOcc_TdApp)
apply (drule_tac [2] LOcc_TLLam_imp_dOcc_TdLam)
apply (drule_tac [1] LOcc_TLLam_imp_dOcc_TdLam)
apply safe
apply (drule_tac [8] major [THEN dAlpha_sym, THEN dAlpha_dBoundByD])
apply (drule_tac [7] major [THEN dAlpha_dBoundByD])
apply (drule_tac [6] major [THEN dAlpha_sym, THEN dAlphaD2])
apply (drule_tac [5] major [THEN dAlphaD2])
apply (drule_tac [4] major [THEN dAlpha_sym, THEN dAlphaD1,
                            THEN dSkeltonEq_TdAppD])
apply (drule_tac [3] major [THEN dAlphaD1,
                            THEN dSkeltonEq_TdAppD])
apply (drule_tac [2] major [THEN dAlpha_sym, THEN dAlphaD1,
                            THEN dSkeltonEq_TdLamD])
apply (drule_tac [1] major [THEN dAlphaD1,
                            THEN dSkeltonEq_TdLamD])
apply (drule_tac [8] dBoundBy_imp_LBoundBy)
apply (drule_tac [7] dBoundBy_imp_LBoundBy)
apply (drule_tac [6] dFreeIn_imp_LFreeIn)
apply (drule_tac [5] dFreeIn_imp_LFreeIn)
apply (drule_tac [4] dOcc_TdApp_imp_LOcc_TLApp)
apply (drule_tac [3] dOcc_TdApp_imp_LOcc_TLApp)
apply (drule_tac [2] dOcc_TdLam_imp_LOcc_TLLam)
apply (drule_tac [1] dOcc_TdLam_imp_LOcc_TLLam)
apply safe
apply (blast elim!: LBoundByE intro: LBoundByI)+
done

(** Now, we can prove correspondence between our alpha-equivarence, LAlpha,
    and equivarence under the de Bruijn notation, LAlpha3. **)

lemma LAlpha3_iff_LAlpha:
  "LAlpha3(M, N) <-> LAlpha(M, N)"
apply (unfold LAlpha3_def)
apply (rule iffI)
apply (erule conjE)+
apply (rule dAlpha_imp_LAlpha)
apply simp
apply (rule dAlpha_refl)
apply (assumption | rule dB_type [THEN dPropD1])+
apply (frule LAlphaD1 [THEN LSkeltonEqD1])
apply (frule LAlphaD1 [THEN LSkeltonEqD2])
apply (drule LAlpha_imp_dAlpha [THEN dAlpha_imp_dProp_eq])
apply (assumption | rule dB_type conjI)+
done

lemma LAlpha3D1:
  "LAlpha3(M, N) ==> M: LTerm"
apply (unfold LAlpha3_def)
apply (erule conjunct1)
done

lemma LAlpha3D2:
  "LAlpha3(M, N) ==> N: LTerm"
apply (unfold LAlpha3_def)
apply (erule conjunct2 [THEN conjunct1])
done

lemma LAlpha3D3:
  "LAlpha3(M, N) ==> dB(M) = dB(N)"
apply (unfold LAlpha3_def)
apply (erule conjunct2 [THEN conjunct2])
done

lemmas LAlpha_imp_dB_eq = LAlpha3_iff_LAlpha [THEN iffD2,
  THEN LAlpha3D3, rule_format]

lemmas dTerm_def_Terms_depth_induct = def_Terms_depth_induct [OF
  dTerm_Occ_cons_cond dTerm_Occ_ind_cond dOccinv_def]

lemma dProp_LTerm_lemma:
  assumes infv: "Infinite(LVariable)"
  and prem: "M: dProp"
  shows "EX M': LTerm. M = dB(M')"
apply (rule prem [THEN rev_mp])
apply (rule prem [THEN dPropD1, THEN dTerm_def_Terms_depth_induct])
apply (erule dTerm.cases)
prefer 4 apply hypsubst
prefer 4 apply hypsubst
defer 1
defer 1
apply (frule_tac [4] depth_ind_dApp1)
apply (frule_tac [6] depth_ind_dApp2)
apply (frule_tac [3] depth_ind_dLam)
apply (rule_tac [4] InfiniteE [OF infv dFV_Fin])
prefer 4 apply assumption
apply (safe elim!: dProp_dTermEs)
apply (drule_tac [3] M="Ma" and x="x" and n="0" in
         depth_ind_dSubst_dVar)
apply (frule_tac [6] M="Ma" and N="dVar(x)" in
         dDeg_dSubst_lemma3)
apply (erule_tac [3] asm_rl | rule_tac [3] nat_0I dProp_dVarI)+
apply (rule_tac x="LVar(x)" in bexI)
apply (simp only: dB_eqns)
apply (assumption | rule LTerm.intros)+
apply (frule_tac [3] x="Ma" in bspec)
apply (drule_tac [4] x="N" in bspec)
apply (drule_tac [2] x="dSubst(Ma, 0, dVar(x))" in bspec)
apply (drule_tac [1] x="Ma" in bspec)
prefer 3
prefer 5
prefer 6
apply (assumption | rule dSubst_type nat_0I dTerm.intros)+
apply (drule_tac [3] mp [THEN mp], erule_tac [3] asm_rl,
       erule_tac [3] asm_rl)+
apply (drule_tac [2] mp [THEN mp], erule_tac [2] asm_rl,
       erule_tac [2] asm_rl)+
apply (drule_tac [1] mp [THEN mp], erule_tac [1] asm_rl,
       erule_tac [1] asm_rl)+
apply safe
apply (rule_tac [3] x="LApp(M', M'a)" in bexI)
apply (rule_tac [2] x="LLam(x, M')" in bexI)
apply (rule_tac [1] x="LLam(x, M')" in bexI)
apply safe
apply (drule_tac [2] sym)
apply (drule_tac [2] sym)
apply (frule dDeg_dAbst_lemma1)
apply (assumption | rule nat_0I)+
apply (simp_all add: dB_eqns dAbst_dSubst_lemma)
done

(** LFV and dFV **)
lemma LFV_eq_dFV_dB:
  assumes major: "M: LTerm"
  shows "LFV(M) = dFV(dB(M))"
apply (rule major [THEN LTerm.induct])
apply (simp_all add: dB_eqns dB_type [THEN dPropD1]
         dFV_dAbst dAbst_type)
done

(** isSubst **)
lemma dsubst_lemma1:
  "[| x ~: dFV(M); dDeg(M) le n;
     M: dTerm; n: nat; N: dTerm
   |] ==> dSubst(dAbst(M, x, n), n, N) = M"
apply (rule dDeg_dAbst_lemma1 [THEN ssubst])
apply (rule_tac [4] dDeg_dSubst_lemma1)
apply assumption+
done

lemma dsubst_lemma2:
  assumes major: "x ~: dFV(N)"
  and sub: "dDeg(M) le n"
  and prem0: "x ~= y"
  and prem1: "M: dTerm"
  and prem2: "n: nat"
  and prem3: "N: dTerm"
  shows "dSubst(dAbst(dAbst(M, x, n), y, succ(n)), succ(n), N)
          = dAbst(dSubst(dAbst(M, y, n), n, N), x, n)"
apply (insert prem0)
apply (rule sub [THEN rev_mp])
apply (rule major [THEN rev_mp])
apply (rule prem2 [THEN [2] bspec])
apply (rule prem3 [THEN [2] bspec])
apply (rule prem1 [THEN dTerm.induct])
apply (rule_tac [4] ballI [THEN ballI])
apply (rule_tac [3] ballI [THEN ballI])
apply (rule_tac [2] ballI [THEN ballI])
apply (rule_tac [1] ballI [THEN ballI])
apply (case_tac [2] "xaa = n")
apply (case_tac "x = xa")
apply (case_tac [2] "y = xa")
apply (case_tac "y = xa")
apply (simp_all add: dDeg_dAbst_lemma1 succ_neq_self_simps
        split del: split_if del: ball_simps)
apply safe
apply (erule_tac [2] bspec [THEN bspec, THEN mp, THEN mp, THEN function_apply_eq])
prefer 4 apply (simp add: dFV_dLift_iff)
apply (subgoal_tac "succ(xaa) ~= n" "~ succ(xaa) < n")
apply (simp split del: split_if)
apply (safe intro!: dLift_type)
apply (drule_tac [2] leI [THEN succ_le_iff [THEN iffD1]])
apply (erule_tac [2] lt_irrefl)
apply (drule lt_trans, assumption)
apply (drule leI [THEN succ_le_iff [THEN iffD1]])
apply (erule lt_irrefl)
done

lemma Lsubst_eq_dsubst:
  assumes major: "LFreeForIn(B, x, A)"
  shows "dB(Lsubst(A, x, B)) = dsubst(dB(A), x, dB(B))"
apply (rule major [THEN rev_mp])
apply (rule major [THEN LFreeForInD3, THEN LTerm.induct])
apply (rule_tac [3] impI, erule_tac [3] LFreeForIn_LTermEs)
apply (rule_tac [2] impI, erule_tac [2] LFreeForIn_LTermEs)
apply (rule_tac [1] impI, erule_tac [1] LFreeForIn_LTermEs)
apply (subgoal_tac [4] "LFreeForIn(B, x, M)")
apply (rule_tac [5] LFreeForInI)
apply (erule_tac [8] notE, erule_tac [8] LFV_I)
apply (erule_tac [5] asm_rl)+
apply (drule_tac [5] mp, erule_tac [5] asm_rl)+
apply (drule_tac [4] mp, erule_tac [4] asm_rl)+
apply (drule_tac [3] mp, erule_tac [3] asm_rl)+
prefer 2 apply hypsubst
prefer 2
apply (drule_tac [5] LFreeForInD1)+
apply (drule_tac [4] LFreeForInD1)+
apply (drule_tac [3] LFreeForInD1)+
apply (case_tac "x = xa")
prefer 2
apply (simp_all add: dB_eqns)
apply (simp_all add: dsubst_def dB_type [THEN dPropD1]
        dB_type [THEN dPropD2] dDeg_dLift_lemma1)
apply (rule_tac [2] dsubst_lemma2 [THEN sym, THEN function_apply_eq])
apply (rule_tac [8] dsubst_lemma1 [THEN sym, THEN function_apply_eq])
apply (rule_tac [1] dsubst_lemma1 [THEN sym, THEN function_apply_eq])
prefer 3
prefer 4
prefer 5
prefer 9
prefer 10
prefer 11
prefer 14
prefer 15
prefer 16
apply (assumption | rule dAbst_type dB_type dPropD1 nat_succI
         nat_0I)+
prefer 5 apply blast
apply (erule_tac [4] dB_type [THEN dPropD2, THEN ssubst])
apply (rule_tac [4] Ord_0 [THEN le_refl])
apply (rule_tac [4] notI, erule_tac [4] dFV_E)
apply (rule_tac [3] notI, erule_tac [3] dFV_E)
apply (rule_tac [1] notI, erule_tac [1] dFV_E)
apply (drule_tac [3] dFreeIn_imp_LFreeIn)
apply (erule_tac [4] notE, erule_tac [4] LFV_I)
apply (erule_tac [4] dOcc_dAbstE)
apply (drule dOcc_dAbst_lemma1)
prefer 3 apply blast
prefer 7 apply (blast elim!: dTag.free_elims)
apply (drule_tac [7] dFreeIn_imp_LFreeIn)
apply (erule_tac [8] notE, erule_tac [8] LFV_I)
prefer 4
prefer 5
prefer 6
prefer 7
apply (assumption | rule dB_type dPropD1 nat_succI nat_0I)+
apply (erule_tac [2] dB_type [THEN dPropE])+
apply (erule_tac [1] dB_type [THEN dPropE])+
apply (case_tac [2] "xa: dFV(dB(M))")
apply (case_tac [1] "x: dFV(dB(M))")
apply (simp_all add: dDeg_dAbst_lemma1 dDeg_dAbst_lemma2)
done

lemma isSubst1_isSubst2_iff:
  assumes infv: "Infinite(LVariable)"
  shows "isSubst1(A, x, B, C) <-> isSubst2(A, x, B, C)"
apply (unfold isSubst1_def isSubst2_def)
apply safe
apply (erule LAlphaD1 [THEN LSkeltonEqD1])
apply (erule LFreeForInD1)
apply (erule LAlphaD1 [THEN LSkeltonEqD2])
apply (erule LFreeForInD2)
apply (frule_tac [2] M="A" and N="B" in
         infv [THEN Infinite_LVariable_LAlpha_lemma])
apply (erule_tac [2] asm_rl)+
apply safe
apply (rule_tac [2] exI)
apply (erule_tac [2] asm_rl | rule_tac [2] conjI)+
apply (simp_all only: LAlpha3_iff_LAlpha [THEN iff_sym])
apply (unfold LAlpha3_def)
apply safe
prefer 2
apply (assumption | rule Lsubst_type)+
apply (rotate_tac [2] 9)
apply (simp_all add: Lsubst_eq_dsubst)
done

end