(*
Authors:

  Anthony Bordg, University of Cambridge, apdb3@cam.ac.uk;
  Yijun He, University of Cambridge, yh403@cam.ac.uk
*)

section \<open>The No-Cloning Theorem\<close>

theory No_Cloning
imports
  Quantum
  Tensor
begin

subsection \<open>The Cauchy-Schwarz Inequality\<close>

lemma inner_prod_expand:
  assumes "dim_vec a = dim_vec b" and "dim_vec a = dim_vec c" and "dim_vec a = dim_vec d"
  shows "\<langle>a + b|c + d\<rangle> = \<langle>a|c\<rangle> + \<langle>a|d\<rangle> + \<langle>b|c\<rangle> + \<langle>b|d\<rangle>"
    apply (simp add: inner_prod_def)
    using assms sum.cong by (simp add: sum.distrib algebra_simps)

lemma inner_prod_distrib_left:
  assumes "dim_vec a = dim_vec b"
  shows "\<langle>c \<cdot>\<^sub>v a|b\<rangle> = cnj(c) * \<langle>a|b\<rangle>"
  using assms inner_prod_def by (simp add: algebra_simps mult_hom.hom_sum)

lemma inner_prod_distrib_right:
  assumes "dim_vec a = dim_vec b"
  shows "\<langle>a|c \<cdot>\<^sub>v b\<rangle> = c * \<langle>a|b\<rangle>"
  using assms by (simp add: algebra_simps mult_hom.hom_sum)

lemma cauchy_schwarz_ineq:
  assumes "dim_vec v = dim_vec w"
  shows "(cmod(\<langle>v|w\<rangle>))\<^sup>2 \<le> Re (\<langle>v|v\<rangle> * \<langle>w|w\<rangle>)"
proof (cases "\<langle>v|v\<rangle> = 0")
  case c0:True
  then have "\<And>i. i < dim_vec v \<Longrightarrow> v $ i = 0"
    by(metis index_zero_vec(1) inner_prod_with_itself_nonneg_reals_non0)
  then have "(cmod(\<langle>v|w\<rangle>))\<^sup>2 = 0" by (simp add: assms inner_prod_def)
  moreover have "Re (\<langle>v|v\<rangle> * \<langle>w|w\<rangle>) = 0" by (simp add: c0)
  ultimately show ?thesis by simp
next
  case c1:False
  have "dim_vec w = dim_vec (- \<langle>v|w\<rangle> / \<langle>v|v\<rangle> \<cdot>\<^sub>v v)" by (simp add: assms)
  then have "\<langle>w + -\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v|w + -\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v\<rangle> = \<langle>w|w\<rangle> + \<langle>w|-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v\<rangle> +
\<langle>-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v|w\<rangle> + \<langle>-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v|-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v\<rangle>"
    using inner_prod_expand[of "w" "-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v" "w" "-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v"] by auto
  moreover have "\<langle>w|-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v\<rangle> = -\<langle>v|w\<rangle>/\<langle>v|v\<rangle> * \<langle>w|v\<rangle>"
    using assms inner_prod_distrib_right[of "w" "v" "-\<langle>v|w\<rangle>/\<langle>v|v\<rangle>"] by simp
  moreover have "\<langle>-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v|w\<rangle> = cnj(-\<langle>v|w\<rangle>/\<langle>v|v\<rangle>) * \<langle>v|w\<rangle>"
    using assms inner_prod_distrib_left[of "v" "w" "-\<langle>v|w\<rangle>/\<langle>v|v\<rangle>"] by simp
  moreover have "\<langle>-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v|-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v\<rangle> = cnj(-\<langle>v|w\<rangle>/\<langle>v|v\<rangle>) * (-\<langle>v|w\<rangle>/\<langle>v|v\<rangle>) * \<langle>v|v\<rangle>"
    using inner_prod_distrib_left[of "v" "-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v" "-\<langle>v|w\<rangle>/\<langle>v|v\<rangle>"]
inner_prod_distrib_right[of "v" "v" "-\<langle>v|w\<rangle>/\<langle>v|v\<rangle>"] by simp
  ultimately have "\<langle>w + -\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v|w + -\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v\<rangle> = \<langle>w|w\<rangle> -  cmod(\<langle>v|w\<rangle>)^2 / \<langle>v|v\<rangle>"
    using assms inner_prod_cnj[of "w" "v"] inner_prod_cnj[of "v" "v"] complex_norm_square by simp
  moreover have "Re(\<langle>w + -\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v|w + -\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v\<rangle>) \<ge> 0"
    using inner_prod_with_itself_Re by blast
  ultimately have "Re(\<langle>w|w\<rangle>) \<ge> cmod(\<langle>v|w\<rangle>)^2/Re(\<langle>v|v\<rangle>)"
    using inner_prod_with_itself_real by simp
  moreover have c2:"Re(\<langle>v|v\<rangle>) > 0"
    using inner_prod_with_itself_Re_non0 inner_prod_with_itself_eq0 c1 by auto
  ultimately have "Re(\<langle>w|w\<rangle>) * Re(\<langle>v|v\<rangle>) \<ge> cmod(\<langle>v|w\<rangle>)^2/Re(\<langle>v|v\<rangle>) * Re(\<langle>v|v\<rangle>)"
    by (metis less_numeral_extra(3) nonzero_divide_eq_eq pos_divide_le_eq)
  thus ?thesis
    using inner_prod_with_itself_Im c2 by (simp add: mult.commute)
qed

lemma cauchy_schwarz_eq [simp]:
  assumes "v = (l \<cdot>\<^sub>v w)"
  shows "(cmod(\<langle>v|w\<rangle>))\<^sup>2 = Re (\<langle>v|v\<rangle> * \<langle>w|w\<rangle>)"
proof-
  have "cmod(\<langle>v|w\<rangle>) = cmod(cnj(l) * \<langle>w|w\<rangle>)"
    using assms inner_prod_distrib_left[of "w" "w" "l"] by simp
  then have "cmod(\<langle>v|w\<rangle>)^2 = cmod(l)^2 * \<langle>w|w\<rangle> * \<langle>w|w\<rangle>"
    using complex_norm_square inner_prod_cnj[of "w" "w"] by simp
  moreover have "\<langle>v|v\<rangle> = cmod(l)^2 * \<langle>w|w\<rangle>"
    using assms complex_norm_square inner_prod_distrib_left[of "w" "v" "l"]
inner_prod_distrib_right[of "w" "w" "l"] by simp
  ultimately show ?thesis by (metis Re_complex_of_real)
qed

lemma cauchy_schwarz_col [simp]:
  assumes "dim_vec v = dim_vec w" and "(cmod(\<langle>v|w\<rangle>))\<^sup>2 = Re (\<langle>v|v\<rangle> * \<langle>w|w\<rangle>)"
  shows "\<exists>l. v = (l \<cdot>\<^sub>v w) \<or> w = (l \<cdot>\<^sub>v v)"
proof (cases "\<langle>v|v\<rangle> = 0")
  case c0:True
  then have "\<And>i. i < dim_vec v \<Longrightarrow> v $ i = 0"
    by(metis index_zero_vec(1) inner_prod_with_itself_nonneg_reals_non0)
  then have "v = 0 \<cdot>\<^sub>v w" by (auto simp: assms)
  then show ?thesis by auto
next
  case c1:False
  have f0:"dim_vec w = dim_vec (- \<langle>v|w\<rangle> / \<langle>v|v\<rangle> \<cdot>\<^sub>v v)" by (simp add: assms(1))
  then have "\<langle>w + -\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v|w + -\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v\<rangle> = \<langle>w|w\<rangle> + \<langle>w|-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v\<rangle> +
\<langle>-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v|w\<rangle> + \<langle>-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v|-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v\<rangle>"
    using inner_prod_expand[of "w" "-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v" "w" "-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v"] by simp
  moreover have "\<langle>w|-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v\<rangle> = -\<langle>v|w\<rangle>/\<langle>v|v\<rangle> * \<langle>w|v\<rangle>"
    using assms(1) inner_prod_distrib_right[of "w" "v" "-\<langle>v|w\<rangle>/\<langle>v|v\<rangle>"] by simp
  moreover have "\<langle>-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v|w\<rangle> = cnj(-\<langle>v|w\<rangle>/\<langle>v|v\<rangle>) * \<langle>v|w\<rangle>"
    using assms(1) inner_prod_distrib_left[of "v" "w" "-\<langle>v|w\<rangle>/\<langle>v|v\<rangle>"] by simp
  moreover have "\<langle>-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v|-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v\<rangle> = cnj(-\<langle>v|w\<rangle>/\<langle>v|v\<rangle>) * (-\<langle>v|w\<rangle>/\<langle>v|v\<rangle>) * \<langle>v|v\<rangle>"
    using inner_prod_distrib_left[of "v" "-\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v" "-\<langle>v|w\<rangle>/\<langle>v|v\<rangle>"]
inner_prod_distrib_right[of "v" "v" "-\<langle>v|w\<rangle>/\<langle>v|v\<rangle>"] by simp
  ultimately have "\<langle>w + -\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v|w + -\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v\<rangle> = \<langle>w|w\<rangle> -  cmod(\<langle>v|w\<rangle>)^2 / \<langle>v|v\<rangle>"
    using inner_prod_cnj[of "w" "v"] inner_prod_cnj[of "v" "v"] assms(1) complex_norm_square by simp
  moreover have "\<langle>w|w\<rangle> = cmod(\<langle>v|w\<rangle>)^2 / \<langle>v|v\<rangle>"
    using assms(2) inner_prod_with_itself_real by(metis Reals_mult c1 nonzero_mult_div_cancel_left of_real_Re)
  ultimately have "\<langle>w + -\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v|w + -\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v\<rangle> = 0" by simp
  then have "\<And>i. i<dim_vec w \<Longrightarrow> (w + -\<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v) $ i = 0"
    by (metis f0 index_add_vec(2) index_zero_vec(1) inner_prod_with_itself_nonneg_reals_non0)
  then have "\<And>i. i<dim_vec w \<Longrightarrow> w $ i + -\<langle>v|w\<rangle>/\<langle>v|v\<rangle> * v $ i = 0"
    by (metis assms(1) f0 index_add_vec(1) index_smult_vec(1))
  then have "\<And>i. i<dim_vec w \<Longrightarrow> w $ i = \<langle>v|w\<rangle>/\<langle>v|v\<rangle> * v $ i" by simp
  then have "w = \<langle>v|w\<rangle>/\<langle>v|v\<rangle> \<cdot>\<^sub>v v" by (auto simp add: assms(1))
  thus ?thesis by auto
qed

subsection \<open>The No-Cloning Theorem\<close>

lemma eq_from_inner_prod [simp]:
  assumes "dim_vec v = dim_vec w" and "\<langle>v|w\<rangle> = 1" and "\<langle>v|v\<rangle> = 1" and "\<langle>w|w\<rangle> = 1"
  shows "v = w"
proof-
  have "(cmod(\<langle>v|w\<rangle>))\<^sup>2 = Re (\<langle>v|v\<rangle> * \<langle>w|w\<rangle>)" by (simp add: assms)
  then have f0:"\<exists>l. v = (l \<cdot>\<^sub>v w) \<or> w = (l \<cdot>\<^sub>v v)" by (simp add: assms(1))
  then show ?thesis
  proof (cases "\<exists>l. v = (l \<cdot>\<^sub>v w)")
    case True
    then have "\<exists>l. v = (l \<cdot>\<^sub>v w) \<and> \<langle>v|w\<rangle> = cnj(l) * \<langle>w|w\<rangle>"
      using inner_prod_distrib_left by auto
    then show ?thesis by (simp add: assms(2,4))
  next
    case False
    then have "\<exists>l. w = (l \<cdot>\<^sub>v v) \<and> \<langle>v|w\<rangle> = l * \<langle>v|v\<rangle>"
      using f0 inner_prod_distrib_right by auto
    then show ?thesis by (simp add: assms(2,3))
  qed
qed

lemma hermite_cnj_of_tensor:
  shows "(A \<Otimes> B)\<^sup>\<dagger>  = (A\<^sup>\<dagger>) \<Otimes> (B\<^sup>\<dagger>)"
proof
  show c0:"dim_row ((A \<Otimes> B)\<^sup>\<dagger>) = dim_row ((A\<^sup>\<dagger>) \<Otimes> (B\<^sup>\<dagger>))" by simp
  show c1:"dim_col ((A \<Otimes> B)\<^sup>\<dagger>) = dim_col ((A\<^sup>\<dagger>) \<Otimes> (B\<^sup>\<dagger>))" by simp
  show "\<And>i j. i < dim_row ((A\<^sup>\<dagger>) \<Otimes> (B\<^sup>\<dagger>)) \<Longrightarrow> j < dim_col ((A\<^sup>\<dagger>) \<Otimes> (B\<^sup>\<dagger>)) \<Longrightarrow>
((A \<Otimes> B)\<^sup>\<dagger>) $$ (i, j) = ((A\<^sup>\<dagger>) \<Otimes> (B\<^sup>\<dagger>)) $$ (i, j)"
  proof-
    fix i j assume a0:"i < dim_row ((A\<^sup>\<dagger>) \<Otimes> (B\<^sup>\<dagger>))" and a1:"j < dim_col ((A\<^sup>\<dagger>) \<Otimes> (B\<^sup>\<dagger>))"
    then have "(A \<Otimes> B)\<^sup>\<dagger> $$ (i, j) = cnj((A \<Otimes> B) $$ (j, i))" by (simp add: dagger_def)
    also have "\<dots> = cnj(A $$ (j div dim_row(B), i div dim_col(B)) * B $$ (j mod dim_row(B), i mod dim_col(B)))"
      by (metis (mono_tags, lifting) a0 a1 c1 dim_row_tensor_mat dim_col_of_dagger dim_row_of_dagger
index_tensor_mat less_nat_zero_code mult_not_zero neq0_conv)
    moreover have "((A\<^sup>\<dagger>) \<Otimes> (B\<^sup>\<dagger>)) $$ (i, j) =
(A\<^sup>\<dagger>) $$ (i div dim_col(B), j div dim_row(B)) * (B\<^sup>\<dagger>) $$ (i mod dim_col(B), j mod dim_row(B))"
      by (smt a0 a1 c1 dim_row_tensor_mat dim_col_of_dagger dim_row_of_dagger index_tensor_mat
less_nat_zero_code mult_eq_0_iff neq0_conv)
    moreover have "(B\<^sup>\<dagger>) $$ (i mod dim_col(B), j mod dim_row(B)) = cnj(B $$ (j mod dim_row(B), i mod dim_col(B)))"
    proof-
      have "i mod dim_col(B) < dim_col(B)"
        using a0 gr_implies_not_zero mod_div_trivial by fastforce
      moreover have "j mod dim_row(B) < dim_row(B)"
        using a1 gr_implies_not_zero mod_div_trivial by fastforce
      ultimately show ?thesis by (simp add: dagger_def)
    qed
    moreover have "(A\<^sup>\<dagger>) $$ (i div dim_col(B), j div dim_row(B)) = cnj(A $$ (j div dim_row(B), i div dim_col(B)))"
    proof-
      have "i div dim_col(B) < dim_col(A)"
        using a0 dagger_def by (simp add: less_mult_imp_div_less)
      moreover have "j div dim_row(B) < dim_row(A)"
        using a1 dagger_def by (simp add: less_mult_imp_div_less)
      ultimately show ?thesis by (simp add: dagger_def)
    qed
    ultimately show "((A \<Otimes> B)\<^sup>\<dagger>) $$ (i, j) = ((A\<^sup>\<dagger>) \<Otimes> (B\<^sup>\<dagger>)) $$ (i, j)" by simp
  qed
qed

locale quantum_machine =
  fixes n:: nat and s:: "complex Matrix.vec" and U:: "complex Matrix.mat"
  assumes dim_vec [simp]: "dim_vec s = 2^n"
    and dim_col [simp]: "dim_col U = 2^n * 2^n"
    and square [simp]: "square_mat U" and unitary [simp]: "unitary U"

lemma inner_prod_of_unit_vec:
  fixes n i:: nat
  assumes "i < n"
  shows "\<langle>unit_vec n i| unit_vec n i\<rangle> = 1"
  by (auto simp add: inner_prod_def unit_vec_def)
    (simp add: assms sum.cong[of "{0..<n}" "{0..<n}"
        "\<lambda>j. cnj (if j = i then 1 else 0) * (if j = i then 1 else 0)" "\<lambda>j. (if j = i then 1 else 0)"])

theorem (in quantum_machine) no_cloning:
  assumes [simp]: "dim_vec v = 2^n" and [simp]: "dim_vec w = 2^n" and
    cloning1: "\<And>s. U * ( |v\<rangle> \<Otimes> |s\<rangle>) = |v\<rangle> \<Otimes> |v\<rangle>" and
    cloning2: "\<And>s. U * ( |w\<rangle> \<Otimes> |s\<rangle>) = |w\<rangle> \<Otimes> |w\<rangle>" and
    "\<langle>v|v\<rangle> = 1" and "\<langle>w|w\<rangle> = 1"
  shows "v = w \<or> \<langle>v|w\<rangle> = 0"
proof-
  define s:: "complex Matrix.vec" where d0:"s = unit_vec (2^n) 0"
  have f0:"\<langle>|v\<rangle>| \<Otimes> \<langle>|s\<rangle>| = (( |v\<rangle> \<Otimes> |s\<rangle>)\<^sup>\<dagger>)"
    using hermite_cnj_of_tensor[of "|v\<rangle>" "|s\<rangle>"] bra_def dagger_def ket_vec_def by simp
  moreover have f1:"( |v\<rangle> \<Otimes> |v\<rangle>)\<^sup>\<dagger> * ( |w\<rangle> \<Otimes> |w\<rangle>) = (\<langle>|v\<rangle>| \<Otimes> \<langle>|s\<rangle>| ) * ( |w\<rangle> \<Otimes> |s\<rangle>)"
  proof-
    have "(U * ( |v\<rangle> \<Otimes> |s\<rangle>))\<^sup>\<dagger> = (\<langle>|v\<rangle>| \<Otimes> \<langle>|s\<rangle>| ) * (U\<^sup>\<dagger>)"
      using dagger_of_prod[of "U" "|v\<rangle> \<Otimes> |s\<rangle>"] f0 d0 by (simp add: ket_vec_def)
    then have "(U * ( |v\<rangle> \<Otimes> |s\<rangle>))\<^sup>\<dagger> * U * ( |w\<rangle> \<Otimes> |s\<rangle>) = (\<langle>|v\<rangle>| \<Otimes> \<langle>|s\<rangle>| ) * (U\<^sup>\<dagger>) * U * ( |w\<rangle> \<Otimes> |s\<rangle>)" by simp
    moreover have "(U * ( |v\<rangle> \<Otimes> |s\<rangle>))\<^sup>\<dagger> * U * ( |w\<rangle> \<Otimes> |s\<rangle>) = (( |v\<rangle> \<Otimes> |v\<rangle>)\<^sup>\<dagger>) * ( |w\<rangle> \<Otimes> |w\<rangle>)"
      using assms(2-4) d0 unit_vec_def by (smt Matrix.dim_vec assoc_mult_mat carrier_mat_triv dim_row_mat(1)
dim_row_tensor_mat dim_col_of_dagger index_mult_mat(2) ket_vec_def square square_mat.elims(2))
    moreover have "(U\<^sup>\<dagger>) * U = 1\<^sub>m (2^n * 2^n)"
      using unitary_def dim_col unitary by simp
    moreover have "(\<langle>|v\<rangle>| \<Otimes> \<langle>|s\<rangle>| ) * (U\<^sup>\<dagger>) * U = (\<langle>|v\<rangle>| \<Otimes> \<langle>|s\<rangle>| ) * ((U\<^sup>\<dagger>) * U)"
      using d0 assms(1) unit_vec_def by (smt Matrix.dim_vec assoc_mult_mat carrier_mat_triv dim_row_mat(1)
dim_row_tensor_mat f0 dim_col_of_dagger dim_row_of_dagger ket_vec_def local.dim_col)
    moreover have "(\<langle>|v\<rangle>| \<Otimes> \<langle>|s\<rangle>| ) * 1\<^sub>m (2^n * 2^n) = (\<langle>|v\<rangle>| \<Otimes> \<langle>|s\<rangle>| )"
      using f0 ket_vec_def d0 by simp
    ultimately show ?thesis by simp
  qed
  then have f2:"(\<langle>|v\<rangle>| * |w\<rangle>) \<Otimes> (\<langle>|v\<rangle>| * |w\<rangle>) = (\<langle>|v\<rangle>| * |w\<rangle>) \<Otimes> (\<langle>|s\<rangle>| * |s\<rangle>)"
  proof-
    have "\<langle>|v\<rangle>| \<Otimes> \<langle>|v\<rangle>| = (( |v\<rangle> \<Otimes> |v\<rangle>)\<^sup>\<dagger>)"
      using hermite_cnj_of_tensor[of "|v\<rangle>" "|v\<rangle>"] bra_def dagger_def ket_vec_def by simp
    then show ?thesis
      using f1 d0 by (simp add: bra_def mult_distr_tensor ket_vec_def)
  qed
  then have "\<langle>v|w\<rangle> * \<langle>v|w\<rangle> = \<langle>v|w\<rangle> * \<langle>s|s\<rangle>"
  proof-
    have "((\<langle>|v\<rangle>| * |w\<rangle>) \<Otimes> (\<langle>|v\<rangle>| * |w\<rangle>)) $$ (0,0) = \<langle>v|w\<rangle> * \<langle>v|w\<rangle>"
      using assms inner_prod_with_times_mat[of "v" "w"] by (simp add: bra_def ket_vec_def)
    moreover have "((\<langle>|v\<rangle>| * |w\<rangle>) \<Otimes> (\<langle>|s\<rangle>| * |s\<rangle>)) $$ (0,0) = \<langle>v|w\<rangle> * \<langle>s|s\<rangle>"
      using inner_prod_with_times_mat[of "v" "w"] inner_prod_with_times_mat[of "s" "s"] by(simp add: bra_def ket_vec_def)
    ultimately show ?thesis using f2 by auto
  qed
  then have "\<langle>v|w\<rangle> = 0 \<or> \<langle>v|w\<rangle> = \<langle>s|s\<rangle>" by (simp add: mult_left_cancel)
  moreover have "\<langle>s|s\<rangle> = 1" by(simp add: d0 inner_prod_of_unit_vec)
  ultimately show ?thesis using assms(1,2,5,6) by auto
qed

end


(* Title: Examples/SML_Relativization/Algebra/SML_Groups.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section\<open>Relativization of the results about groups\<close>
theory SML_Groups
  imports SML_Monoids
begin

subsection\<open>Simple groups\<close>

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

locale group_ow = semigroup_ow U f for U :: "'ag set" and f +
  fixes z (\<open>\<^bold>1\<^sub>o\<^sub>w\<close>)
    and inverse :: "'ag \<Rightarrow> 'ag"
  assumes z_closed[simp]: "\<^bold>1\<^sub>o\<^sub>w \<in> U"
    and inverse_closed[simp]: "a \<in> U \<Longrightarrow> inverse a \<in> U"
    and group_left_neutral: "a \<in> U \<Longrightarrow> \<^bold>1\<^sub>o\<^sub>w \<^bold>*\<^sub>o\<^sub>w a = a"
    and left_inverse[simp]: "a \<in> U \<Longrightarrow> inverse a \<^bold>*\<^sub>o\<^sub>w a = \<^bold>1\<^sub>o\<^sub>w"
begin

notation z (\<open>\<^bold>1\<^sub>o\<^sub>w\<close>)

lemma inverse_closed': "inverse ` U \<subseteq> U" by auto
lemma inverse_closed'': "\<forall>x\<in>U. inverse x \<in> U" by auto

lemma left_cancel:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U"
  shows "a \<^bold>*\<^sub>o\<^sub>w b = a \<^bold>*\<^sub>o\<^sub>w c \<longleftrightarrow> b = c"
proof
  assume "a \<^bold>*\<^sub>o\<^sub>w b = a \<^bold>*\<^sub>o\<^sub>w c"
  then have "inverse a \<^bold>*\<^sub>o\<^sub>w (a \<^bold>*\<^sub>o\<^sub>w b) = inverse a \<^bold>*\<^sub>o\<^sub>w (a \<^bold>*\<^sub>o\<^sub>w c)" by simp
  with assms have "(inverse a \<^bold>*\<^sub>o\<^sub>w a) \<^bold>*\<^sub>o\<^sub>w b = (inverse a \<^bold>*\<^sub>o\<^sub>w a) \<^bold>*\<^sub>o\<^sub>w c"
    by (metis assoc inverse_closed)
  with assms show "b = c"
    using group_ow_axioms by (fastforce simp: group_ow.group_left_neutral)
qed simp

sublocale monoid_ow U \<open>(\<^bold>*\<^sub>o\<^sub>w)\<close> \<open>\<^bold>1\<^sub>o\<^sub>w\<close>
proof
  show "a \<in> U \<Longrightarrow> a \<^bold>*\<^sub>o\<^sub>w \<^bold>1\<^sub>o\<^sub>w = a" for a
  proof-
    assume "a \<in> U"
    with left_inverse[OF this] have "inverse a \<^bold>*\<^sub>o\<^sub>w (a \<^bold>*\<^sub>o\<^sub>w \<^bold>1\<^sub>o\<^sub>w) = inverse a \<^bold>*\<^sub>o\<^sub>w a"
      by (metis assoc group_left_neutral inverse_closed z_closed)
    with \<open>a \<in> U\<close> z_closed show "a \<^bold>*\<^sub>o\<^sub>w \<^bold>1\<^sub>o\<^sub>w = a"
      by (meson left_cancel f_closed inverse_closed)
  qed
qed (simp add: group_left_neutral)+

lemma inverse_image[simp]: "inverse ` U \<subseteq> U" by (simp add: image_subsetI)

end

lemma group_ow: "group = group_ow UNIV"
  unfolding
    group_def group_ow_def  group_axioms_def group_ow_axioms_def semigroup_ow
  by simp

locale uminus_ow =
  fixes U :: "'ag set" and uminus :: "'ag \<Rightarrow> 'ag" (\<open>-\<^sub>o\<^sub>w _\<close> [81] 80)
  assumes uminus_closed: "a \<in> U \<Longrightarrow> -\<^sub>o\<^sub>w a \<in> U"
begin

notation uminus (\<open>-\<^sub>o\<^sub>w _\<close> [81] 80)

lemma uminus_closed': "uminus ` U \<subseteq> U" by (auto simp: uminus_closed)
lemma uminus_closed'': "\<forall>a\<in>U. -\<^sub>o\<^sub>w a \<in> U" by (simp add: uminus_closed)

tts_register_sbts uminus | U by (rule tts_AB_transfer[OF uminus_closed'])

end

locale group_add_ow =
  minus_ow U minus + uminus_ow U uminus + monoid_add_ow U plus zero
  for U :: "'ag set" and minus plus zero uminus +
  assumes left_inverse: "a \<in> U \<Longrightarrow> (-\<^sub>o\<^sub>w a) +\<^sub>o\<^sub>w a = 0\<^sub>o\<^sub>w"
    and add_inv_conv_diff: "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> a +\<^sub>o\<^sub>w (-\<^sub>o\<^sub>w b) = a -\<^sub>o\<^sub>w b"
begin

sublocale add: group_ow U \<open>(+\<^sub>o\<^sub>w)\<close> \<open>0\<^sub>o\<^sub>w\<close> uminus
  by unfold_locales (auto simp: uminus_closed left_inverse)

lemma inverse_unique:
  assumes "a \<in> U" and "b \<in> U" and "a +\<^sub>o\<^sub>w b = 0\<^sub>o\<^sub>w"
  shows "-\<^sub>o\<^sub>w a = b"
proof-
  from assms have "(-\<^sub>o\<^sub>w a +\<^sub>o\<^sub>w a) +\<^sub>o\<^sub>w b = -\<^sub>o\<^sub>w a"
    by (metis add.assoc uminus_closed add.right_neutral_mow)
  thus ?thesis
    unfolding left_inverse[OF \<open>a \<in> U\<close>] add.left_neutral_mow[OF \<open>b \<in> U\<close>] by simp
qed

lemma inverse_neutral[simp]: "-\<^sub>o\<^sub>w 0\<^sub>o\<^sub>w = 0\<^sub>o\<^sub>w"
  by
    (
      rule inverse_unique[
        OF zero_closed zero_closed add.left_neutral_mow[OF zero_closed]
        ]
    )

lemma inverse_inverse:
  assumes "a \<in> U"
  shows "-\<^sub>o\<^sub>w (-\<^sub>o\<^sub>w a) = a"
  by
    (
      rule inverse_unique[
        OF uminus_closed[OF assms] assms left_inverse[OF assms]
      ]
    )

lemma right_inverse:
  assumes "a \<in> U"
  shows "a +\<^sub>o\<^sub>w (-\<^sub>o\<^sub>w a) = 0\<^sub>o\<^sub>w"
proof -
  from assms have "a +\<^sub>o\<^sub>w (-\<^sub>o\<^sub>w a) = -\<^sub>o\<^sub>w (-\<^sub>o\<^sub>w a) +\<^sub>o\<^sub>w (-\<^sub>o\<^sub>w a)"
    by (simp add: inverse_inverse)
  moreover have "\<dots> = 0\<^sub>o\<^sub>w" by (rule left_inverse[OF uminus_closed[OF assms]])
  ultimately show ?thesis by simp
qed

sublocale cancel_semigroup_add_ow U \<open>(+\<^sub>o\<^sub>w)\<close>
proof
  fix a b c assume "a \<in> U" and "b \<in> U" and "c \<in> U" and "a +\<^sub>o\<^sub>w b = a +\<^sub>o\<^sub>w c"
  from \<open>a \<in> U\<close> \<open>b \<in> U\<close> \<open>c \<in> U\<close> this have
    "((-\<^sub>o\<^sub>w a) +\<^sub>o\<^sub>w a) +\<^sub>o\<^sub>w b = ((-\<^sub>o\<^sub>w a) +\<^sub>o\<^sub>w a) +\<^sub>o\<^sub>w c"
    by (auto simp: add.left_cancel)
  thus "b = c"
    unfolding
      left_inverse[OF \<open>a \<in> U\<close>]
      add.left_neutral_mow[OF \<open>b \<in> U\<close>]
      add.left_neutral_mow[OF \<open>c \<in> U\<close>]
    by simp
next
  fix a b c assume "a \<in> U" and "b \<in> U" and "c \<in> U" and "b +\<^sub>o\<^sub>w a = c +\<^sub>o\<^sub>w a"
  then have "b +\<^sub>o\<^sub>w (a +\<^sub>o\<^sub>w (-\<^sub>o\<^sub>w a)) = c +\<^sub>o\<^sub>w (a +\<^sub>o\<^sub>w (-\<^sub>o\<^sub>w a))"
    by (metis add.assoc uminus_closed)
  thus "b = c"
    unfolding
      right_inverse[OF \<open>a \<in> U\<close>]
      add.left_neutral_mow[OF \<open>b \<in> U\<close>]
      add.right_neutral_mow[OF \<open>c \<in> U\<close>]
    by (simp add: \<open>b \<in> U\<close>)
qed

end

lemma group_add_ow: "class.group_add = group_add_ow UNIV"
  unfolding
    class.group_add_def group_add_ow_def
    class.group_add_axioms_def group_add_ow_axioms_def
    minus_ow_def uminus_ow_def
    monoid_add_ow
  by simp

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma group_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows "((A ===> A ===> A) ===> A ===> (A ===> A) ===> (=))
    (group_ow (Collect (Domainp A))) group"
proof -
  let ?P = "((A ===> A ===> A) ===> A ===> (A ===> A) ===> (=))"
  let ?group_ow = "group_ow (Collect (Domainp A))"
  have
    "?P
      (\<lambda>f z inv. ?group_ow f z inv)
      (\<lambda>f z inv. z \<in> UNIV \<and> (\<forall>x\<in>UNIV. inv x \<in> UNIV) \<and> group f z inv)"
    unfolding group_ow_def group_def group_ow_axioms_def group_axioms_def
    apply transfer_prover_start
    apply transfer_step+
    by blast
  thus ?thesis by simp
qed

lemma group_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> (A ===> A ===> A) ===> A ===> (A ===> A) ===> (=))
      (group_add_ow (Collect (Domainp A))) class.group_add"
proof -
  let ?P =
    "((A ===> A ===> A) ===> (A ===> A ===> A) ===> A ===> (A ===> A) ===> (=))"
  let ?group_add_ow = "group_add_ow (Collect (Domainp A))"
  have
    "?P
      (\<lambda>minus plus zero uminus. ?group_add_ow minus plus zero uminus)
      (
        \<lambda>fi f z inv_f.
          (\<forall>x\<in>UNIV. \<forall>y\<in>UNIV. fi x y \<in> UNIV) \<and>
          (\<forall>x\<in>UNIV. inv_f x \<in> UNIV) \<and>
          class.group_add fi f z inv_f
      )"
    unfolding
      group_add_ow_def class.group_add_def
      group_add_ow_axioms_def class.group_add_axioms_def
      minus_ow_def uminus_ow_def
    apply transfer_prover_start
    apply transfer_step+
    by simp
  thus ?thesis by simp
qed

end

subsubsection\<open>Relativization\<close>

context group_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting group_ow_axioms and not_empty
  applying [OF f_closed' z_closed inverse_closed'']
begin

tts_lemma inverse_neutral: "inverse \<^bold>1\<^sub>o\<^sub>w = \<^bold>1\<^sub>o\<^sub>w"
  is group.inverse_neutral.

tts_lemma inverse_inverse:
  assumes "a \<in> U"
  shows "inverse (inverse a) = a"
    is group.inverse_inverse.

tts_lemma right_inverse:
  assumes "a \<in> U"
  shows "a \<^bold>*\<^sub>o\<^sub>w inverse a = \<^bold>1\<^sub>o\<^sub>w"
    is group.right_inverse.

tts_lemma inverse_distrib_swap:
  assumes "a \<in> U" and "b \<in> U"
  shows "inverse (a \<^bold>*\<^sub>o\<^sub>w b) = inverse b \<^bold>*\<^sub>o\<^sub>w inverse a"
    is group.inverse_distrib_swap.

tts_lemma right_cancel:
  assumes "b \<in> U" and "a \<in> U" and "c \<in> U"
  shows "(b \<^bold>*\<^sub>o\<^sub>w a = c \<^bold>*\<^sub>o\<^sub>w a) = (b = c)"
    is group.right_cancel.

tts_lemma inverse_unique:
  assumes "a \<in> U" and "b \<in> U" and "a \<^bold>*\<^sub>o\<^sub>w b = \<^bold>1\<^sub>o\<^sub>w"
  shows "inverse a = b"
    is group.inverse_unique.
end

end

context group_add_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting group_add_ow_axioms and zero.not_empty
  applying [OF minus_closed' plus_closed' zero_closed add.inverse_closed'']
begin

tts_lemma diff_0:
  assumes "a \<in> U"
  shows "0\<^sub>o\<^sub>w -\<^sub>o\<^sub>w a = -\<^sub>o\<^sub>w a"
    is group_add_class.diff_0.

tts_lemma diff_0_right:
  assumes "a \<in> U"
  shows "a -\<^sub>o\<^sub>w 0\<^sub>o\<^sub>w = a"
    is group_add_class.diff_0_right.

tts_lemma diff_self:
  assumes "a \<in> U"
  shows "a -\<^sub>o\<^sub>w a = 0\<^sub>o\<^sub>w"
    is group_add_class.diff_self.

tts_lemma group_left_neutral:
  assumes "a \<in> U"
  shows "0\<^sub>o\<^sub>w +\<^sub>o\<^sub>w a = a"
    is group_add_class.add.group_left_neutral.

tts_lemma minus_minus:
  assumes "a \<in> U"
  shows "-\<^sub>o\<^sub>w (-\<^sub>o\<^sub>w a) = a"
  is group_add_class.minus_minus.

tts_lemma right_minus:
  assumes "a \<in> U"
  shows "a +\<^sub>o\<^sub>w -\<^sub>o\<^sub>w a = 0\<^sub>o\<^sub>w"
  is group_add_class.right_minus.

tts_lemma left_minus:
  assumes "a \<in> U"
  shows "-\<^sub>o\<^sub>w a +\<^sub>o\<^sub>w a = 0\<^sub>o\<^sub>w"
    is group_add_class.left_minus.

tts_lemma add_diff_cancel:
  assumes "a \<in> U" and "b \<in> U"
  shows "a +\<^sub>o\<^sub>w b -\<^sub>o\<^sub>w b = a"
  is group_add_class.add_diff_cancel.

tts_lemma diff_add_cancel:
  assumes "a \<in> U" and "b \<in> U"
  shows "a -\<^sub>o\<^sub>w b +\<^sub>o\<^sub>w b = a"
    is group_add_class.diff_add_cancel.

tts_lemma diff_conv_add_uminus:
  assumes "a \<in> U" and "b \<in> U"
  shows "a -\<^sub>o\<^sub>w b = a +\<^sub>o\<^sub>w -\<^sub>o\<^sub>w b"
    is group_add_class.diff_conv_add_uminus.

tts_lemma diff_minus_eq_add:
  assumes "a \<in> U" and "b \<in> U"
  shows "a -\<^sub>o\<^sub>w -\<^sub>o\<^sub>w b = a +\<^sub>o\<^sub>w b"
    is group_add_class.diff_minus_eq_add.

tts_lemma add_uminus_conv_diff:
  assumes "a \<in> U" and "b \<in> U"
  shows "a +\<^sub>o\<^sub>w -\<^sub>o\<^sub>w b = a -\<^sub>o\<^sub>w b"
    is group_add_class.add_uminus_conv_diff.

tts_lemma minus_diff_eq:
  assumes "a \<in> U" and "b \<in> U"
  shows "-\<^sub>o\<^sub>w (a -\<^sub>o\<^sub>w b) = b -\<^sub>o\<^sub>w a"
    is group_add_class.minus_diff_eq.

tts_lemma add_minus_cancel:
  assumes "a \<in> U" and "b \<in> U"
  shows "a +\<^sub>o\<^sub>w (-\<^sub>o\<^sub>w a +\<^sub>o\<^sub>w b) = b"
    is group_add_class.add_minus_cancel.

tts_lemma minus_add_cancel:
  assumes "a \<in> U" and "b \<in> U"
  shows "-\<^sub>o\<^sub>w a +\<^sub>o\<^sub>w (a +\<^sub>o\<^sub>w b) = b"
    is group_add_class.minus_add_cancel.

tts_lemma neg_0_equal_iff_equal:
  assumes "a \<in> U"
  shows "(0\<^sub>o\<^sub>w = -\<^sub>o\<^sub>w a) = (0\<^sub>o\<^sub>w = a)"
    is group_add_class.neg_0_equal_iff_equal.

tts_lemma neg_equal_0_iff_equal:
  assumes "a \<in> U"
  shows "(-\<^sub>o\<^sub>w a = 0\<^sub>o\<^sub>w) = (a = 0\<^sub>o\<^sub>w)"
    is group_add_class.neg_equal_0_iff_equal.

tts_lemma eq_iff_diff_eq_0:
  assumes "a \<in> U" and "b \<in> U"
  shows "(a = b) = (a -\<^sub>o\<^sub>w b = 0\<^sub>o\<^sub>w)"
    is group_add_class.eq_iff_diff_eq_0.

tts_lemma equation_minus_iff:
  assumes "a \<in> U" and "b \<in> U"
  shows "(a = -\<^sub>o\<^sub>w b) = (b = -\<^sub>o\<^sub>w a)"
    is group_add_class.equation_minus_iff.

tts_lemma minus_equation_iff:
  assumes "a \<in> U" and "b \<in> U"
  shows "(-\<^sub>o\<^sub>w a = b) = (-\<^sub>o\<^sub>w b = a)"
    is group_add_class.minus_equation_iff.

tts_lemma neg_equal_iff_equal:
  assumes "a \<in> U" and "b \<in> U"
  shows "(-\<^sub>o\<^sub>w a = -\<^sub>o\<^sub>w b) = (a = b)"
    is group_add_class.neg_equal_iff_equal.

tts_lemma right_minus_eq:
  assumes "a \<in> U" and "b \<in> U"
  shows "(a -\<^sub>o\<^sub>w b = 0\<^sub>o\<^sub>w) = (a = b)"
    is group_add_class.right_minus_eq.

tts_lemma minus_add:
  assumes "a \<in> U" and "b \<in> U"
  shows "-\<^sub>o\<^sub>w (a +\<^sub>o\<^sub>w b) = -\<^sub>o\<^sub>w b +\<^sub>o\<^sub>w -\<^sub>o\<^sub>w a"
    is group_add_class.minus_add.

tts_lemma eq_neg_iff_add_eq_0:
  assumes "a \<in> U" and "b \<in> U"
  shows "(a = -\<^sub>o\<^sub>w b) = (a +\<^sub>o\<^sub>w b = 0\<^sub>o\<^sub>w)"
    is group_add_class.eq_neg_iff_add_eq_0.

tts_lemma neg_eq_iff_add_eq_0:
  assumes "a \<in> U" and "b \<in> U"
  shows "(-\<^sub>o\<^sub>w a = b) = (a +\<^sub>o\<^sub>w b = 0\<^sub>o\<^sub>w)"
    is group_add_class.neg_eq_iff_add_eq_0.

tts_lemma add_eq_0_iff2:
  assumes "a \<in> U" and "b \<in> U"
  shows "(a +\<^sub>o\<^sub>w b = 0\<^sub>o\<^sub>w) = (a = -\<^sub>o\<^sub>w b)"
    is group_add_class.add_eq_0_iff2.

tts_lemma add_eq_0_iff:
  assumes "a \<in> U" and "b \<in> U"
  shows "(a +\<^sub>o\<^sub>w b = 0\<^sub>o\<^sub>w) = (b = -\<^sub>o\<^sub>w a)"
    is group_add_class.add_eq_0_iff.

tts_lemma diff_diff_eq2:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U"
  shows "a -\<^sub>o\<^sub>w (b -\<^sub>o\<^sub>w c) = a +\<^sub>o\<^sub>w c -\<^sub>o\<^sub>w b"
    is group_add_class.diff_diff_eq2.

tts_lemma diff_add_eq_diff_diff_swap:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U"
  shows "a -\<^sub>o\<^sub>w (b +\<^sub>o\<^sub>w c) = a -\<^sub>o\<^sub>w c -\<^sub>o\<^sub>w b"
    is group_add_class.diff_add_eq_diff_diff_swap.

tts_lemma add_diff_eq:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U"
  shows "a +\<^sub>o\<^sub>w (b -\<^sub>o\<^sub>w c) = a +\<^sub>o\<^sub>w b -\<^sub>o\<^sub>w c"
    is group_add_class.add_diff_eq.

tts_lemma eq_diff_eq:
  assumes "a \<in> U" and "c \<in> U" and "b \<in> U"
  shows "(a = c -\<^sub>o\<^sub>w b) = (a +\<^sub>o\<^sub>w b = c)"
    is group_add_class.eq_diff_eq.

tts_lemma diff_eq_eq:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U"
  shows "(a -\<^sub>o\<^sub>w b = c) = (a = c +\<^sub>o\<^sub>w b)"
    is group_add_class.diff_eq_eq.

tts_lemma left_cancel:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U"
  shows "(a +\<^sub>o\<^sub>w b = a +\<^sub>o\<^sub>w c) = (b = c)"
    is group_add_class.add.left_cancel.

tts_lemma right_cancel:
  assumes "b \<in> U" and "a \<in> U" and "c \<in> U"
  shows "(b +\<^sub>o\<^sub>w a = c +\<^sub>o\<^sub>w a) = (b = c)"
    is group_add_class.add.right_cancel.

tts_lemma minus_unique:
  assumes "a \<in> U" and "b \<in> U" and "a +\<^sub>o\<^sub>w b = 0\<^sub>o\<^sub>w"
  shows "-\<^sub>o\<^sub>w a = b"
    is group_add_class.minus_unique.

tts_lemma diff_eq_diff_eq:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U" and "d \<in> U" and "a -\<^sub>o\<^sub>w b = c -\<^sub>o\<^sub>w d"
  shows "(a = b) = (c = d)"
    is group_add_class.diff_eq_diff_eq.

end

end

subsection\<open>Abelian groups\<close>

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

locale ab_group_add_ow =
  minus_ow U minus + uminus_ow U uminus + comm_monoid_add_ow U plus zero
  for U :: "'ag set" and plus zero minus uminus +
  assumes ab_left_minus: "a \<in> U \<Longrightarrow> -\<^sub>o\<^sub>w a +\<^sub>o\<^sub>w a = 0\<^sub>o\<^sub>w"
  assumes ab_diff_conv_add_uminus:
    "\<lbrakk> a \<in> U; b \<in> U \<rbrakk> \<Longrightarrow> a -\<^sub>o\<^sub>w b = a +\<^sub>o\<^sub>w (-\<^sub>o\<^sub>w b)"
begin

sublocale group_add_ow
  by unfold_locales (simp_all add: ab_left_minus ab_diff_conv_add_uminus)

sublocale cancel_comm_monoid_add_ow
  apply unfold_locales
  subgoal using add.commute by (fastforce simp: add_diff_cancel)
  subgoal by (metis add.commute diff_add_eq_diff_diff_swap)
  done

end

lemma ab_group_add_ow: "class.ab_group_add = ab_group_add_ow UNIV"
  unfolding
  class.ab_group_add_def ab_group_add_ow_def
  class.ab_group_add_axioms_def ab_group_add_ow_axioms_def
  minus_ow_def uminus_ow_def
  comm_monoid_add_ow
  by simp

lemma ab_group_add_ow_UNIV_axioms:
  "ab_group_add_ow (UNIV::'a::ab_group_add set) (+) 0 (-) uminus"
  by (fold ab_group_add_ow) (rule ab_group_add_class.ab_group_add_axioms)

subsubsection\<open>Transfer rules\<close>

context
  includes lifting_syntax
begin

lemma ab_group_add_transfer[transfer_rule]:
  assumes [transfer_rule]: "bi_unique A" "right_total A"
  shows
    "((A ===> A ===> A) ===> A ===> (A ===> A ===> A) ===> (A ===> A) ===> (=))
      (ab_group_add_ow (Collect (Domainp A))) class.ab_group_add"
proof -
  let ?P =
    "((A ===> A ===> A) ===> A ===> (A ===> A ===> A) ===> (A ===> A) ===> (=))"
  let ?ab_group_add_ow = "ab_group_add_ow (Collect (Domainp A))"
  have
    "?P
      ?ab_group_add_ow
      (
        \<lambda>plus zero minus uminus.
          (\<forall>x\<in>UNIV. \<forall>y\<in>UNIV. minus x y \<in> UNIV) \<and>
          (\<forall>x\<in>UNIV. uminus x \<in> UNIV) \<and>
          class.ab_group_add plus zero minus uminus
      )"
    unfolding
      ab_group_add_ow_def class.ab_group_add_def
      ab_group_add_ow_axioms_def class.ab_group_add_axioms_def
      minus_ow_def uminus_ow_def
    apply transfer_prover_start
    apply transfer_step+
    by simp
  thus ?thesis by simp
qed

end

subsubsection\<open>Relativization\<close>

context ab_group_add_ow
begin

tts_context
  tts: (?'a to U)
  rewriting ctr_simps
  substituting ab_group_add_ow_axioms and zero.not_empty
  applying [OF plus_closed' zero_closed minus_closed' add.inverse_closed'']
begin

tts_lemma uminus_add_conv_diff:
  assumes "a \<in> U" and "b \<in> U"
  shows "-\<^sub>o\<^sub>w a +\<^sub>o\<^sub>w b = b -\<^sub>o\<^sub>w a"
    is ab_group_add_class.uminus_add_conv_diff.

tts_lemma diff_add_eq:
  assumes "a \<in> U" and "b \<in> U" and "c \<in> U"
  shows "a -\<^sub>o\<^sub>w b +\<^sub>o\<^sub>w c = a +\<^sub>o\<^sub>w c -\<^sub>o\<^sub>w b"
    is ab_group_add_class.diff_add_eq.

end

end

text\<open>\newpage\<close>

end


theory mdom_mran
  imports Function_Model_Base mapp
begin

context Function_Model begin

(*MOVE TO mSet.thy*)
lemma msetI_eq :
  assumes "x = <set,x'>" "<set,x'> : M"
    shows "x : mSet"
    using msetI assms by auto
(* ------------- *)

subsection \<open>Domain of model Functions\<close>

definition mdom' :: \<open>'a \<Rightarrow> 'a\<close>
  where "mdom' f \<equiv> <set, dom (snd f)>"

definition mdom :: \<open>'a \<Rightarrow> 'a\<close>
  where "mdom f \<equiv> if f : mFunc then mdom' f
                  else Function_Model_mdefault"

lemma mdom_eq :
  assumes f : "f : mFunc"
    shows "mdom f = <set, dom (snd f)>"
  unfolding mdom_def mdom'_def
  using f by auto

lemma mdom_eq_pair :
  assumes f : "<func, f'> : mFunc"
    shows "mdom <func,f'> = <set, dom f'>"
  using mdom_eq[OF f] mfunc_snd_eq[OF f] by auto

lemma mdom_typ :
  "mdom : mFunc \<rightarrow> mSet"
proof (rule funI)
  fix f assume
    f : "f : mFunc"
  then obtain f' j where
    f' : "f' : Function" and f_eq : "f = <func, f'>" and
    j : "j : Ord" and
    dom : "dom f' \<subseteq> Tier j \<ominus> func"
    using mfuncE2 by metis
  hence "<set, dom f'> : M"
    using mI_mset[OF j dom_set[OF f'] ex_func_set_trans[OF tier_set]] by auto
  thus "mdom f : mSet"
   using msetI mdom_eq_pair f
   unfolding f_eq by auto
qed

lemmas mdom_mset = funE[OF mdom_typ]

lemma mdom_typ_ax :
  "m\<forall>x. x : mFunc \<longrightarrow> mdom x : mSet"
  unfolding mall_def tall_def
  using mdom_mset by auto

lemma mdom_iff :
  assumes f : "f : mFunc"
    shows "b m mdom f \<longleftrightarrow> (\<exists>c. mapp f b c)"
proof (rule mfuncE2[OF f])
  fix f' j assume
    f' : "f' : Function" and f_eq : "f = <func, f'>"
  show "(b m mdom f) = (\<exists>c. mapp f b c)"
  proof
    assume "b m mdom f"
    hence "b \<in> dom f'"
      using mdom_eq_pair f f_eq mmemD by auto
    then obtain c where
      "app f' b c"
      using domE[OF f'] by auto
    hence "mapp f b c"
      using mappI_pair f f_eq by auto
    thus "\<exists>c. mapp f b c" by auto
  next
    assume "\<exists>c. mapp f b c"
    then obtain c where
      "app f' b c"
      using mappD_pair f f_eq by auto
    hence "b \<in> dom f'"
      using domI[OF f'] by auto
    thus "b m mdom f"
      using mdom_eq_pair f mmemI_eq[OF mdom_mset]
      unfolding f_eq by auto
  qed
qed

lemma mdom_ax :
  "m\<forall>f : mFunc. m\<forall>x. (x m mdom f) = (m\<exists>y. mapp f x y)"
  unfolding mtall_def mall_def tall_def mex_def tex_def
  using mdom_iff mapp_m by metis

subsection \<open>Range of model Functions\<close>

definition mran' :: \<open>'a \<Rightarrow> 'a\<close>
  where "mran' f \<equiv> <set, ran (snd f)>"

definition mran :: \<open>'a \<Rightarrow> 'a\<close>
  where "mran f \<equiv> if f : mFunc then mran' f
                  else Function_Model_mdefault"

lemma mran_eq :
  assumes f : "f : mFunc"
    shows "mran f = <set, ran (snd f)>"
  unfolding mran_def mran'_def
  using f by auto

lemma mran_eq_pair :
  assumes f : "<func, f'> : mFunc"
    shows "mran <func,f'> = <set, ran f'>"
  using mran_eq[OF f] mfunc_snd_eq[OF f] by auto

lemma mran_typ :
  "mran : mFunc \<rightarrow> mSet"
proof (rule funI)
  fix f assume
    f : "f : mFunc"
  then obtain f' j where
    f' : "f' : Function" and f_eq : "f = <func, f'>" and
    j : "j : Ord" and
    ran : "ran f' \<subseteq> Tier j \<ominus> func"
    using mfuncE2 by metis
  hence "<set, ran f'> : M"
    using mI_mset[OF j ran_set[OF f'] ex_func_set_trans[OF tier_set]] by auto
  thus "mran f : mSet"
   using msetI mran_eq_pair f
   unfolding f_eq by auto
qed

lemmas mran_mset = funE[OF mran_typ]

lemma mran_typ_ax :
  "m\<forall>x. x : mFunc \<longrightarrow> mran x : mSet"
  unfolding mall_def tall_def
  using mran_mset by auto

lemma mran_iff :
  assumes f : "f : mFunc"
    shows "c m mran f \<longleftrightarrow> (\<exists>b. mapp f b c)"
proof (rule mfuncE2[OF f])
  fix f' j assume
    f' : "f' : Function" and f_eq : "f = <func, f'>"
  show "(c m mran f) = (\<exists>b. mapp f b c)"
  proof
    assume "c m mran f"
    hence "c \<in> ran f'"
      using mran_eq_pair f f_eq mmemD by auto
    then obtain b where
      "app f' b c"
      using ranE[OF f'] by auto
    hence "mapp f b c"
      using mappI_pair f f_eq by auto
    thus "\<exists>b. mapp f b c" by auto
  next
    assume "\<exists>b. mapp f b c"
    then obtain b where
      "app f' b c"
      using mappD_pair f f_eq by auto
    hence "c \<in> ran f'"
      using ranI[OF f'] by auto
    thus "c m mran f"
      using mran_eq_pair f mmemI_eq[OF mran_mset]
      unfolding f_eq by auto
  qed
qed

lemma mran_ax :
  "m\<forall>f : mFunc. m\<forall>y. (y m mran f) = (m\<exists>x. mapp f x y)"
   unfolding mtall_def mall_def tall_def mex_def tex_def
   using mran_iff mapp_m by metis

lemma mdom_rsp :
  "f : M \<Longrightarrow> mdom f : M"
  using mset_m[OF mdom_mset] Function_Model_mdefault_m
  unfolding mdom_def
  by auto

lemma mran_rsp :
  "f : M \<Longrightarrow> mran f : M"
  using mset_m[OF mran_mset] Function_Model_mdefault_m
  unfolding mran_def
  by auto

end
end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_03
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun y :: "'a list => 'a list => 'a list" where
  "y (nil2) y2 = y2"
| "y (cons2 z2 xs) y2 = cons2 z2 (y xs y2)"

fun x :: "Nat => Nat => bool" where
  "x (Z) (Z) = True"
| "x (Z) (S z2) = False"
| "x (S x2) (Z) = False"
| "x (S x2) (S y22) = x x2 y22"

fun count :: "Nat => Nat list => Nat" where
  "count z (nil2) = Z"
| "count z (cons2 z2 ys) =
     (if x z z2 then S (count z ys) else count z ys)"

fun t2 :: "Nat => Nat => bool" where
  "t2 (Z) y2 = True"
| "t2 (S z2) (Z) = False"
| "t2 (S z2) (S x2) = t2 z2 x2"

theorem property0 :
  "t2 (count n xs) (count n (y xs ys))"
  oops

end


theory PLTL
imports StutterEquivalence
begin

section {* Stuttering Invariant PLTL Formulas *}

text {*
  We define the syntax and semantics of propositional linear-time
  temporal logic PLTL and show that its next-free fragment is
  invariant to finite stuttering.
*}

subsection {* Syntax and semantics of PLTL *}

text {*
  PLTL formulas are built from atomic formulas, propositional connectives,
  and the temporal operators ``next'' and ``until''. The following data
  type definition is parameterized by the type of states over which
  formulas are evaluated.
*}

datatype 'a pltl =
    "false"
  | "atom" "'a \<Rightarrow> bool"
  | "implies" "'a pltl" "'a pltl"
  | "next" "'a pltl"
  | "until" "'a pltl" "'a pltl"

text {*
  The semantics of PLTL formulas is defined inductively w.r.t.
  @{text "\<omega>"}-sequences of states.
*}

fun holds_of :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a pltl \<Rightarrow> bool" ("_ \<Turnstile> _" [70,70] 40) where
  "(\<sigma> \<Turnstile> false) = False"
| "(\<sigma> \<Turnstile> atom p) = p (\<sigma> 0)"
| "(\<sigma> \<Turnstile> implies \<phi> \<psi>) = ((\<sigma> \<Turnstile> \<phi>) \<longrightarrow> (\<sigma> \<Turnstile> \<psi>))"
| "(\<sigma> \<Turnstile> next \<phi>) = (\<sigma>[1..] \<Turnstile> \<phi>)"
| "(\<sigma> \<Turnstile> until \<phi> \<psi>) = (\<exists>k. \<sigma>[k..] \<Turnstile> \<psi> \<and> (\<forall>i<k. \<sigma>[i..] \<Turnstile> \<phi>))"

text {*
  Further connectives of PLTL can be defined as abbreviations.
*}

definition not where "not \<phi> = implies \<phi> false"

definition true where "true = not false"

definition or where "or \<phi> \<psi> = implies (not \<phi>) \<psi>"

definition "and" where "and \<phi> \<psi> = not (or (not \<phi>) (not \<psi>))"

definition eventually where "eventually \<phi> = until true \<phi>"

definition always where "always \<phi> = not (eventually (not \<phi>))"

text {*
  These definitions give rise to the expected semantics.
*}

lemma holds_of_not [simp]: "(\<sigma> \<Turnstile> not \<phi>) = (\<not>(\<sigma> \<Turnstile> \<phi>))"
  by (simp add: not_def)

lemma holds_of_true [simp]: "\<sigma> \<Turnstile> true"
  by (simp add: true_def)

lemma holds_of_or [simp]: "(\<sigma> \<Turnstile> or \<phi> \<psi>) = (\<sigma> \<Turnstile> \<phi> \<or> \<sigma> \<Turnstile> \<psi>)"
  by (auto simp add: or_def)

lemma holds_of_and [simp]: "(\<sigma> \<Turnstile> and \<phi> \<psi>) = (\<sigma> \<Turnstile> \<phi> \<and> \<sigma> \<Turnstile> \<psi>)"
  by (simp add: and_def)

lemma holds_of_eventually [simp]: "(\<sigma> \<Turnstile> eventually \<phi>) = (\<exists>k. \<sigma>[k..] \<Turnstile> \<phi>)"
  by (simp add: eventually_def)

lemma holds_of_always [simp]: "(\<sigma> \<Turnstile> always \<phi>) = (\<forall>k. \<sigma>[k..] \<Turnstile> \<phi>)"
  by (simp add: always_def)

text {*
  We also define finite conjunctions and disjunctions.
*}

(* It would be tempting to define these operators as follows:

definition OR where "OR \<Phi> = Finite_Set.fold or false \<Phi>"
definition AND where "AND \<Phi> = Finite_Set.fold and true \<Phi>"

However, this would only work if "or" and "and" were left-commutative,
which they are not (syntactically). We must therefore resort to
the more general fold_graph predicate, effectively picking a
conjunction (or disjunction) in arbitrary order.

An alternative would be to define these generalized operators
over lists of formulas, but working with sets is more natural
in the following.
*)

definition OR where "OR \<Phi> \<equiv> SOME \<phi>. fold_graph or false \<Phi> \<phi>"

definition AND where "AND \<Phi> \<equiv> SOME \<phi>. fold_graph and true \<Phi> \<phi>"

lemma fold_graph_OR: "finite \<Phi> \<Longrightarrow> fold_graph or false \<Phi> (OR \<Phi>)"
  unfolding OR_def by (rule someI2_ex[OF finite_imp_fold_graph])

lemma fold_graph_AND: "finite \<Phi> \<Longrightarrow> fold_graph and true \<Phi> (AND \<Phi>)"
  unfolding AND_def by (rule someI2_ex[OF finite_imp_fold_graph])

lemma holds_of_OR [simp]:
  assumes fin: "finite (\<Phi>::'a pltl set)"
  shows "(\<sigma> \<Turnstile> OR \<Phi>) = (\<exists>\<phi>\<in>\<Phi>. \<sigma> \<Turnstile> \<phi>)"
proof -
  {
    fix \<psi>::"'a pltl"
    assume "fold_graph or false \<Phi> \<psi>"
    hence "(\<sigma> \<Turnstile> \<psi>) = (\<exists>\<phi>\<in>\<Phi>. \<sigma> \<Turnstile> \<phi>)"
      by (rule fold_graph.induct) auto
  }
  with fold_graph_OR[OF fin] show ?thesis by simp
qed

lemma holds_of_AND [simp]:
  assumes fin: "finite (\<Phi>::'a pltl set)"
  shows "(\<sigma> \<Turnstile> AND \<Phi>) = (\<forall>\<phi>\<in>\<Phi>. \<sigma> \<Turnstile> \<phi>)"
proof -
  {
    fix \<psi>::"'a pltl"
    assume "fold_graph and true \<Phi> \<psi>"
    hence "(\<sigma> \<Turnstile> \<psi>) = (\<forall>\<phi>\<in>\<Phi>. \<sigma> \<Turnstile> \<phi>)"
      by (rule fold_graph.induct) auto
  }
  with fold_graph_AND[OF fin] show ?thesis by simp
qed

subsection {* Next-Free PLTL Formulas *}

text {*
  A PLTL formula is called \emph{next-free} if it does not contain any
  subformula @{text "tnext f"}.
*}

fun "next_free" where
  "next_free false = True"
| "next_free (atom p) = True"
| "next_free (implies \<phi> \<psi>) = (next_free \<phi> \<and> next_free \<psi>)"
| "next_free (next \<phi>) = False"
| "next_free (until \<phi> \<psi>) = (next_free \<phi> \<and> next_free \<psi>)"

lemma next_free_not [simp]: "next_free (not \<phi>) = next_free \<phi>"
  by (simp add: not_def)

lemma next_free_true [simp]: "next_free true"
  by (simp add: true_def)

lemma next_free_or [simp]: "next_free (or \<phi> \<psi>) = (next_free \<phi> \<and> next_free \<psi>)"
  by (simp add: or_def)

lemma next_free_and [simp]: "next_free (and \<phi> \<psi>) = (next_free \<phi> \<and> next_free \<psi>)"
  by (simp add: and_def)

lemma next_free_eventually [simp]: "next_free (eventually \<phi>) = next_free \<phi>"
  by (simp add: eventually_def)

lemma next_free_always [simp]: "next_free (always \<phi>) = next_free \<phi>"
  by (simp add: always_def)

lemma next_free_OR [simp]:
  assumes fin: "finite (\<Phi>::'a pltl set)"
  shows "next_free (OR \<Phi>) = (\<forall>\<phi>\<in>\<Phi>. next_free \<phi>)"
proof -
  {
    fix \<psi>::"'a pltl"
    assume "fold_graph or false \<Phi> \<psi>"
    hence "next_free \<psi> = (\<forall>\<phi>\<in>\<Phi>. next_free \<phi>)"
      by (rule fold_graph.induct) auto
  }
  with fold_graph_OR[OF fin] show ?thesis by simp
qed

lemma next_free_AND [simp]:
  assumes fin: "finite (\<Phi>::'a pltl set)"
  shows "next_free (AND \<Phi>) = (\<forall>\<phi>\<in>\<Phi>. next_free \<phi>)"
proof -
  {
    fix \<psi>::"'a pltl"
    assume "fold_graph and true \<Phi> \<psi>"
    hence "next_free \<psi> = (\<forall>\<phi>\<in>\<Phi>. next_free \<phi>)"
      by (rule fold_graph.induct) auto
  }
  with fold_graph_AND[OF fin] show ?thesis by simp
qed

subsection {* Stuttering Invariance of PLTL Without ``Next'' *}

text {*
  A PLTL formula is \emph{stuttering invariant} if for any stuttering equivalent
  state sequences @{text "\<sigma> \<approx> \<tau>"}, the formula holds of @{text "\<sigma>"} iff it
  holds of @{text "\<tau>"}.
*}

definition stutter_invariant where
  "stutter_invariant \<phi> = (\<forall>\<sigma> \<tau>. \<sigma> \<approx> \<tau> \<longrightarrow> (\<sigma> \<Turnstile> \<phi>) = (\<tau> \<Turnstile> \<phi>))"

text {*
  Since stuttering equivalence is symmetric, it is enough to show an
  implication in the above definition instead of an equivalence.
*}

lemma stutter_invariantI [intro!]:
  assumes "\<And>\<sigma> \<tau>. \<lbrakk>\<sigma> \<approx> \<tau>; \<sigma> \<Turnstile> \<phi>\<rbrakk> \<Longrightarrow> \<tau> \<Turnstile> \<phi>"
  shows "stutter_invariant \<phi>"
proof -
  {
    fix \<sigma> \<tau>
    assume st: "\<sigma> \<approx> \<tau>" and f: "\<sigma> \<Turnstile> \<phi>"
    hence "\<tau> \<Turnstile> \<phi>" by (rule assms)
  }
moreover
  {
    fix \<sigma> \<tau>
    assume st: "\<sigma> \<approx> \<tau>" and f: "\<tau> \<Turnstile> \<phi>"
    from st have "\<tau> \<approx> \<sigma>" by (rule stutter_equiv_sym)
    from this f have "\<sigma> \<Turnstile> \<phi>" by (rule assms)
  }
ultimately show ?thesis by (auto simp: stutter_invariant_def)
qed

lemma stutter_invariantD [dest]:
  assumes "stutter_invariant \<phi>" and "\<sigma> \<approx> \<tau>"
  shows "(\<sigma> \<Turnstile> \<phi>) = (\<tau> \<Turnstile> \<phi>)"
  using assms by (auto simp: stutter_invariant_def)

text {*
  We first show that next-free PLTL formulas are indeed stuttering invariant.
  The proof proceeds by straightforward induction on the syntax of PLTL formulas.
*}
theorem next_free_stutter_invariant:
  "next_free \<phi> \<Longrightarrow> stutter_invariant (\<phi>::'a pltl)"
proof (induct "\<phi>")
    show "stutter_invariant false" by auto
next
  fix p :: "'a \<Rightarrow> bool"
  show "stutter_invariant (atom p)"
  proof
    fix \<sigma> \<tau>
    assume "\<sigma> \<approx> \<tau>" "\<sigma> \<Turnstile> atom p"
    thus "\<tau> \<Turnstile> atom p" by (simp add: stutter_equiv_0)
  qed
next
  fix \<phi> \<psi> :: "'a pltl"
  assume ih: "next_free \<phi> \<Longrightarrow> stutter_invariant \<phi>"
             "next_free \<psi> \<Longrightarrow> stutter_invariant \<psi>"
  assume "next_free (implies \<phi> \<psi>)"
  with ih show "stutter_invariant (implies \<phi> \<psi>)" by auto
next
  fix \<phi> :: "'a pltl"
  assume "next_free (next \<phi>)"  -- {* hence contradiction *}
  thus "stutter_invariant (next \<phi>)" by simp
next
  fix \<phi> \<psi> :: "'a pltl"
  assume ih: "next_free \<phi> \<Longrightarrow> stutter_invariant \<phi>"
             "next_free \<psi> \<Longrightarrow> stutter_invariant \<psi>"
  assume "next_free (until \<phi> \<psi>)"
  with ih have stinv: "stutter_invariant \<phi>" "stutter_invariant \<psi>" by auto
  show "stutter_invariant (until \<phi> \<psi>)"
  proof
    fix \<sigma> \<tau>
    assume st: "\<sigma> \<approx> \<tau>" and unt: "\<sigma> \<Turnstile> until \<phi> \<psi>"
    from unt obtain m
      where 1: "\<sigma>[m..] \<Turnstile> \<psi>" and 2: "\<forall>j<m. \<sigma>[j..] \<Turnstile> \<phi>" by auto
    from st obtain n
      where 3: "\<sigma>[m..] \<approx> \<tau>[n..]" and 4: "\<forall>i<n. \<exists>j<m. \<sigma>[j..] \<approx> \<tau>[i..]"
      by (rule stutter_equiv_suffixes_right)
    from 1 3 stinv have "\<tau>[n..] \<Turnstile> \<psi>" by auto
    moreover
    from 2 4 stinv have "\<forall>i<n. \<tau>[i..] \<Turnstile> \<phi>" by force
    ultimately show "\<tau> \<Turnstile> until \<phi> \<psi>" by auto
  qed
qed

subsection {* Atoms, Canonical State Sequences, and Characteristic Formulas *}

text {*
  We now address the converse implication: any stutter invariant PLTL
  formula @{text "\<phi>"} can be equivalently expressed by a next-free formula.
  The construction of that formula requires attention to the atomic
  formulas that appear in @{text "\<phi>"}. We will also prove that the
  next-free formula does not need any new atoms beyond those present
  in @{text "\<phi>"}.

  The following function collects the atoms (of type @{text "'a \<Rightarrow> bool"})
  of a PLTL formula.
*}

fun atoms where
  "atoms false = {}"
| "atoms (atom p) = {p}"
| "atoms (implies \<phi> \<psi>) = atoms \<phi> \<union> atoms \<psi>"
| "atoms (next \<phi>) = atoms \<phi>"
| "atoms (until \<phi> \<psi>) = atoms \<phi> \<union> atoms \<psi>"

lemma atoms_finite [iff]: "finite (atoms \<phi>)"
  by (induct \<phi>) auto

lemma atoms_not [simp]: "atoms (not \<phi>) = atoms \<phi>"
  by (simp add: not_def)

lemma atoms_true [simp]: "atoms true = {}"
  by (simp add: true_def)

lemma atoms_or [simp]: "atoms (or \<phi> \<psi>) = atoms \<phi> \<union> atoms \<psi>"
  by (simp add: or_def)

lemma atoms_and [simp]: "atoms (and \<phi> \<psi>) = atoms \<phi> \<union> atoms \<psi>"
  by (simp add: and_def)

lemma atoms_eventually [simp]: "atoms (eventually \<phi>) = atoms \<phi>"
  by (simp add: eventually_def)

lemma atoms_always [simp]: "atoms (always \<phi>) = atoms \<phi>"
  by (simp add: always_def)

lemma atoms_OR [simp]:
  assumes fin: "finite (\<Phi>::'a pltl set)"
  shows "atoms (OR \<Phi>) = (\<Union>\<phi>\<in>\<Phi>. atoms \<phi>)"
proof -
  {
    fix \<psi>::"'a pltl"
    assume "fold_graph or false \<Phi> \<psi>"
    hence "atoms \<psi> = (\<Union>\<phi>\<in>\<Phi>. atoms \<phi>)"
      by (rule fold_graph.induct) auto
  }
  with fold_graph_OR[OF fin] show ?thesis by simp
qed

lemma atoms_AND [simp]:
  assumes fin: "finite (\<Phi>::'a pltl set)"
  shows "atoms (AND \<Phi>) = (\<Union>\<phi>\<in>\<Phi>. atoms \<phi>)"
proof -
  {
    fix \<psi>::"'a pltl"
    assume "fold_graph and true \<Phi> \<psi>"
    hence "atoms \<psi> = (\<Union>\<phi>\<in>\<Phi>. atoms \<phi>)"
      by (rule fold_graph.induct) auto
  }
  with fold_graph_AND[OF fin] show ?thesis by simp
qed

text {*
  Given a set of atoms @{text A} as above, we say that two states
  are @{text A}-similar if they agree on all atoms in @{text A}.
  Two state sequences @{text "\<sigma>"} and @{text "\<tau>"} are @{text A}-similar
  if corresponding states are @{text A}-equal.
*}

definition state_sim :: "['a, ('a \<Rightarrow> bool) set, 'a] \<Rightarrow> bool"
  ("_ ~_~ _" [70,100,70] 50) where
  "s ~A~ t = (\<forall>p\<in>A. p s \<longleftrightarrow> p t)"

definition seq_sim :: "[nat \<Rightarrow> 'a, ('a \<Rightarrow> bool) set, nat \<Rightarrow> 'a] \<Rightarrow> bool"
  ("_ \<simeq>_\<simeq> _" [70,100,70] 50)  where
  "\<sigma> \<simeq>A\<simeq> \<tau> = (\<forall>n. (\<sigma> n) ~A~ (\<tau> n))"

text {*
  These relations are (indexed) equivalence relations. Moreover
  @{text "s ~A~ t"} implies @{text "s ~B~ t"} for @{text "B \<subseteq> A"},
  and similar for @{text "\<sigma> \<simeq>A\<simeq> \<tau>"} and @{text "\<sigma> \<simeq>B\<simeq> \<tau>"}.
*}

lemma state_sim_refl [simp]: "s ~A~ s"
  by (simp add: state_sim_def)

lemma state_sim_sym: "s ~A~ t \<Longrightarrow> t ~A~ s"
  by (auto simp: state_sim_def)

lemma state_sim_trans[trans]: "s ~A~ t \<Longrightarrow> t ~A~ u \<Longrightarrow> s ~A~ u"
  unfolding state_sim_def by blast

lemma state_sim_mono:
  assumes "s ~A~ t" and "B \<subseteq> A"
  shows "s ~B~ t"
  using assms unfolding state_sim_def by auto

lemma seq_sim_refl [simp]: "\<sigma> \<simeq>A\<simeq> \<sigma>"
  by (simp add: seq_sim_def)

lemma seq_sim_sym: "\<sigma> \<simeq>A\<simeq> \<tau> \<Longrightarrow> \<tau> \<simeq>A\<simeq> \<sigma>"
  by (auto simp: seq_sim_def state_sim_sym)

lemma seq_sim_trans[trans]: "\<rho> \<simeq>A\<simeq> \<sigma> \<Longrightarrow> \<sigma> \<simeq>A\<simeq> \<tau> \<Longrightarrow> \<rho> \<simeq>A\<simeq> \<tau>"
  unfolding seq_sim_def by (blast intro: state_sim_trans)

lemma seq_sim_mono:
  assumes "\<sigma> \<simeq>A\<simeq> \<tau>" and "B \<subseteq> A"
  shows "\<sigma> \<simeq>B\<simeq> \<tau>"
  using assms unfolding seq_sim_def by (blast intro: state_sim_mono)

text {*
  State sequences that are similar w.r.t. the atoms of a PLTL formula
  evaluate that formula to the same value.
*}

lemma pltl_seq_sim: "\<sigma> \<simeq>(atoms \<phi>)\<simeq> \<tau> \<Longrightarrow> (\<sigma> \<Turnstile> \<phi>) = (\<tau> \<Turnstile> \<phi>)"
  (is "?sim \<sigma> \<phi> \<tau> \<Longrightarrow> ?P \<sigma> \<phi> \<tau>")
proof (induct \<phi> arbitrary: \<sigma> \<tau>)
  fix \<sigma> \<tau>
  show "?P \<sigma> false \<tau>" by simp
next
  fix p \<sigma> \<tau>
  assume "?sim \<sigma> (atom p) \<tau>" thus "?P \<sigma> (atom p) \<tau>"
    by (auto simp: seq_sim_def state_sim_def)
next
  fix \<phi> \<psi> \<sigma> \<tau>
  assume ih: "\<And>\<sigma> \<tau>. ?sim \<sigma> \<phi> \<tau> \<Longrightarrow> ?P \<sigma> \<phi> \<tau>"
             "\<And>\<sigma> \<tau>. ?sim \<sigma> \<psi> \<tau> \<Longrightarrow> ?P \<sigma> \<psi> \<tau>"
     and sim: "?sim \<sigma> (implies \<phi> \<psi>) \<tau>"
  from sim have "?sim \<sigma> \<phi> \<tau>" "?sim \<sigma> \<psi> \<tau>"
    by (auto elim: seq_sim_mono)
  with ih show "?P \<sigma> (implies \<phi> \<psi>) \<tau>" by simp
next
  fix \<phi> \<sigma> \<tau>
  assume ih: "\<And>\<sigma> \<tau>. ?sim \<sigma> \<phi> \<tau> \<Longrightarrow> ?P \<sigma> \<phi> \<tau>"
     and sim: "\<sigma> \<simeq>atoms (next \<phi>)\<simeq> \<tau>"
  from sim have "\<sigma>[1..] \<simeq>atoms \<phi>\<simeq> \<tau>[1..]"
    by (auto simp: seq_sim_def)
  with ih show "?P \<sigma> (next \<phi>) \<tau>" by auto
next
  fix \<phi> \<psi> \<sigma> \<tau>
  assume ih: "\<And>\<sigma> \<tau>. ?sim \<sigma> \<phi> \<tau> \<Longrightarrow> ?P \<sigma> \<phi> \<tau>"
             "\<And>\<sigma> \<tau>. ?sim \<sigma> \<psi> \<tau> \<Longrightarrow> ?P \<sigma> \<psi> \<tau>"
     and sim: "?sim \<sigma> (until \<phi> \<psi>) \<tau>"
  from sim have "\<forall>i. \<sigma>[i..] \<simeq>atoms \<phi>\<simeq> \<tau>[i..]" "\<forall>j. \<sigma>[j..] \<simeq>atoms \<psi>\<simeq> \<tau>[j..]"
    by (auto simp: seq_sim_def state_sim_def)
  with ih have "\<forall>i. ?P (\<sigma>[i..]) \<phi> (\<tau>[i..])" "\<forall>j. ?P (\<sigma>[j..]) \<psi> (\<tau>[j..])"
    by (auto simp del: suffix_elt)
  thus "?P \<sigma> (until \<phi> \<psi>) \<tau>" by (auto simp del: suffix_elt)
qed

text {*
  The following function picks an arbitrary representative among
  @{text A}-similar states. Because the choice is functional,
  any two @{text A}-similar states are mapped to the same state.
*}

definition canonize where
  "canonize A s \<equiv> SOME t. t ~A~ s"

lemma canonize_state_sim: "canonize A s ~A~ s"
  unfolding canonize_def by (rule someI, rule state_sim_refl)

lemma canonize_canonical:
  assumes st: "s ~A~ t"
  shows "canonize A s = canonize A t"
proof -
  from st have "\<forall>u. (u ~A~s) = (u ~A~ t)"
    by (auto elim: state_sim_sym state_sim_trans)
  thus ?thesis unfolding canonize_def by simp
qed

lemma canonize_idempotent:
  "canonize A (canonize A s) = canonize A s"
  by (rule canonize_canonical[OF canonize_state_sim])

text {*
  In a canonical state sequence, any two @{text A}-similar states
  are in fact equal.
*}

definition canonical_sequence where
  "canonical_sequence A \<sigma> \<equiv> \<forall>m (n::nat). \<sigma> m ~A~ \<sigma> n \<longrightarrow> \<sigma> m = \<sigma> n"

text {*
  Every suffix of a canonical sequence is canonical, as is any
  (sampled) subsequence, in particular any stutter-sampling.
*}

lemma canonical_suffix:
  "canonical_sequence A \<sigma> \<Longrightarrow> canonical_sequence A (\<sigma>[k..])"
  by (auto simp: canonical_sequence_def)

lemma canonical_sampled:
  "canonical_sequence A \<sigma> \<Longrightarrow> canonical_sequence A (\<sigma> \<circ> f)"
  by (auto simp: canonical_sequence_def)

lemma canonical_reduced:
  "canonical_sequence A \<sigma> \<Longrightarrow> canonical_sequence A (\<natural>\<sigma>)"
  unfolding stutter_reduced_def by (rule canonical_sampled)

text {*
  For any sequence @{text "\<sigma>"} there exists a canonical
  @{text A}-similar sequence @{text "\<tau>"}. Such a @{text "\<tau>"}
  can be obtained by canonizing all states of @{text "\<sigma>"}.
*}

lemma canonical_exists:
  obtains \<tau> where "\<tau> \<simeq>A\<simeq> \<sigma>" "canonical_sequence A \<tau>"
proof -
  have "(canonize A \<circ> \<sigma>) \<simeq>A\<simeq> \<sigma>"
    by (simp add: seq_sim_def canonize_state_sim)
  moreover
  have "canonical_sequence A (canonize A \<circ> \<sigma>)"
    by (auto simp: canonical_sequence_def canonize_idempotent
             dest: canonize_canonical)
  ultimately
  show ?thesis using that by blast
qed

text {*
  Given a state @{text s} and a set @{text A} of atoms, we define
  the characteristic formula of @{text s} as the conjunction of
  all atoms in @{text A} that hold of @{text s} and the negation of
  the atoms in @{text A} that do not hold of @{text s}.
*}

definition characteristic_formula where
  "characteristic_formula A s \<equiv>
   (and (AND { atom p | p . p \<in> A \<and> p s })
        (AND { not (atom p) | p . p \<in> A \<and> \<not>(p s) }))"

lemma characteristic_holds:
  "finite A \<Longrightarrow> \<sigma> \<Turnstile> characteristic_formula A (\<sigma> 0)"
  by (auto simp: characteristic_formula_def)

lemma characteristic_state_sim:
  assumes fin: "finite A"
  shows "(\<sigma> 0 ~A~ \<tau> 0) = (\<tau> \<Turnstile> characteristic_formula A (\<sigma> (0::nat)))"
proof
  assume sim: "\<sigma> 0 ~A~ \<tau> 0"
  {
    fix p
    assume "p \<in> A"
    with sim have "p (\<tau> 0) = p (\<sigma> 0)" by (auto simp: state_sim_def)
  }
  with fin show "\<tau> \<Turnstile> characteristic_formula A (\<sigma> 0)"
    by (auto simp: characteristic_formula_def) (blast+)
next
  assume "\<tau> \<Turnstile> characteristic_formula A (\<sigma> 0)"
  with fin show "\<sigma> 0 ~A~ \<tau> 0"
    by (auto simp: characteristic_formula_def state_sim_def)
qed

subsection {* Stuttering Invariant PLTL Formulas Don't Need Next *}

text {*
  The following is the main lemma used in the proof of the
  completeness theorem: for any PLTL formula @{text "\<phi>"} there
  exists a next-free formula @{text "\<psi>"} such that the two
  formulas evaluate to the same value over stutter-free and
  canonical sequences (w.r.t. some @{text "A \<supseteq> atoms \<phi>"}).
*}

lemma ex_next_free_stutter_free_canonical:
  assumes A: "atoms \<phi> \<subseteq> A" and fin: "finite A"
  shows "\<exists>\<psi>. next_free \<psi> \<and> atoms \<psi> \<subseteq> A \<and>
             (\<forall>\<sigma>. stutter_free \<sigma> \<and> canonical_sequence A \<sigma> \<longrightarrow> (\<sigma> \<Turnstile> \<psi>) = (\<sigma> \<Turnstile> \<phi>))"
    (is "\<exists>\<psi>. ?P \<phi> \<psi>")
using A proof (induct \<phi>)
  txt {* The cases of @{text "false"} and atomic formulas are trivial. *}
  have "?P false false" by auto
  thus "\<exists>\<psi>. ?P false \<psi>" ..
next
  fix p
  assume "atoms (atom p) \<subseteq> A"
  hence "?P (atom p) (atom p)" by auto
  thus "\<exists>\<psi>. ?P (atom p) \<psi>" ..
next
  txt {* Implication is easy, using the induction hypothesis. *}
  fix \<phi> \<psi>
  assume "atoms \<phi> \<subseteq> A \<Longrightarrow> \<exists>\<phi>'. ?P \<phi> \<phi>'"
     and "atoms \<psi> \<subseteq> A \<Longrightarrow> \<exists>\<psi>'. ?P \<psi> \<psi>'"
     and "atoms (implies \<phi> \<psi>) \<subseteq> A"
  then obtain \<phi>' \<psi>' where "?P \<phi> \<phi>'" "?P \<psi> \<psi>'" by auto
  hence "?P (implies \<phi> \<psi>) (implies \<phi>' \<psi>')" by auto
  thus "\<exists>\<chi>. ?P (implies \<phi> \<psi>) \<chi>" ..
next
  txt {* The case of @{text "until"} follows similarly. *}
  fix \<phi> \<psi>
  assume "atoms \<phi> \<subseteq> A \<Longrightarrow> \<exists>\<phi>'. ?P \<phi> \<phi>'"
     and "atoms \<psi> \<subseteq> A \<Longrightarrow> \<exists>\<psi>'. ?P \<psi> \<psi>'"
     and "atoms (until \<phi> \<psi>) \<subseteq> A"
  then obtain \<phi>' \<psi>' where 1: "?P \<phi> \<phi>'" and 2: "?P \<psi> \<psi>'" by auto
  {
    fix \<sigma>
    assume sigma: "stutter_free \<sigma>" "canonical_sequence A \<sigma>"
    hence "\<And>k. stutter_free (\<sigma>[k..])" "\<And>k. canonical_sequence A (\<sigma>[k..])"
      by (auto simp: stutter_free_suffix canonical_suffix)
    with 1 2
    have "\<And>k. (\<sigma>[k..] \<Turnstile> \<phi>') = (\<sigma>[k..] \<Turnstile> \<phi>)"
     and "\<And>k. (\<sigma>[k..] \<Turnstile> \<psi>') = (\<sigma>[k..] \<Turnstile> \<psi>)"
      by (blast+)
    hence "(\<sigma> \<Turnstile> until \<phi>' \<psi>') = (\<sigma> \<Turnstile> until \<phi> \<psi>)"
      by auto
  }
  with 1 2 have "?P (until \<phi> \<psi>) (until \<phi>' \<psi>')" by auto
  thus "\<exists>\<chi>. ?P (until \<phi> \<psi>) \<chi>" ..
next
  txt {* The interesting case is the one of the @{text "next"}-operator. *}
  fix \<phi>
  assume ih: "atoms \<phi> \<subseteq> A \<Longrightarrow> \<exists>\<psi>. ?P \<phi> \<psi>" and at: "atoms (next \<phi>) \<subseteq> A"
  then obtain \<psi> where psi: "?P \<phi> \<psi>" by auto
  txt {* A valuation (over @{text A}) is a set @{text "val \<subseteq> A"} of atoms. We
    define some auxiliary notions: the valuation corresponding to a state and
    the characteristic formula for a valuation. Finally, we define the formula
    @{text "psi'"} that we will prove to be equivalent to @{text "next \<phi>"} over
    the stutter-free and canonical sequence @{text "\<sigma>"}. *}
  def stval \<equiv> "\<lambda>s. { p \<in> A . p s }"
  def chi \<equiv> "\<lambda>val. (and (AND {atom p | p . p \<in> val})
                        (AND {not (atom p) | p . p \<in> A - val}))"
  def psi' \<equiv> "(or (and \<psi> (OR { always (chi val) | val . val \<subseteq> A }))
                  (OR { and (chi val) (until (chi val) (and \<psi> (chi val'))) | val val'.
                        val \<subseteq> A \<and> val' \<subseteq> A \<and> val' \<noteq> val }))"
        (is "(or (and _ (OR ?ALW)) (OR ?UNT))")

  have "\<And>s. {not (atom p) | p . p \<in> A - stval s}
           = {not (atom p) | p . p \<in> A \<and> \<not>(p s)}"
    by (auto simp: stval_def)
  hence chi1: "\<And>s. chi (stval s) = characteristic_formula A s"
    by (auto simp: chi_def stval_def characteristic_formula_def)
  {
    fix val \<tau>
    assume val: "val \<subseteq> A" and tau: "\<tau> \<Turnstile> chi val"
    with fin have "val = stval (\<tau> 0)"
      by (auto simp: stval_def chi_def finite_subset)
  }
  note chi2 = this

  have "?UNT \<subseteq> (\<lambda>(val,val'). and (chi val) (until (chi val) (and \<psi> (chi val'))))
               ` (Pow A \<times> Pow A)"
    (is "_ \<subseteq> ?S")
    by auto
  with fin have fin_UNT: "finite ?UNT"
    by (auto simp: finite_subset)

  have nf: "next_free psi'"
  proof -
    from fin have "\<And>val. val \<subseteq> A \<Longrightarrow> next_free (chi val)"
      by (auto simp: chi_def finite_subset)
    with fin fin_UNT psi show ?thesis
      by (force simp: psi'_def finite_subset)
  qed

  have atoms: "atoms psi' \<subseteq> A"
  proof -
    from fin have at_chi: "\<And>val. val \<subseteq> A \<Longrightarrow> atoms (chi val) \<subseteq> A"
      by (auto simp: chi_def finite_subset)
    with fin psi have at_alw: "atoms (and \<psi> (OR ?ALW)) \<subseteq> A"
      by auto blast?    (** FRAGILE: auto leaves trivial goal about subset **)
    from fin fin_UNT psi at_chi have "atoms (OR ?UNT) \<subseteq> A"
      by auto (blast+)? (** FRAGILE: even more left-over goals here **)
    with at_alw show ?thesis by (auto simp: psi'_def)
  qed

  {
    fix \<sigma>
    assume st: "stutter_free \<sigma>" and can: "canonical_sequence A \<sigma>"
    have "(\<sigma> \<Turnstile> next \<phi>) = (\<sigma> \<Turnstile> psi')"
    proof (cases "\<sigma> (Suc 0) = \<sigma> 0")
      case True
      txt {* In the case of a stuttering transition at the beginning, we must have
        infinite stuttering, and the first disjunct of @{text "psi'"} holds,
        whereas the second does not. *}
      {
        fix n
        have "\<sigma> n = \<sigma> 0"
        proof (cases n)
          case 0 thus ?thesis by simp
        next
          case Suc
          hence "n > 0" by simp
          with True st show ?thesis unfolding stutter_free_def by blast
        qed
      }
      note alleq = this
      have suffix: "\<And>n. \<sigma>[n..] = \<sigma>"
      proof (rule ext)
        fix n i
        have "(\<sigma>[n..]) i = \<sigma> 0" by (auto intro: alleq)
        moreover have "\<sigma> i = \<sigma> 0" by (rule alleq)
        ultimately show "(\<sigma>[n..]) i = \<sigma> i" by simp
      qed
      with st can psi have 1: "(\<sigma> \<Turnstile> next \<phi>) = (\<sigma> \<Turnstile> \<psi>)" by simp

      from fin have "\<sigma> \<Turnstile> chi (stval (\<sigma> 0))" by (simp add: chi1 characteristic_holds)
      with suffix have "\<sigma> \<Turnstile> always (chi (stval (\<sigma> 0)))" (is "_ \<Turnstile> ?alw") by simp
      moreover have "?alw \<in> ?ALW" by (auto simp: stval_def)
      ultimately have 2: "\<sigma> \<Turnstile> OR ?ALW"
        using fin by (auto simp: finite_subset simp del: holds_of_always)

      have 3: "\<not>(\<sigma> \<Turnstile> OR ?UNT)"
      proof
        assume unt: "\<sigma> \<Turnstile> OR ?UNT"
        with fin_UNT obtain val val' k where
          val: "val \<subseteq> A" "val' \<subseteq> A" "val' \<noteq> val" and
          now: "\<sigma> \<Turnstile> chi val" and k: "\<sigma>[k..] \<Turnstile> chi val'"
          by auto (blast+)?  (* FRAGILE: similar as above *)
        from `val \<subseteq> A` now have "val = stval (\<sigma> 0)" by (rule chi2)
        moreover
        from `val' \<subseteq> A` k suffix have "val' = stval (\<sigma> 0)" by (simp add: chi2)
        moreover note `val' \<noteq> val`
        ultimately show "False" by simp
      qed

      from 1 2 3 show ?thesis by (simp add: psi'_def)

    next
      case False
      txt {* Otherwise, @{text "\<sigma> \<Turnstile> next \<phi>"} is equivalent to @{text "\<sigma>"} satisfying
        the second disjunct of @{text "psi'"}. We show both implications separately. *}
      let ?val = "stval (\<sigma> 0)"
      let ?val' = "stval (\<sigma> 1)"
      from False can have vals: "?val' \<noteq> ?val"
        by (auto simp: canonical_sequence_def state_sim_def stval_def)

      show ?thesis
      proof
        assume phi: "\<sigma> \<Turnstile> next \<phi>"
        from fin have 1: "\<sigma> \<Turnstile> chi ?val" by (simp add: chi1 characteristic_holds)

        from st can have "stutter_free (\<sigma>[1..])" "canonical_sequence A (\<sigma>[1..])"
          by (auto simp: stutter_free_suffix canonical_suffix)
        with phi psi have 2: "\<sigma>[1..] \<Turnstile> \<psi>" by auto

        from fin have "\<sigma>[1..] \<Turnstile> characteristic_formula A ((\<sigma>[1..]) 0)"
          by (rule characteristic_holds)
        hence 3: "\<sigma>[1..] \<Turnstile> chi ?val'" by (simp add: chi1)

        from 1 2 3 have "\<sigma> \<Turnstile> and (chi ?val) (until (chi ?val) (and \<psi> (chi ?val')))"
          (is "_ \<Turnstile> ?unt")
          by auto
        moreover from vals have "?unt \<in> ?UNT"
          by (auto simp: stval_def)
        ultimately have "\<sigma> \<Turnstile> OR ?UNT"
          using fin_UNT[THEN holds_of_OR] by blast
        thus "\<sigma> \<Turnstile> psi'" by (simp add: psi'_def)

      next
        assume psi': "\<sigma> \<Turnstile> psi'"
        have "\<not>(\<sigma> \<Turnstile> OR ?ALW)"
        proof
          assume "\<sigma> \<Turnstile> OR ?ALW"
          with fin obtain val where 1: "val \<subseteq> A" and 2: "\<forall>n. \<sigma>[n..] \<Turnstile> chi val"
            by (force simp: finite_subset)
          from 2 have "\<sigma>[0..] \<Turnstile> chi val" ..
          with 1 have "val = ?val" by (simp add: chi2)
          moreover
          from 2 have "\<sigma>[1..] \<Turnstile> chi val" ..
          with 1 have "val = ?val'" by (force dest: chi2)
          ultimately
          show "False" using vals by simp
        qed
        with psi' have "\<sigma> \<Turnstile> OR ?UNT" by (simp add: psi'_def)
        with fin_UNT obtain val val' k where
          val: "val \<subseteq> A" "val' \<subseteq> A" "val' \<noteq> val" and
          now: "\<sigma> \<Turnstile> chi val" and
          k: "\<sigma>[k..] \<Turnstile> \<psi>" "\<sigma>[k..] \<Turnstile> chi val'" and
          i: "\<forall>i<k. \<sigma>[i..] \<Turnstile> chi val"
          by auto (blast+)?  (* FRAGILE: similar as above *)

        from val now have 1: "val = ?val" by (simp add: chi2)

        have 2: "k \<noteq> 0"
        proof
          assume "k=0"
          with val k have "val' = ?val" by (simp add: chi2)
          with 1 `val' \<noteq> val` show "False" by simp
        qed

        have 3: "k \<le> 1"
        proof (rule ccontr)
          assume "\<not>(k \<le> 1)"
          with i have "\<sigma>[1..] \<Turnstile> chi val" by simp
          with 1 have "\<sigma>[1..] \<Turnstile> characteristic_formula A (\<sigma> 0)"
            by (simp add: chi1)
          hence "(\<sigma> 0) ~A~ ((\<sigma>[1..]) 0)"
            using characteristic_state_sim[OF fin] by blast
          with can have "\<sigma> 0 = \<sigma> 1"
            by (simp add: canonical_sequence_def)
          with `\<sigma> (Suc 0) \<noteq> \<sigma> 0` show "False" by simp
        qed

        from 2 3 have "k=1" by simp
        moreover
        from st can have "stutter_free (\<sigma>[1..])" "canonical_sequence A (\<sigma>[1..])"
          by (auto simp: stutter_free_suffix canonical_suffix)
        ultimately show "\<sigma> \<Turnstile> next \<phi>" using `\<sigma>[k..] \<Turnstile> \<psi>` psi by auto
      qed
    qed
  }
  with nf atoms show "\<exists>\<psi>'. ?P (next \<phi>) \<psi>'" by blast
qed

text {*
  Comparing the definition of the next-free formula in the case of
  formulas @{text "next \<phi>"} with the one that appears in~\cite{peled:ltl-x},
  there is a subtle difference. Peled and Wilke define the second disjunct as
  a disjunction of formulas
%
  \begin{center}\(
    @{text "until (chi val) (and \<psi> (chi val'))"}
  \)\end{center}
%
  for subsets @{text "val, val' \<subseteq> A"} whereas we conjoin the formula
  @{text "chi val"} to the ``until'' formula. This conjunct is indeed
  necessary in order to rule out the case of the ``until'' formula
  being true because of @{text "chi val'"} being true immediately.
  The subtle error in the definition of the formula was acknowledged
  by Peled and Wilke and apparently had not been noticed since the
  publication of~\cite{peled:ltl-x} in 1996 (which has been cited more
  than a hundred times according to Google Scholar). Although the error
  was corrected easily, the fact that authors, reviewers, and readers
  appear to have missed it for so long underscores the usefulness of
  formal proofs.

  We now show that any stuttering invariant PLTL formula
  can be expressed without the @{text "next"} operator.
*}

theorem stutter_invariant_next_free:
  assumes phi: "stutter_invariant \<phi>"
  obtains \<psi> where "next_free \<psi>" "atoms \<psi> \<subseteq> atoms \<phi>"
                  "\<forall>\<sigma>. (\<sigma> \<Turnstile> \<psi>) = (\<sigma> \<Turnstile> \<phi>)"
proof -
  have "atoms \<phi> \<subseteq> atoms \<phi>" "finite (atoms \<phi>)" by simp_all
  then obtain \<psi> where
    psi: "next_free \<psi>" "atoms \<psi> \<subseteq> atoms \<phi>" and
    equiv: "\<forall>\<sigma>. stutter_free \<sigma> \<and> canonical_sequence (atoms \<phi>) \<sigma> \<longrightarrow> (\<sigma> \<Turnstile> \<psi>) = (\<sigma> \<Turnstile> \<phi>)"
    by (blast dest: ex_next_free_stutter_free_canonical)
  from `next_free \<psi>` have sinv: "stutter_invariant \<psi>"
    by (rule next_free_stutter_invariant)
  {
    fix \<sigma>
    obtain \<tau> where 1: "\<tau> \<simeq> atoms \<phi> \<simeq> \<sigma>" and 2: "canonical_sequence (atoms \<phi>) \<tau>"
      by (rule canonical_exists)
    from 1 `atoms \<psi> \<subseteq> atoms \<phi>` have 3: "\<tau> \<simeq> atoms \<psi> \<simeq> \<sigma>"
      by (rule seq_sim_mono)

    from 1 have "(\<sigma> \<Turnstile> \<phi>) = (\<tau> \<Turnstile> \<phi>)" by (simp add: pltl_seq_sim)
    also from phi stutter_reduced_equivalent have "... = (\<natural>\<tau> \<Turnstile> \<phi>)" by auto
    also from 2[THEN canonical_reduced] equiv stutter_reduced_stutter_free
    have "... = (\<natural>\<tau> \<Turnstile> \<psi>)" by auto
    also from sinv stutter_reduced_equivalent have "... = (\<tau> \<Turnstile> \<psi>)" by auto
    also from 3 have "... = (\<sigma> \<Turnstile> \<psi>)" by (simp add: pltl_seq_sim)
    finally have "(\<sigma> \<Turnstile> \<psi>) = (\<sigma> \<Turnstile> \<phi>)" by (rule sym)
  }
  with psi that show ?thesis by blast
qed

text {*
  Combining theorems @{text "next_free_stutter_invariant"} and
  @{text "stutter_invariant_next_free"}, it follows that a PLTL
  formula is stuttering invariant iff it is equivalent to a next-free
  formula.
*}

theorem pltl_stutter_invariant:
  "stutter_invariant \<phi> \<longleftrightarrow>
   (\<exists>\<psi>. next_free \<psi> \<and> atoms \<psi> \<subseteq> atoms \<phi> \<and> (\<forall>\<sigma>. \<sigma> \<Turnstile> \<psi> \<longleftrightarrow> \<sigma> \<Turnstile> \<phi>))"
proof -
  {
    assume "stutter_invariant \<phi>"
    hence "\<exists>\<psi>. next_free \<psi> \<and> atoms \<psi> \<subseteq> atoms \<phi> \<and> (\<forall>\<sigma>. \<sigma> \<Turnstile> \<psi> \<longleftrightarrow> \<sigma> \<Turnstile> \<phi>)"
      by (rule stutter_invariant_next_free) blast
  }
moreover
  {
    fix \<psi>
    assume 1: "next_free \<psi>" and 2: "\<forall>\<sigma>. \<sigma> \<Turnstile> \<psi> \<longleftrightarrow> \<sigma> \<Turnstile> \<phi>"
    from 1 have "stutter_invariant \<psi>" by (rule next_free_stutter_invariant)
    with 2 have "stutter_invariant \<phi>" by blast
  }
ultimately show ?thesis by blast
qed

end


(*
Author: Alexander Katovsky
*)

section "Universe"

theory Universe
imports "HOL-ZF.MainZF"
begin

locale Universe =
  fixes U :: ZF (structure)
  assumes Uempty  : "Elem Empty U"
  and     Usubset : "Elem u U \<Longrightarrow> subset u U"
  and     Usingle : "Elem u U \<Longrightarrow> Elem (Singleton u) U"
  and     Upow    : "Elem u U \<Longrightarrow> Elem (Power u) U"
  and     Uim     : "\<lbrakk>Elem I U ; Elem u (Fun I U) \<rbrakk> \<Longrightarrow> Elem (Sum (Range u)) U"
  and     Unat    : "Elem Nat U"
(*
axiomatization where
  Grothendieck: "\<forall> x . \<exists> uni . (Universe uni) \<and> Elem x uni"
*)
lemma ElemLambdaFun : "(\<And> x .Elem x u \<Longrightarrow> Elem (f x) U) \<Longrightarrow> Elem (Lambda u f) (Fun u U)"
apply (subst Elem_Lambda_Fun)
apply simp
done

lemma RangeRepl: "Range (Lambda A f) = Repl A f"
apply (subst Ext)
apply (subst Range)
apply (simp add: Repl Opair Lambda_def)
done

lemma (in Universe) Utrans: "\<lbrakk>Elem a U ; Elem b a\<rbrakk> \<Longrightarrow> Elem b U"
apply (drule Usubset)
apply (insert HOLZF.subset_def [of a U])
apply (auto simp add: Usubset)
done

lemma ReplId: "Repl A id = A"
by (subst Ext, simp add: Repl)

lemma (in Universe) UniverseSum : "Elem u U \<Longrightarrow> Elem (Sum u) U"
apply (frule_tac u = "Lambda u id" in Uim)
apply (subst Elem_Lambda_Fun)
apply (frule Usubset)
apply (simp add: subset_def)
apply (simp only: RangeRepl ReplId)
done

lemma (in Universe) UniverseUnion:
  assumes "Elem u U" and "Elem v U"
  shows "Elem (union u v) U"
proof-
  let ?f = "(% x. if x = Empty then u else v)"
    and ?S = "(Power (Power Empty))"
  have 1: "(Upair u v) = Range (Lambda ?S ?f)"
    by (subst RangeRepl, simp add: Upair_def)
  have 2: "\<lbrakk>Elem u U; Elem v U\<rbrakk> \<Longrightarrow> Elem (Lambda ?S ?f) (Fun ?S U)"
    by (rule ElemLambdaFun, simp)
  show ?thesis using assms
    apply (subst HOLZF.union_def)
    apply (subst 1)
    apply (rule_tac I="?S" in Uim)
    apply (rule Upow)+
    apply (rule Uempty)
    apply (rule 2)
    apply simp+
    done
qed

lemma UPairSingleton: "Upair u v = union (Singleton u) (Singleton v)"
apply (subst Ext)
apply (subst Upair)
apply (subst union)
apply (subst Singleton)+
apply (simp)
done

lemma (in Universe) UniverseUPair: "\<lbrakk>Elem u U ; Elem v U\<rbrakk> \<Longrightarrow> Elem (Upair u v) U"
apply (subst UPairSingleton)
apply (rule UniverseUnion)
apply (rule Usingle, simp)+
done

lemma (in Universe) UniversePair: "\<lbrakk>Elem u U ; Elem v U\<rbrakk> \<Longrightarrow> Elem (Opair u v) U"
apply (subst Opair_def)
apply ((rule UniverseUPair)+, simp+)+
done

lemma (in Universe) "\<lbrakk>Elem u U ; Elem v U\<rbrakk> \<Longrightarrow> Elem (Sum (Repl u (%x . Singleton (Opair x v)))) U"
apply (rule RangeRepl [THEN subst])
apply (rule Uim [of u], simp)
apply (rule ElemLambdaFun)
apply (rule Usingle)
apply (rule UniversePair)
apply (rule Utrans)
apply simp+
done

lemma SumRepl: "Sum (Repl A (Singleton o f)) = Repl A f"
proof-
  show ?thesis
    apply (subst Ext)
    apply (subst Sum)
    apply (subst Repl)+
    apply (auto simp add: Singleton)
    proof-
      fix a
      show "Elem a A \<Longrightarrow> \<exists>y. Elem (f a) y \<and> (\<exists>a. Elem a A \<and> y = Singleton (f a))"
        apply (rule exI [of _ "Singleton (f a)"])
        apply (subst Singleton, simp+)
        apply (rule exI [of _ "a"], simp+)
        done
      qed
    qed

lemma (in Universe) UniverseProd:
  assumes "Elem u U" and "Elem v U"
  shows   "Elem (CartProd u v) U"
proof-
  show ?thesis using assms
    apply (subst CartProd_def)
    apply (rule RangeRepl [of u "% x . (Repl v (Opair x))", THEN subst])
    apply (rule Uim [of u], simp)
    apply (rule ElemLambdaFun)
    proof-
      fix x
      show "\<lbrakk>Elem u U; Elem v U; Elem x u\<rbrakk> \<Longrightarrow> Elem (Repl v (Opair x)) U"
        apply (drule Utrans [of u x], simp)
        apply (rule SumRepl [THEN subst])
        apply (rule RangeRepl [THEN subst])
        apply (rule Uim [of v], simp)
        apply (rule ElemLambdaFun,simp)
        apply (rule Usingle)
        apply (rule UniversePair)
        apply (drule Usubset, simp)
        proof-
          fix xa
          show "\<lbrakk>Elem v U; Elem x u; Elem x U; Elem xa v\<rbrakk> \<Longrightarrow> Elem xa U"
            by (rule Utrans, simp+)
        qed
      qed
    qed

lemma (in Universe) UniverseSubset: "\<lbrakk>subset u v ; Elem v U\<rbrakk> \<Longrightarrow> Elem u U"
  apply (drule_tac HOLZF.Power [of u v, THEN ssubst])
  apply (drule Upow)
  apply (rule Utrans, simp+)
  done

definition
  Product :: "ZF \<Rightarrow> ZF" where
  "Product U = Sep (Fun U (Sum U)) (%f . (\<forall> u . Elem u U \<longrightarrow> Elem (app f u) u))"

lemma SepSubset: "subset (Sep A p) A"
apply (subst subset_def)
apply (subst Sep, simp)
done

lemma SubsetSmall:
  assumes "subset A' A" and "subset A B" shows "subset A' B"
  proof-
    have "(subset A' A \<and> subset A B) \<longrightarrow> subset A' B"
      by ((subst subset_def)+, simp+)
    thus ?thesis using assms by simp
  qed

lemma SubsetTrans:
  assumes "(subset a b)" and "(subset b c)"
  shows "(subset a c)"
proof-
  have "(subset a b) \<and> (subset b c) \<longrightarrow> (subset a c)"
    by ((subst subset_def)+, simp)
  thus ?thesis using assms by simp
qed

lemma SubsetSepTrans: "subset A B \<Longrightarrow> subset (Sep A p) B"
apply (rule SubsetSmall [of "Sep A p" A B])
apply (rule SepSubset)
by simp

lemma ProductSubset: "subset (Product u) (Power (CartProd u (Sum u)))"
apply (subst Product_def)
apply (subst Fun_def)
apply (subst PFun_def)
apply (rule SubsetSepTrans)+
apply (subst subset_def)
by simp

lemma (in Universe) UniverseProduct: "Elem u U \<Longrightarrow> Elem (Product u) U"
apply (rule_tac u="(Product u)" and v="Power (CartProd u (Sum u))" in UniverseSubset)
apply (rule ProductSubset)
apply (rule Upow)
apply (rule UniverseProd, simp)
apply (rule UniverseSum,simp)
done

lemma ZFImageRangeExplode: "x \<in> range explode \<Longrightarrow> f ` x \<in> range explode"
proof-
  assume "x \<in> range explode"
  from this obtain y where "x = explode y" using range_ex1_eq by auto
  hence "f ` x = explode (Repl y f)" using explode_Repl_eq by simp
  thus "f ` x \<in> range explode" by auto
qed

definition "subsetFn X Y \<equiv> \<lambda> x . (if x \<in> Y then x else SOME y . y \<in> Y)"

lemma subsetFn: "\<lbrakk>Y \<noteq> {} ; Y \<subseteq> X \<rbrakk> \<Longrightarrow> (subsetFn X Y) ` X = Y"
proof(auto simp add: subsetFn_def)
  fix x assume "x \<in> Y"
  thus "(SOME y. y \<in> Y) \<in> Y" using someI_ex[of "\<lambda> x . x \<in> Y"] by auto
qed

lemma ZFSubsetRangeExplode: "\<lbrakk>X \<in> range explode ; Y \<subseteq> X\<rbrakk> \<Longrightarrow> Y \<in> range explode"
proof(cases "Y = {}", simp)
  have "explode Empty = {}" using explode_Empty by simp
  thus "{} \<in> range explode" by (auto simp add: explode_def)
  assume "Y \<noteq> {}" and "Y \<subseteq> X" and "X \<in> range explode" thus "Y \<in> range explode"
    using ZFImageRangeExplode[of X "subsetFn X Y"] subsetFn[of Y X] by simp
qed

lemma ZFUnionRangeExplode:
  assumes "\<And> x . x \<in> A \<Longrightarrow> f x \<in> range explode" and "A \<in> range explode"
  shows "(\<Union> x \<in> A . f x) \<in> range explode"
proof-
  let ?S = "Sep (Sum (Repl (implode A) (implode o f))) (\<lambda> y . \<exists> x  . (Elem x (implode A)) \<and> (Elem y (implode (f x))))"
  have "explode ?S = (\<Union> x \<in> A . f x)"
  proof (auto simp add: UNION_eq explode_def Sep Sum Repl assms Elem_implode cong del: image_cong_simp)
    fix x y assume a: "y \<in> A" and b: "x \<in> f y"
    show "\<exists>z. Elem x z \<and> (\<exists>a. a \<in> A \<and> z = implode (f a))"
      apply (rule exI [where ?x = "implode (f y)"])
      apply (auto simp add: explode_def Sep Sum Repl assms Elem_implode a b cong del: image_cong_simp)
      apply (rule exI [where ?x = y])
      apply (simp add: a)
      done
  qed
  thus ?thesis by auto
qed

lemma ZFUnionNatInRangeExplode: "(\<And> (n :: nat) . f n \<in> range explode) \<Longrightarrow> (\<Union> n . f n) \<in> range explode"
proof-
  assume a: "(\<And> (n :: nat) . f n \<in> range explode)"
  have "explode Nat \<in> range explode" by simp
  moreover have "\<And> n . n \<in> (explode Nat) \<Longrightarrow> (f o Nat2nat) n \<in> range explode" using a
    by(auto simp add: explode_def)
  moreover have "(\<Union> n . f n) = (\<Union> n \<in> (explode Nat) . (f o Nat2nat) n)"
  proof(auto simp add: Nat2nat_def)
    fix x n assume aa: "x \<in> f n" show "\<exists> n \<in> (explode Nat) . x \<in> f (inv nat2Nat n)"
      apply(rule bexI[where ?x = "nat2Nat n"])
      by(auto simp add: aa inj_nat2Nat explode_Elem)
  qed
  ultimately show "(\<Union> n . f n) \<in> range explode" using ZFUnionRangeExplode by simp
qed

lemma ZFProdFnInRangeExplode: "\<lbrakk>A \<in> range explode ; B \<in> range explode\<rbrakk> \<Longrightarrow> f ` (A \<times> B) \<in> range explode"
proof-
  assume a: "A \<in> range explode" and b: "B \<in> range explode"
  let ?X = "(explode (CartProd (implode A) (implode B)))"
  have "f ` (A \<times> B) = (f  o (\<lambda> z . (Fst z, Snd z))) ` ?X"
  proof(auto simp add: explode_def CartProd image_def Fst Snd)
    {
      fix z y assume z: "z \<in> A" and y: "y \<in> B" show "\<exists>x. (\<exists>a. Elem a (implode A) \<and>
        (\<exists>b. Elem b (implode B) \<and> x = Opair a b)) \<and> f (z, y) = f (Fst x, Snd x)"
        apply(insert z y a b)
        apply(rule exI[where ?x = "Opair z y"])
        apply(auto simp add: Opair explode_Elem Fst Snd)
        done
    }
    {
      fix a b assume aa: "Elem a (implode A)" and bb: "Elem b (implode B)"
      show "\<exists> x \<in> A . \<exists> y \<in> B . f (a,b) = f (x,y)"
        by(rule bexI[where ?x = a], rule bexI[where ?x = b], simp, insert a b aa bb, auto simp add: explode_Elem)
    }
  qed
  moreover have "?X \<in> range explode" by simp
  ultimately show "f ` (A \<times> B) \<in> range explode" using ZFImageRangeExplode by simp
qed

lemma ZFUnionInRangeExplode: "\<lbrakk>A \<in> range explode ; B \<in> range explode\<rbrakk> \<Longrightarrow> A \<union> B \<in> range explode"
proof-
  assume "A \<in> range explode" and "B \<in> range explode"
  from this obtain A' B' where A': "A = explode A'" and B': "B = explode B'" by auto
  have "A \<union> B = explode (union (implode A) (implode B))"
    by(auto simp add: explode_union  union explode_Elem A' B')
  thus "A \<union> B \<in> range explode" by auto
qed

lemma SingletonInRangeExplode: "{x} \<in> range explode"
proof-
  have "explode (Singleton x) = {x}" by(auto simp add: explode_def Singleton)
  thus ?thesis by auto
qed

definition ZFTriple :: "[ZF,ZF,ZF] \<Rightarrow> ZF" where
  "ZFTriple a b c = Opair (Opair a b) c"
definition "ZFTFst = Fst o Fst"
definition "ZFTSnd = Snd o Fst"
definition "ZFTThd = Snd"

lemma ZFTFst: "ZFTFst (ZFTriple a b c) = a"
  by(auto simp add: ZFTriple_def ZFTFst_def Fst)
lemma ZFTSnd: "ZFTSnd (ZFTriple a b c) = b"
  by(auto simp add: ZFTriple_def ZFTSnd_def Snd Fst)
lemma ZFTThd: "ZFTThd (ZFTriple a b c) = c"
  by(auto simp add: ZFTriple_def ZFTThd_def Snd Fst)

lemma ZFTriple: "ZFTriple a b c = ZFTriple a' b' c' \<Longrightarrow> (a = a' \<and> b = b' \<and> c = c')"
by(auto simp add: ZFTriple_def Opair)

lemma ZFSucZero: "Nat2nat (SucNat Empty) = 1"
proof-
  have "nat2Nat 0 = Empty" by auto
  hence "(SucNat Empty) = nat2Nat (Suc 0)" by auto
  hence "Nat2nat (SucNat Empty) = Nat2nat (nat2Nat (Suc 0))" by simp
  also have "... = Suc 0" using Nat2nat_nat2Nat[of "Suc 0"] by simp
  finally show ?thesis by simp
qed

lemma ZFZero: "Nat2nat Empty = 0"
proof-
  have "nat2Nat 0 = Empty" by auto
  hence "Nat2nat Empty = Nat2nat (nat2Nat 0)" by simp
  thus ?thesis using Nat2nat_nat2Nat[of "0"] by simp
qed

lemma ZFSucNeq0: "Elem x Nat \<Longrightarrow> Nat2nat (SucNat x) \<noteq> 0"
by(auto simp add: Nat2nat_SucNat)

end