section \<open>\<open>Extra_Operator_Norm\<close> -- Additional facts bout the operator norm\<close>

theory Extra_Operator_Norm
  imports "HOL-Analysis.Operator_Norm"
    Extra_General
    "HOL-Analysis.Bounded_Linear_Function"
begin

text \<open>This theorem complements \<^theory>\<open>HOL-Analysis.Operator_Norm\<close>
      additional useful facts about operator norms.\<close>

lemma ex_norm1:
  assumes \<open>(UNIV::'a::real_normed_vector set) \<noteq> {0}\<close>
  shows \<open>\<exists>x::'a. norm x = 1\<close>
proof-
  have \<open>\<exists>x::'a. x \<noteq> 0\<close>
    using assms by fastforce
  then obtain x::'a where \<open>x \<noteq> 0\<close>
    by blast
  hence \<open>norm x \<noteq> 0\<close>
    by simp
  hence \<open>(norm x) / (norm x) = 1\<close>
    by simp
  moreover have \<open>(norm x) / (norm x) = norm (x /\<^sub>R (norm x))\<close>
    by simp
  ultimately have \<open>norm (x /\<^sub>R (norm x)) = 1\<close>
    by simp
  thus ?thesis
    by blast
qed

lemma bdd_above_norm_f:
  assumes "bounded_linear f"
  shows \<open>bdd_above {norm (f x) |x. norm x = 1}\<close>
proof-
  have \<open>\<exists>M. \<forall>x. norm x = 1 \<longrightarrow> norm (f x) \<le> M\<close>
    using assms
    by (metis bounded_linear.axioms(2) bounded_linear_axioms_def)
  thus ?thesis by auto
qed

lemma onorm_sphere:
  fixes f :: "'a::{real_normed_vector, not_singleton} \<Rightarrow> 'b::real_normed_vector"
  assumes a1: "bounded_linear f"
  shows \<open>onorm f = Sup {norm (f x) | x. norm x = 1}\<close>
proof(cases \<open>f = (\<lambda> _. 0)\<close>)
  case True
  have \<open>(UNIV::'a set) \<noteq> {0}\<close>
    by simp
  hence \<open>\<exists>x::'a. norm x = 1\<close>
    using  ex_norm1
    by blast
  have \<open>norm (f x) = 0\<close>
    for x
    by (simp add: True)
  hence \<open>{norm (f x) | x. norm x = 1} = {0}\<close>
    using \<open>\<exists>x. norm x = 1\<close> by auto
  hence v1: \<open>Sup {norm (f x) | x. norm x = 1} = 0\<close>
    by simp
  have \<open>onorm f = 0\<close>
    by (simp add: True onorm_eq_0)
  thus ?thesis using v1 by simp
next
  case False
  have \<open>y \<in> {norm (f x) |x. norm x = 1} \<union> {0}\<close>
    if "y \<in> {norm (f x) / norm x |x. True}"
    for y
  proof(cases \<open>y = 0\<close>)
    case True
    thus ?thesis
      by simp
  next
    case False
    have \<open>\<exists> x. y = norm (f x) / norm x\<close>
      using \<open>y \<in> {norm (f x) / norm x |x. True}\<close> by auto
    then obtain x where \<open>y = norm (f x) / norm x\<close>
      by blast
    hence \<open>y = \<bar>(1/norm x)\<bar> * norm ( f x )\<close>
      by simp
    hence \<open>y = norm ( (1/norm x) *\<^sub>R f x )\<close>
      by simp
    hence \<open>y = norm ( f ((1/norm x) *\<^sub>R x) )\<close>
      apply (subst linear_cmul[of f])
      by (simp_all add: assms bounded_linear.linear)
    moreover have \<open>norm ((1/norm x) *\<^sub>R x) = 1\<close>
      using False \<open>y = norm (f x) / norm x\<close> by auto
    ultimately have \<open>y \<in> {norm (f x) |x. norm x = 1}\<close>
      by blast
    thus ?thesis by blast
  qed
  moreover have "y \<in> {norm (f x) / norm x |x. True}"
    if \<open>y \<in> {norm (f x) |x. norm x = 1} \<union> {0}\<close>
    for y
  proof(cases \<open>y = 0\<close>)
    case True
    thus ?thesis
      by auto
  next
    case False
    hence \<open>y \<notin> {0}\<close>
      by simp
    hence \<open>y \<in> {norm (f x) |x. norm x = 1}\<close>
      using that by auto
    hence \<open>\<exists> x. norm x = 1 \<and> y = norm (f x)\<close>
      by auto
    then obtain x where \<open>norm x = 1\<close> and \<open>y = norm (f x)\<close>
      by auto
    have \<open>y = norm (f x) / norm x\<close> using  \<open>norm x = 1\<close>  \<open>y = norm (f x)\<close>
      by simp
    thus ?thesis
      by auto
  qed
  ultimately have \<open>{norm (f x) / norm x |x. True} = {norm (f x) |x. norm x = 1} \<union> {0}\<close>
    by blast
  hence \<open>Sup {norm (f x) / norm x |x. True} = Sup ({norm (f x) |x. norm x = 1} \<union> {0})\<close>
    by simp
  moreover have \<open>Sup {norm (f x) |x. norm x = 1} \<ge> 0\<close>
  proof-
    have \<open>\<exists> x::'a. norm x = 1\<close>
      by (metis (full_types) False assms linear_simps(3) norm_sgn)
    then obtain x::'a where \<open>norm x = 1\<close>
      by blast
    have \<open>norm (f x) \<ge> 0\<close>
      by simp
    hence \<open>\<exists> x::'a. norm x = 1 \<and> norm (f x) \<ge> 0\<close>
      using \<open>norm x = 1\<close> by blast
    hence \<open>\<exists> y \<in> {norm (f x) |x. norm x = 1}. y \<ge> 0\<close>
      by blast
    then obtain y::real where \<open>y \<in> {norm (f x) |x. norm x = 1}\<close>
      and \<open>y \<ge> 0\<close>
      by auto
    have \<open>{norm (f x) |x. norm x = 1} \<noteq> {}\<close>
      using \<open>y \<in> {norm (f x) |x. norm x = 1}\<close> by blast
    moreover have \<open>bdd_above {norm (f x) |x. norm x = 1}\<close>
      using bdd_above_norm_f
      by (metis (mono_tags, lifting) a1)
    ultimately have \<open>y \<le> Sup {norm (f x) |x. norm x = 1}\<close>
      using \<open>y \<in> {norm (f x) |x. norm x = 1}\<close>
      by (simp add: cSup_upper)
    thus ?thesis using \<open>y \<ge> 0\<close> by simp
  qed
  moreover have \<open>Sup ({norm (f x) |x. norm x = 1} \<union> {0}) = Sup {norm (f x) |x. norm x = 1}\<close>
  proof-
    have \<open>{norm (f x) |x. norm x = 1} \<noteq> {}\<close>
      by (simp add: assms(1) ex_norm1)
    moreover have \<open>bdd_above {norm (f x) |x. norm x = 1}\<close>
      using a1 bdd_above_norm_f by force
    have \<open>{0::real} \<noteq> {}\<close>
      by simp
    moreover have \<open>bdd_above {0::real}\<close>
      by simp
    ultimately have \<open>Sup ({norm (f x) |x. norm x = 1} \<union> {(0::real)})
             = max (Sup {norm (f x) |x. norm x = 1}) (Sup {0::real})\<close>
      by (metis (lifting) \<open>0 \<le> Sup {norm (f x) |x. norm x = 1}\<close> \<open>bdd_above {0}\<close> \<open>bdd_above {norm (f x) |x. norm x = 1}\<close> \<open>{0} \<noteq> {}\<close> \<open>{norm (f x) |x. norm x = 1} \<noteq> {}\<close> cSup_singleton cSup_union_distrib max.absorb_iff1 sup.absorb_iff1)
    moreover have \<open>Sup {(0::real)} = (0::real)\<close>
      by simp
    moreover have \<open>Sup {norm (f x) |x. norm x = 1} \<ge> 0\<close>
      by (simp add: \<open>0 \<le> Sup {norm (f x) |x. norm x = 1}\<close>)
    ultimately show ?thesis
      by simp
  qed
  moreover have \<open>Sup ( {norm (f x) |x. norm x = 1} \<union> {0})
           = max (Sup {norm (f x) |x. norm x = 1}) (Sup {0}) \<close>
    using calculation(2) calculation(3) by auto
  ultimately have w1: "Sup {norm (f x) / norm x | x. True} = Sup {norm (f x) | x. norm x = 1}"
    by simp

  have \<open>(SUP x. norm (f x) / (norm x)) = Sup {norm (f x) / norm x | x. True}\<close>
    by (simp add: full_SetCompr_eq)
  also have \<open>... = Sup {norm (f x) | x. norm x = 1}\<close>
    using w1 by auto
  ultimately  have \<open>(SUP x. norm (f x) / (norm x)) = Sup {norm (f x) | x. norm x = 1}\<close>
    by linarith
  thus ?thesis unfolding onorm_def by blast
qed

lemma onorm_Inf_bound:
  fixes f :: \<open>'a::{real_normed_vector,not_singleton} \<Rightarrow> 'b::real_normed_vector\<close>
  assumes a1: "bounded_linear f"
  shows "onorm f = Inf {K. (\<forall>x\<noteq>0. norm (f x) \<le> norm x * K)}"
proof-
  have a2: \<open>(UNIV::'a set) \<noteq> {0}\<close>
    by simp

  define A where \<open>A = {norm (f x) / (norm x) | x. x \<noteq> 0}\<close>
  have \<open>A \<noteq> {}\<close>
  proof-
    have \<open>\<exists> x::'a. x \<noteq> 0\<close>
      using a2 by auto
    thus ?thesis using A_def
      by simp
  qed
  moreover have \<open>bdd_above A\<close>
  proof-
    have \<open>\<exists> M. \<forall> x.  norm (f x) / (norm x) \<le> M\<close>
      using \<open>bounded_linear f\<close> le_onorm by auto
    thus ?thesis using A_def
      by auto
  qed
  ultimately have \<open>Sup A = Inf {b. \<forall>a\<in>A. a \<le> b}\<close>
    by (simp add: cSup_cInf)
  moreover have \<open>{b. \<forall>a\<in>A. a \<le> b} = {K. (\<forall>x\<noteq>0. norm (f x)/ norm x \<le>  K)}\<close>
  proof-
    have \<open>{b. \<forall>a\<in>A. a \<le> b} = {b. \<forall>a\<in>{norm (f x) / (norm x) | x. x \<noteq> 0}. a \<le> b}\<close>
      using A_def by blast
    also have \<open>... = {b. \<forall>x\<in>{x | x. x \<noteq> 0}. norm (f x) / (norm x) \<le> b}\<close>
      by auto
    also have \<open>... = {b. \<forall>x\<noteq>0. norm (f x) / (norm x) \<le> b}\<close>
      by auto
    finally show ?thesis by blast
  qed
  ultimately have \<open>Sup {norm (f x) / (norm x) | x. x \<noteq> 0}
                    = Inf {K. (\<forall>x\<noteq>0. norm (f x)/ norm x \<le>  K)}\<close>
    using A_def
    by simp
  moreover have \<open>(\<forall>x\<noteq>0. norm (f x) \<le> norm x * K) \<longleftrightarrow> (\<forall>x\<noteq>0. norm (f x)/ norm x \<le> K)\<close>
    for K
  proof
    show "\<forall>x\<noteq>0. norm (f x) / norm x \<le> K"
      if "\<forall>x\<noteq>0. norm (f x) \<le> norm x * K"
      using divide_le_eq nonzero_mult_div_cancel_left norm_le_zero_iff that
      by (simp add: divide_le_eq mult.commute)

    show "\<forall>x\<noteq>0. norm (f x) \<le> norm x * K"
      if "\<forall>x\<noteq>0. norm (f x) / norm x \<le> K"
      using divide_le_eq nonzero_mult_div_cancel_left norm_le_zero_iff that
      by (simp add: divide_le_eq mult.commute)
  qed
  ultimately have f1: \<open>Sup {norm (f x) / (norm x) | x. x \<noteq> 0} = Inf {K. (\<forall>x\<noteq>0. norm (f x) \<le> norm x * K)}\<close>
    by simp
  moreover
  have t1: \<open>{norm (f x) / (norm x) | x. x \<noteq> 0} \<union> {norm (f x) / (norm x) | x. x = 0}  = {norm (f x) / (norm x) | x. True}\<close>
    using Collect_cong by blast

  have \<open>{norm (f x) / (norm x) | x. x \<noteq> 0} \<noteq> {}\<close>
  proof-
    have \<open>\<exists> x::'a. x \<noteq> 0\<close>
      using \<open>UNIV\<noteq>{0}\<close> by auto
    thus ?thesis
      by simp
  qed
  moreover have \<open>bdd_above {norm (f x) / (norm x) | x. x \<noteq> 0}\<close>
  proof-
    have \<open>\<exists> M. \<forall> x.  norm (f x) / (norm x) \<le> M\<close>
      using \<open>bounded_linear f\<close> bounded_linear.nonneg_bounded
        mult_divide_mult_cancel_left_if norm_zero real_divide_square_eq
      using le_onorm by blast
    thus ?thesis
      by auto
  qed
  moreover have \<open>{norm (f x) / (norm x) | x. x = 0} \<noteq> {}\<close>
    by simp
  moreover have \<open>bdd_above {norm (f x) / (norm x) | x. x = 0}\<close>
    by simp
  ultimately
  have d1: \<open>Sup ({norm (f x) / (norm x) | x. x \<noteq> 0} \<union> {norm (f x) / (norm x) | x. x = 0})
        = max (Sup {norm (f x) / (norm x) | x. x \<noteq> 0}) (Sup {norm (f x) / (norm x) | x. x = 0})\<close>
    by (metis (no_types, lifting) cSup_union_distrib sup_max)
  have g1: \<open>Sup {norm (f x) / (norm x) | x. x \<noteq> 0} \<ge> 0\<close>
  proof-
    have t2: \<open>{norm (f x) / (norm x) | x. x \<noteq> 0} \<noteq> {}\<close>
    proof-
      have \<open>\<exists> x::'a. x \<noteq> 0\<close>
        using \<open>UNIV\<noteq>{0}\<close> by auto
      thus ?thesis
        by auto
    qed
    have \<open>\<exists> M. \<forall> x.  norm (f x) / (norm x) \<le> M\<close>
      using \<open>bounded_linear f\<close>
      by (metis \<open>\<And>K. (\<forall>x. x \<noteq> 0 \<longrightarrow> norm (f x) \<le> norm x * K) = (\<forall>x. x \<noteq> 0 \<longrightarrow> norm (f x) / norm x \<le> K)\<close> bounded_linear.nonneg_bounded mult_divide_mult_cancel_left_if norm_zero real_divide_square_eq)
    hence t3: \<open>bdd_above {norm (f x) / (norm x) | x. x \<noteq> 0}\<close>
      by auto
    have \<open>norm (f x) / (norm x) \<ge> 0\<close>
      for x
      by simp
    hence \<open>\<forall> y\<in>{norm (f x) / (norm x) | x. x \<noteq> 0}. y \<ge> 0\<close>
      by blast
    show ?thesis
      by (metis (lifting) \<open>\<forall>y\<in>{norm (f x) / norm x |x. x \<noteq> 0}. 0 \<le> y\<close> \<open>bdd_above {norm (f x) / norm x |x. x \<noteq> 0}\<close> \<open>{norm (f x) / norm x |x. x \<noteq> 0} \<noteq> {}\<close> bot.extremum_uniqueI cSup_upper2 subset_emptyI)
  qed
  hence r: \<open>Sup ({norm (f x) / (norm x) | x. x \<noteq> 0} \<union> {norm (f x) / (norm x) | x. x = 0})
         = Sup {norm (f x) / (norm x) | x. True}\<close>
    using t1 by auto
  have \<open>{norm (f x) / (norm x) | x. x = 0} = {norm (f 0) / (norm 0)}\<close>
    by simp
  hence \<open>Sup {norm (f x) / (norm x) | x. x = 0} = 0\<close>
    by simp
  have h1: \<open>Sup {norm (f x) / (norm x) | x. x \<noteq> 0} = Sup {norm (f x) / (norm x) | x. True}\<close>
    using d1 r g1 by auto
  have \<open>(SUP x. norm (f x) / (norm x)) = Inf {K. (\<forall>x\<noteq>0. norm (f x) \<le> norm x * K)}\<close>
    using full_SetCompr_eq
    by (metis f1 h1)
  thus ?thesis
    by (simp add: onorm_def)
qed

lemma onormI:
  assumes "\<And>x. norm (f x) \<le> b * norm x"
    and "x \<noteq> 0" and "norm (f x) = b * norm x"
  shows "onorm f = b"
  apply (unfold onorm_def, rule cSup_eq_maximum)
   apply (smt (verit) UNIV_I assms(2) assms(3) image_iff nonzero_mult_div_cancel_right norm_eq_zero)
  by (smt (verit, del_insts) assms(1) assms(2) divide_nonneg_nonpos norm_ge_zero norm_le_zero_iff pos_divide_le_eq rangeE zero_le_mult_iff)

lemma norm_unit_sphere:
  fixes f::\<open>'a::{real_normed_vector,not_singleton} \<Rightarrow>\<^sub>L 'b::real_normed_vector\<close>
  assumes a1: "bounded_linear f" and a2: "e > 0"
  shows \<open>\<exists>x\<in>(sphere 0 1). norm (norm (blinfun_apply f x) - norm f) < e\<close>
proof-
  define S::"real set" where \<open>S = { norm (f x)| x. x \<in> sphere 0 1 }\<close>
  have "\<exists>x::'a. norm x = 1"
    by (metis (full_types) Collect_empty_eq Extra_General.UNIV_not_singleton UNIV_I equalityI mem_Collect_eq norm_sgn singleton_conv subsetI)
  hence \<open>\<exists>x::'a. x \<in> sphere 0 1\<close>
    by simp
  hence \<open>S\<noteq>{}\<close>unfolding S_def
    by auto
  hence t1: \<open>e > 0 \<Longrightarrow> \<exists> y \<in> S. Sup S - e < y\<close>
    for e
    by (simp add: less_cSupD)
  have \<open>onorm f = Sup { norm (f x)| x. norm x = 1 }\<close>
    using \<open>bounded_linear f\<close> onorm_sphere
    by auto
  hence \<open>onorm f = Sup { norm (f x)| x. x \<in> sphere 0 1 }\<close>
    unfolding sphere_def
    by simp
  hence t2: \<open>Sup S = onorm f\<close> unfolding S_def
    by auto
  have s1: \<open>\<exists>y\<in>{norm (f x) |x. x \<in> sphere 0 1}. norm (onorm f - y) < e\<close>
    if "0 < e"
    for e
  proof-
    have \<open>\<exists> y \<in> S. (onorm f) - e < y\<close>
      using t1 t2 that by auto
    hence \<open>\<exists> y \<in> S. (onorm f) - y  < e\<close>
      using that
      by force
    have \<open>\<exists> y \<in> S. (onorm f) - y  < e\<close>
      using \<open>0 < e\<close> \<open>\<exists>y\<in>S. onorm f - y < e\<close> by auto
    then obtain y where \<open>y \<in> S\<close> and \<open>(onorm f) - y  < e\<close>
      by blast
    have \<open>y \<in> {norm (f x) |x. x \<in> sphere 0 1} \<Longrightarrow> y \<le> onorm f\<close>
    proof-
      assume \<open>y \<in> {norm (f x) |x. x \<in> sphere 0 1}\<close>
      hence \<open>\<exists> x \<in> sphere 0 1. y = norm (f x)\<close>
        by blast
      then obtain x where \<open>x \<in> sphere 0 1\<close> and \<open>y = norm (f x)\<close>
        by blast
      from \<open>y = norm (f x)\<close>
      have \<open>y \<le> onorm f * norm x\<close>
        using a1 onorm by auto
      moreover have \<open>norm x = 1\<close>
        using  \<open>x \<in> sphere 0 1\<close> unfolding sphere_def by auto
      ultimately show ?thesis by simp
    qed
    hence \<open>bdd_above {norm (f x) |x. x \<in> sphere 0 1}\<close>
      using a1 bdd_above_norm_f by force
    hence \<open>bdd_above S\<close> unfolding S_def
      by blast
    hence \<open>y \<le> Sup S\<close>
      using \<open>y \<in> S\<close> \<open>S \<noteq> {}\<close> cSup_upper
      by blast
    hence \<open>0 \<le> Sup S - y\<close>
      by simp
    hence \<open>0 \<le> onorm f - y\<close>
      using \<open>Sup S = onorm f\<close>
      by simp
    hence \<open>\<bar> (onorm f - y) \<bar> = onorm f - y\<close>
      by simp
    hence \<open>norm (onorm f - y)  = onorm f - y\<close>
      by auto
    hence \<open>\<exists> y \<in> S. norm ((onorm f) - y)  < e\<close>
      using \<open>onorm f - y < e\<close> \<open>y \<in> S\<close> by force
    show ?thesis
      unfolding S_def
      using S_def \<open>\<exists>y\<in>S. norm (onorm (blinfun_apply f) - y) < e\<close> by blast
  qed
  have f2: "onorm (blinfun_apply f) = Sup S"
    using S_def \<open>onorm (blinfun_apply f) = Sup {norm (blinfun_apply f x) |x. x \<in> sphere 0 1}\<close> by blast
  hence "\<exists>a. norm (norm (blinfun_apply f a) - Sup S) < e \<and> a \<in> sphere 0 1"
    using a1 a2 s1 a2 t2
    by force
  thus ?thesis
    using f2 by (metis (full_types) norm_blinfun.rep_eq)
qed

end


theory quantum_hoare_logic
imports Main  Matrix
begin

(*The datatype for representing syntax of quantum programs*)
datatype
com=SKIP
|Init "nat" "number"
|Utrans "Mat" "number"
|Seq "com" "com"          ("(_;/ _)"   [60,61] 60  )
|Cond "(Mat * com * Mat) list"
|While "Mat" "Mat" "com" "Mat"

primrec M_sum::"(Mat*com*Mat) list\<Rightarrow>Mat"where
"M_sum [] =zero"|
"M_sum (a#M) =mat_add (mat_mult (dag (fst a) ) (fst a)) (M_sum M )"
primrec sum::"nat list\<Rightarrow>nT\<Rightarrow>Mat\<Rightarrow>Mat" where
"sum [] f1 p=p"|
"sum (b#nl) f1 p = mat_add (mat_mult (mat_mult (f1 b) p) (dag (f1 b)) ) (sum nl f1 p )"
primrec sum_t::"nat list\<Rightarrow>nT\<Rightarrow>Mat\<Rightarrow>Mat"where
"sum_t [] f1 p=p"|
"sum_t (b#nl) f1 p = mat_add (mat_mult (mat_mult (dag (f1 b)) p)  (f1 b) ) (sum_t nl f1 p )"
primrec sum_1::"nat list\<Rightarrow>nT\<Rightarrow>Mat" where
"sum_1 [] f1 =I"|
"sum_1 (b#nl) f1 =mat_add (mat_mult (f1 b) (dag (f1 b))) (sum_1 nl f1)"
primrec sum_2::"nat list\<Rightarrow>nT\<Rightarrow>Mat" where
"sum_2 [] f1 =I"|
"sum_2 (b#nl) f1 =mat_add (mat_mult (dag (f1 b))  (f1 b)   ) (sum_2 nl f1)"
(*u a b =ab(dag a) *)
definition u::"Mat\<Rightarrow>Mat\<Rightarrow>Mat"where
"u a b= mat_mult (mat_mult a b) (dag a)"
(*uu a b =(dag a)ba *)
definition uu::"Mat\<Rightarrow>Mat\<Rightarrow>Mat"where
"uu a b= mat_mult (mat_mult (dag a) b)  a"
primrec accum::"(Mat*com*Mat) list\<Rightarrow>Mat" where
"accum [] =zero"|
"accum (a#M) = mat_add (snd (snd a)) (accum M)"

inductive denofun::"com\<Rightarrow>Mat\<Rightarrow>Mat\<Rightarrow>bool" where
"denofun SKIP p p"
|"denofun (Utrans U n) p ( mat_mult (mat_mult U p) (dag U) ) "
|"denofun  (Init m n) p (sum (h m) f p )"
|"denofun s1 p p''\<Longrightarrow>denofun s2 p'' p'\<Longrightarrow>denofun (s1;s2) p p'"
|"\<forall>a b c. (a,b,c)\<in>set mcl\<longrightarrow>denofun b (u a p) c\<Longrightarrow>denofun (Cond mcl) p (accum mcl)"
|"denofun s (u m1 p) p''\<Longrightarrow>denofun (While m0 m1 s Q) p'' p'\<Longrightarrow>
                                        denofun (While m0 m1 s Q) p (mat_add (u m0 p) p' )"
inductive_cases [elim!]:
"denofun (SKIP) s s'"
"denofun (s1;s2) s s'"
 "denofun (Utrans U n) s s'"
"denofun (Init m n) s s'"
"denofun (Cond mcl) s s'"

fun rank :: "com\<Rightarrow>nat" where
"rank SKIP =1"|
"rank (Utrans U n) =1"|
"rank (Init m n) =1"|
"rank (s1;s2) =1+ rank s2 + (rank s1 )"|
"rank (Cond mcl) =  (case mcl of [] \<Rightarrow> 1
  | mc # mcr \<Rightarrow> 1+rank (fst (snd mc)) + rank (Cond mcr)) "|
"rank  (While  m0 m1 s Q )= 1 + rank s"
lemma wellDefined_aux: "(x, xa, xb) \<in> set mcl \<Longrightarrow>
       (xc, xd) \<in> Basic_BNFs.snds (x, xa, xb) \<Longrightarrow>
       xe \<in> Basic_BNFs.fsts (xc, xd) \<Longrightarrow> rank xe < (case mcl of [] \<Rightarrow> 1 | mc # mcr \<Rightarrow> 1 + rank (fst (snd mc)) + rank (Cond mcr))"
apply (induct mcl, auto)
by (metis fst_conv fsts.cases not_add_less1 not_less_eq sndI snds.cases)

(*the conditions that the commands should meet iff they are well-defined  *)
function wellDefined :: "com\<Rightarrow>bool" where
"wellDefined SKIP =True"|
"wellDefined (Utrans a n) = (UMat a)"|
"wellDefined (Init m n) =((sum_1 (h m) f =I)\<and>(sum_2 (h m) f=I))"|
"wellDefined (s1;s2) = (wellDefined (s1) & wellDefined (s2))"|
"wellDefined (Cond mcl) = ((M_sum mcl=I) \<and>
(\<forall>a aa b aaa ba xaaa. (a, aa, b) \<in> set mcl \<longrightarrow>
       (aaa, ba) \<in> Basic_BNFs.snds (a, aa, b) \<longrightarrow>
       xaaa \<in> Basic_BNFs.fsts (aaa, ba) \<longrightarrow> wellDefined xaaa))"|
"wellDefined  (While  m0 m1 s Q )=((mat_add (mat_mult (dag m0) m0)  (mat_mult (dag m1) m1) =I)  \<and> (wellDefined s)  )  "
by  pat_completeness auto
termination
apply (relation "measure (\<lambda>(c).rank c)", auto)
apply (rule wellDefined_aux, auto)
done
definition valid::"Mat\<Rightarrow>com\<Rightarrow>Mat\<Rightarrow>bool" where
"valid P S Q=(\<forall>\<rho> p. positive \<rho>\<longrightarrow>denofun S \<rho> p\<longrightarrow>Tr (mat_mult P \<rho>)\<le>Tr (mat_mult Q p)+Tr \<rho>-Tr p)"
definition svalid::"Mat\<Rightarrow>com\<Rightarrow>Mat\<Rightarrow>bool"where
"svalid P S Q=(\<forall>\<rho> p. positive \<rho>\<longrightarrow>denofun S \<rho> p\<longrightarrow>Tr (mat_mult (mat_sub I Q) p)\<le>Tr (mat_mult (mat_sub I P) \<rho>))"
lemma eq_valid:"svalid P S Q\<Longrightarrow>valid P S Q"
using Ident mult_sub_allo1 svalid_def tr_allo1 valid_def by fastforce
lemma eq_valids:"valid P S Q\<Longrightarrow>svalid P S Q"
apply(simp add:valid_def)
apply(simp add:svalid_def)
using Ident mult_sub_allo1 tr_allo1 by fastforce
lemma temp:"Tr (sum m f \<rho> ) =Tr  (mat_mult \<rho> (sum_2 m  f) ) "
apply(induct m)
apply auto
apply (metis Ident exchange)
by (metis exchange mult_allo2 mult_exchange tr_allo)
lemma m_init:"sum_1 m  f=I\<Longrightarrow>sum_2 m  f=I\<Longrightarrow>Tr (sum m f \<rho> ) =Tr \<rho>"
apply(simp add:temp)
apply(subgoal_tac " Tr (mat_mult \<rho> I) = Tr (mat_mult I \<rho> ) ")
apply(simp add:Ident)
apply(simp add:exchange)
done
lemma Initfact: "positive \<rho> \<Longrightarrow> Tr (mat_mult (sum_t m f P ) \<rho>) = Tr (mat_mult P (sum m f \<rho> ))"
apply (induct m,auto)
apply(simp add:mult_allo1)
apply(simp add:mult_allo2)
apply(simp add:tr_allo)
by (metis exchange_tr mult_exchange)
lemma init_rho: "positive a \<Longrightarrow> positive (sum list f a)"
apply(induct list,auto)
by (metis a1 less3 less6 rho_zero zero_add)
lemma a:" \<forall>a p. positive a \<longrightarrow> denofun SKIP a p \<longrightarrow> positive p"
apply auto
done
lemma b:" \<forall>a p. positive a \<longrightarrow> denofun (Init x1 x2) a p \<longrightarrow> positive p"
apply auto
apply(rule init_rho,auto)
done
lemma d:" \<forall>a p. positive a \<longrightarrow> denofun (Cond []) a p \<longrightarrow> positive p"
apply auto
using a1 less11 by auto
lemma c:" (\<And>a aa b ab ba xaaa.
               (a, aa, b) \<in> set x \<Longrightarrow>
               (ab, ba) \<in> Basic_BNFs.snds (a, aa, b) \<Longrightarrow>
               xaaa \<in> Basic_BNFs.fsts (ab, ba) \<Longrightarrow> \<forall>a. positive a \<longrightarrow> (\<forall>p. denofun xaaa a p \<longrightarrow> positive p)) \<Longrightarrow>
           positive a \<Longrightarrow> \<forall>aa b c. (aa, b, c) \<in> set x \<longrightarrow> denofun b (u aa a) c \<Longrightarrow> positive (accum x)"
apply(induct x,auto)
apply (simp add: a1 less11)
by (metis (no_types, hide_lams) c1 empty_iff fst_eqD fsts.simps insert_iff less3_aux mult_exchange prod_set_simps(1) prod_set_simps(2) snd_eqD snds.simps u_def)

lemma e: assumes  "denofun (While x1 x2 c x4) a p"
     shows "\<forall>s s'. positive s\<longrightarrow>denofun c s s'\<longrightarrow>positive s'\<Longrightarrow>positive a\<Longrightarrow> positive p"
 using assms
 apply(induct "While x1 x2 c x4" a p)
 apply auto
by (metis c1 less3_aux u_def)
lemma positive_deno:"\<forall>a p. positive a\<longrightarrow>denofun s a p\<longrightarrow>positive p"
apply(induct s)
apply(simp add:a)
apply(simp add:b)
using less3_aux apply auto[1]
apply blast
prefer 2
using quantum_hoare_logic.e apply blast
apply auto
apply(simp add:c)
done
primrec sum1::"(Mat*com*Mat) list\<Rightarrow>Mat"where
"sum1 []  =zero"|
"sum1  (a#M)  =  (mat_add (uu (fst a ) (snd (snd a)))  (sum1 M  ))  "
primrec validlist :: "(Mat * com * Mat) list \<Rightarrow> Mat \<Rightarrow> bool" where
"validlist [] Q = True "
| "validlist (a # mcml) Q = ( (valid (snd (snd a)) (fst (snd a)) Q) \<and> (validlist  mcml Q) )"
definition matsum::"nat\<Rightarrow>nat\<Rightarrow>Mat\<Rightarrow>Mat" where
"matsum m n P=(sum_t (h m) f P )"
definition matUtrans::"Mat\<Rightarrow>nat\<Rightarrow>Mat\<Rightarrow>Mat"where
"matUtrans U n P =(mat_mult (mat_mult (dag U) P) U)"
(*six rules*)
lemma Skip:"valid P SKIP P"
apply(simp add:valid_def)
apply auto
done
lemma Utrans:"wellDefined (Utrans U n) \<Longrightarrow>valid  (matUtrans U n P)  (Utrans U n) P"
apply(simp add:valid_def matUtrans_def)
apply auto
by (smt Ident UMat_def exchange_tr mult_exchange)
lemma Init:"wellDefined (Init m n) \<Longrightarrow>valid (matsum m n P) (Init m n) P"
apply(simp add:valid_def matsum_def)
apply auto
apply(simp add:m_init)
apply(simp add:Initfact)
done
lemma Seq:"valid P s1 Q\<Longrightarrow>valid Q s2 R\<Longrightarrow>valid P (s1;s2) R"
apply(simp add:valid_def,auto)
apply(drule_tac x="\<rho>" in spec)
apply(subgoal_tac " positive \<rho>\<Longrightarrow>denofun s1 \<rho> p''\<Longrightarrow>positive p''")
apply(drule_tac x="p''" in spec)
apply auto
apply force
apply(simp add:positive_deno)
done
lemma Measure_aux:"wellDefined (Cond M) \<Longrightarrow>
\<forall>\<rho> p. positive \<rho> \<longrightarrow> denofun (Cond M) \<rho> p \<longrightarrow> Tr (mat_mult (sum1 M) \<rho>) \<le> Tr (mat_mult Q p) +Tr (mat_mult (M_sum M) \<rho>) - Tr p \<Longrightarrow>
\<forall>\<rho> p. positive \<rho> \<longrightarrow> denofun (Cond M) \<rho> p \<longrightarrow> Tr (mat_mult (sum1 M) \<rho>) \<le> Tr (mat_mult Q p) + Tr \<rho> - Tr p"
by (simp add: Ident)
lemma Measure_aux2:" validlist M Q \<Longrightarrow>
    \<forall>\<rho> p. positive \<rho> \<longrightarrow> denofun (Cond M) \<rho> p \<longrightarrow> Tr (mat_mult (sum1 M) \<rho>) \<le> Tr (mat_mult Q p) + Tr (mat_mult (M_sum M) \<rho>) - Tr p"
apply(induct M,auto)
apply (simp add: zero_mult_r)
apply(drule_tac x="\<rho>"in spec)
apply auto
by (smt denofun.intros(5) exchange_tr less3_aux mult_allo1 mult_exchange tr_allo u_def uu_def valid_def)
lemma Measure:"wellDefined (Cond M) \<Longrightarrow> validlist M Q \<Longrightarrow> valid (sum1 M) (Cond M ) Q"
unfolding valid_def
apply(rule Measure_aux)
apply (simp)
apply(rule Measure_aux2,auto)
done
lemma While_aux:assumes "denofun (While m0 m1 S Q) \<rho> p " and" \<forall>\<rho>. positive \<rho> \<longrightarrow>
               (\<forall>p. denofun S \<rho> p \<longrightarrow> Tr (mat_mult (mat_sub I (mat_add (uu m0 P) (uu m1 Q))) p) \<le> Tr (mat_mult (mat_sub I Q) \<rho>))"and
               " mat_add (mat_mult (dag m0) m0) (mat_mult (dag m1) m1) = I"and" wellDefined S"
               and " positive \<rho>"
shows "  Tr (mat_mult (mat_sub I P) p) \<le> Tr (mat_mult (mat_sub I (mat_add (uu m0 P) (uu m1 Q))) \<rho>)"
           using assms
           apply(induct "While m0 m1 S Q" \<rho> p)
           apply auto
           apply(simp add:mult_allo2)
           apply(simp add:tr_allo)
           apply(subgoal_tac "positive p''")
           prefer 2
           apply (metis less3_aux positive_deno u_def)
           apply auto
           apply(subgoal_tac " Tr (mat_mult (mat_sub I P) (u m0 p)) +  Tr (mat_mult (mat_sub I (mat_add (uu m0 P) (uu m1 Q))) p'')
                 \<le> Tr (mat_mult (mat_sub I (mat_add (uu m0 P) (uu m1 Q))) p)")
           apply auto
           apply(subgoal_tac " Tr (mat_mult (mat_sub I (mat_add (uu m0 P) (uu m1 Q))) p'') \<le> Tr (mat_mult (mat_sub I Q) (u m1 p))")
           prefer 2
           apply (simp add: less3_aux u_def)
           apply(subgoal_tac "positive (u m1 p)")
           prefer 2
           apply (simp add: less3_aux u_def)
           apply auto
           apply(subgoal_tac " Tr (mat_mult (mat_sub I (mat_add (uu m0 P) (uu m1 Q))) p'') \<le> Tr (mat_mult (mat_sub I Q) (u m1 p))")
           prefer 2
           apply blast
           apply(subgoal_tac " Tr (mat_mult (mat_sub I P) (u m0 p)) + Tr (mat_mult (mat_sub I Q) (u m1 p))
                 \<le> Tr (mat_mult (mat_sub I (mat_add (uu m0 P) (uu m1 Q))) p)")
           apply linarith
           apply(simp add:mult_sub_allo1)
           apply(simp add:Ident)
           apply(simp add:tr_allo1)
           apply(subgoal_tac "Tr (u m0 p)+Tr (u m1 p) =Tr p")
           prefer 2
           apply(simp add:u_def)
           apply(simp add:exchange_tr)
           apply (metis Ident mult_allo1 mult_exchange tr_allo)
           apply(subgoal_tac " Tr p  - Tr (mat_mult P (u m0 p)) -  Tr (mat_mult Q (u m1 p))
                  \<le> Tr p - Tr (mat_mult (mat_add (uu m0 P) (uu m1 Q)) p) ")
           apply auto
           apply(subgoal_tac " Tr (mat_mult P (u m0 p))+ Tr (mat_mult Q (u m1 p)) =Tr (mat_mult (mat_add (uu m0 P) (uu m1 Q)) p)")
           apply auto
           apply(simp add:uu_def)
           apply(simp add:u_def)
           by (smt exchange_tr mult_allo1 mult_exchange tr_allo)
lemma While1:"wellDefined (While m0 m1 S Q) \<Longrightarrow>
          svalid Q S (mat_add (uu m0 P) (uu m1 Q)) \<Longrightarrow>valid (mat_add (uu m0 P) (uu m1 Q))  (While m0 m1 S Q ) P"
apply(rule eq_valid)
apply(simp add:svalid_def,auto)
by (simp add: While_aux)
lemma While:"wellDefined (While m0 m1 S Q) \<Longrightarrow>
          valid Q S (mat_add (uu m0 P) (uu m1 Q)) \<Longrightarrow>valid (mat_add (uu m0 P) (uu m1 Q))  (While m0 m1 S Q ) P"
apply(rule While1,auto)
by (simp add: eq_valids)
lemma order:"less P Pa\<Longrightarrow>valid Pa S Q\<Longrightarrow>valid P S Q"
apply(simp add:valid_def)
apply auto
using less2 by fastforce
lemma Order:"less P Pa\<Longrightarrow>valid Pa S Qa\<Longrightarrow>less Qa Q\<Longrightarrow>valid P S Q"
apply(simp add:valid_def,auto)
by (smt less2 positive_deno)
(*  about wlp     *)
function wlp::"Mat\<Rightarrow>com\<Rightarrow>Mat" where
"wlp P (SKIP) =P"|
"wlp P (Init m n) =matsum m n P"|
"wlp P (Utrans U n) =matUtrans U n P"|
"wlp P ( Seq c1 c2) =wlp (wlp P c2) c1"|
"wlp P (Cond mcl ) = (case mcl of [] \<Rightarrow> zero
  | mc # mcr \<Rightarrow> mat_add (uu (fst mc) (wlp P (fst (snd mc))))  (wlp P (Cond mcr)) ) " |
"wlp P (While m0 m1 s  Q ) = zero"
by  pat_completeness auto
termination
 apply (relation "measure (\<lambda>(c,m).rank m)", auto )
done

lemma while_deno_tr:assumes " denofun (While x1 x2 s x4) p p'" and" mat_add (mat_mult (dag x1) x1) (mat_mult (dag x2) x2) = I "
and "wellDefined s"and "\<forall>p. positive p \<longrightarrow> (\<forall>p'. denofun s p p' \<longrightarrow> Tr p' \<le> Tr p)"and " positive p"
shows "Tr p' \<le> Tr p"
using assms
apply(induct "While x1 x2 s x4" p p')
apply auto
apply(subgoal_tac "positive (u x2 p)")
prefer 2
apply (simp add: less3_aux u_def)
apply(subgoal_tac "Tr p''\<le>Tr (u x2 p)")
prefer 2
apply simp
apply(subgoal_tac "Tr p'\<le>Tr (u x2 p)")
prefer 2
apply (smt positive_deno)
apply(simp add:tr_allo)
apply(subgoal_tac "Tr (u x1 p) + Tr (u x2 p) \<le> Tr p ")
prefer 2
apply auto
apply(simp add:u_def)
apply(simp add:exchange_tr)
apply(subgoal_tac "  Tr (mat_mult (mat_mult (dag x1) x1) p) + Tr (mat_mult (mat_mult (dag x2)  x2) p) \<le> Tr p ")
apply(simp add:mult_exchange)
apply(subgoal_tac "Tr (mat_add (mat_mult (mat_mult (dag x1) x1) p) (mat_mult (mat_mult (dag x2) x2) p)  ) \<le>Tr p")
apply(simp add:tr_allo)
apply(subgoal_tac "Tr (mat_mult (mat_add (mat_mult (dag x1) x1) (mat_mult (dag x2) x2 )) p) \<le>Tr p")
apply (metis mult_allo1)
apply (simp add:Ident)
done
lemma cond_deno_tr:  " (\<And>a aa b. (a, aa, b) \<in> set x \<Longrightarrow>\<forall>p. positive p \<longrightarrow> (\<forall>p'. denofun aa p p' \<longrightarrow> Tr p' \<le> Tr p)) \<Longrightarrow>
           \<forall>a aa b. (a, aa, b) \<in> set x \<longrightarrow> wellDefined aa \<Longrightarrow>
           positive p \<Longrightarrow> \<forall>a b c. (a, b, c) \<in> set x \<longrightarrow> denofun b (u a p) c \<Longrightarrow> Tr (accum x) \<le> Tr (mat_mult (M_sum x) p)"
           apply(induct x,auto)
           using zero_mult_l apply auto[1]
           apply(simp add:tr_allo)
           apply(simp add:mult_allo1)
           apply(simp add:tr_allo)
           by (metis (no_types, hide_lams) add_mono exchange_tr less3_aux mult_exchange u_def)
(*Tr [S](\<rho>) \<le>Tr \<rho>*)
lemma deno_tr:"wellDefined s\<Longrightarrow>\<forall>p p'. positive p\<longrightarrow> denofun s p p'\<longrightarrow>Tr p' \<le>Tr p"
apply(induct s)
apply auto
apply (simp add: m_init)
apply (smt Ident UMat_def exchange_tr mult_exchange)
using positive_deno apply force
prefer 2
apply (simp add: while_deno_tr)
apply(subgoal_tac " Tr (accum x) \<le> Tr (mat_mult (M_sum x) p)")
apply(simp add:Ident)
apply(rule cond_deno_tr, auto)
using fsts.intros snds.intros apply fastforce
using fsts.intros snds.intros by fastforce
lemma temp_wlp:" positive P \<Longrightarrow> positive (sum_t a f P)"
apply(induct a,auto)
by (metis c1 dag_dag less3_aux)
lemma temp_wlp1:" ((\<And>a aa b. (a, aa, b) \<in> set x \<Longrightarrow> \<forall>P. positive P \<longrightarrow> positive (wlp P aa)) \<Longrightarrow>
        positive (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (uu (fst mc) (wlp P (fst (snd mc)))) (wlp P (Cond mcr)))) \<Longrightarrow>
       (\<And>aaa aaaa ba. aaa = a \<and> aaaa = aa \<and> ba = b \<or> (aaa, aaaa, ba) \<in> set x \<Longrightarrow> \<forall>P. positive P \<longrightarrow> positive (wlp P aaaa)) \<Longrightarrow>
       positive P \<Longrightarrow> positive
       (mat_add (uu a (wlp P aa)) (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (uu (fst mc) (wlp P (fst (snd mc)))) (wlp P (Cond mcr))))"
apply(subgoal_tac "positive (wlp P aa)")
prefer 2
apply blast
apply(subgoal_tac "positive (uu a (wlp P aa)) ")
prefer 2
apply(simp add:uu_def)
apply (metis dag_dag less3_aux)
using c1 by blast
 lemma temp_wlp2:" (\<And>a aa b. (a, aa, b) \<in> set x \<Longrightarrow> \<forall>P. positive P \<longrightarrow> positive (wlp P aa)) \<Longrightarrow>
    positive P \<Longrightarrow> positive (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (uu (fst mc) (wlp P (fst (snd mc)))) (wlp P (Cond mcr)))"
apply(induct x,auto)
using a1 less11 apply blast
apply( rule temp_wlp1,auto)
done
(*positive wlp P S*)
lemma positive_wlp: "\<forall>P. positive P\<longrightarrow>positive (wlp P S)"
apply(induct S,auto)
apply(simp add:matsum_def temp_wlp)
apply (metis dag_dag less3_aux matUtrans_def)
prefer 2
apply (simp add: a1 less11)
apply(rule temp_wlp2,auto)
using fsts.intros snds.intros by fastforce
(*while_wlp*)
lemma while_wlp_aux:assumes" denofun (While m1 m2 com Q) \<rho> p"and"mat_add (mat_mult (dag m1) m1) (mat_mult (dag m2) m2) = I"and
" wellDefined com" and " positive \<rho> "and "positive P"
shows " Tr (mat_mult (mat_sub I P) p) \<le> Tr \<rho>"
using assms
apply(induct "While m1 m2 com Q" \<rho> p)
apply auto
apply(subgoal_tac "positive p''")
prefer 2
apply (metis less3_aux positive_deno u_def)
apply auto
apply(simp add:mult_allo2)
apply(simp add:tr_allo)
apply(simp add:mult_sub_allo1)
apply(simp add:Ident tr_allo1)
apply(subgoal_tac "Tr (u m1 p) - Tr (mat_mult P (u m1 p)) + Tr p'' \<le> Tr p ")
apply auto
apply(subgoal_tac "Tr p''\<le>Tr (u m2 p)")
prefer 2
apply (simp add: deno_tr less3_aux u_def)
apply(subgoal_tac " Tr (u m1 p) - Tr (mat_mult P (u m1 p)) + Tr (u m2 p) \<le> Tr p ")
apply auto
by (smt Ident exchange_tr less3_aux less44 mult_allo1 mult_exchange tr_allo u_def)
(*wlp-while*)
lemma while_wlp:"positive P\<Longrightarrow>wellDefined (While m1 m2 com Q) \<Longrightarrow>valid (wlp P (While m1 m2 com Q)) (While m1 m2 com Q) P"
apply(rule eq_valid)
apply(simp add:svalid_def,auto)
apply(simp add:zero_sub)
apply(simp add:Ident)
apply(simp add:while_wlp_aux)
done
lemma skip_wlp:"valid (wlp P SKIP) SKIP P"
apply (simp add:valid_def)
apply auto
done
lemma init_wlp:"wellDefined (Init m n) \<Longrightarrow>valid (wlp P (Init m n)) (Init m n) P"
using Init valid_def by auto
lemma utrans_wlp:"wellDefined (Utrans U n) \<Longrightarrow>valid (wlp P (Utrans U n)) (Utrans U n) P"
using Utrans valid_def by auto
lemma seq_wlp:"       \<forall>Q. positive Q \<longrightarrow> valid (wlp Q S1) S1 Q \<Longrightarrow>
       \<forall>Q. positive Q \<longrightarrow> valid (wlp Q S2) S2 Q \<Longrightarrow>
       wellDefined S1 \<Longrightarrow> wellDefined S2 \<Longrightarrow> positive Q \<Longrightarrow> valid (wlp (wlp Q S2) S1) (S1; S2) Q"
apply(simp add:valid_def)
apply auto
apply(subgoal_tac "positive (wlp Q S2)")
apply(drule_tac x="(wlp Q S2)"in spec)
apply(drule_tac x="Q"in spec)
apply auto
apply(drule_tac x="\<rho>"in spec)
apply(subgoal_tac "positive p''")
apply(drule_tac x="p''"in spec)
apply auto
apply(drule_tac x="p''"in spec)
apply auto
apply(drule_tac x="p"in spec)
using positive_deno apply blast
apply(simp add:positive_wlp)
done

lemma b1:" (\<And>\<rho>. (\<And>a aa b. (a, aa, b) \<in> set x \<Longrightarrow>
                       \<forall>Q. positive Q \<longrightarrow>
                           (\<forall>\<rho>. positive \<rho> \<longrightarrow> (\<forall>p. denofun aa \<rho> p \<longrightarrow> Tr (mat_mult (wlp Q aa) \<rho>) \<le> Tr (mat_mult Q p) + Tr \<rho> - Tr p))) \<Longrightarrow>
             \<forall>a aa. (\<exists>b. (a, aa, b) \<in> set x) \<longrightarrow> wellDefined aa \<Longrightarrow>
             positive \<rho> \<Longrightarrow>
             \<forall>a b c. (a, b, c) \<in> set x \<longrightarrow> denofun b (u a \<rho>) c \<Longrightarrow>
             Tr (mat_mult (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (uu (fst mc) (wlp Q (fst (snd mc)))) (wlp Q (Cond mcr))) \<rho>)
             \<le> Tr (mat_mult Q (accum x)) + Tr (mat_mult (M_sum x) \<rho>) - Tr (accum x)) \<Longrightarrow>
       (\<And>aaa aaaa ba.
           aaa = a \<and> aaaa = aa \<and> ba = b \<or> (aaa, aaaa, ba) \<in> set x \<Longrightarrow>
           \<forall>Q. positive Q \<longrightarrow>
               (\<forall>\<rho>. positive \<rho> \<longrightarrow> (\<forall>p. denofun aaaa \<rho> p \<longrightarrow> Tr (mat_mult (wlp Q aaaa) \<rho>) \<le> Tr (mat_mult Q p) + Tr \<rho> - Tr p))) \<Longrightarrow>
       \<forall>aaa aaaa. (\<exists>ba. aaa = a \<and> aaaa = aa \<and> ba = b \<or> (aaa, aaaa, ba) \<in> set x) \<longrightarrow> wellDefined aaaa \<Longrightarrow>
        \<forall>aaa ba c. (aaa = a \<and> ba = aa \<and> c = b \<longrightarrow> denofun aa (u a \<rho>) b) \<and> ((aaa, ba, c) \<in> set x \<longrightarrow> denofun ba (u aaa \<rho>) c) \<Longrightarrow>
        positive \<rho> \<Longrightarrow>
             Tr (mat_mult (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (uu (fst mc) (wlp Q (fst (snd mc)))) (wlp Q (Cond mcr))) \<rho>)
             \<le> Tr (mat_mult Q (accum x)) + Tr (mat_mult (M_sum x) \<rho>) - Tr (accum x)
               "
by fastforce
lemma b2:"           Tr (mat_mult (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (uu (fst mc) (wlp Q (fst (snd mc)))) (wlp Q (Cond mcr))) \<rho>)
             \<le> Tr (mat_mult Q (accum x)) + Tr (mat_mult (M_sum x) \<rho>) - Tr (accum x) \<Longrightarrow>
       (\<And>aaa aaaa ba.
           aaa = a \<and> aaaa = aa \<and> ba = b \<or> (aaa, aaaa, ba) \<in> set x \<Longrightarrow>
           \<forall>Q. positive Q \<longrightarrow>
               (\<forall>\<rho>. positive \<rho> \<longrightarrow> (\<forall>p. denofun aaaa \<rho> p \<longrightarrow> Tr (mat_mult (wlp Q aaaa) \<rho>) \<le> Tr (mat_mult Q p) + Tr \<rho> - Tr p))) \<Longrightarrow>
       \<forall>aaa aaaa. (\<exists>ba. aaa = a \<and> aaaa = aa \<and> ba = b \<or> (aaa, aaaa, ba) \<in> set x) \<longrightarrow> wellDefined aaaa \<Longrightarrow>
       positive Q \<Longrightarrow>
       positive \<rho> \<Longrightarrow>
       \<forall>aaa ba c. (aaa = a \<and> ba = aa \<and> c = b \<longrightarrow> denofun aa (u a \<rho>) b) \<and> ((aaa, ba, c) \<in> set x \<longrightarrow> denofun ba (u aaa \<rho>) c) \<Longrightarrow>
       Tr (mat_mult (uu a (wlp Q aa)) \<rho>) +
       Tr (mat_mult (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (uu (fst mc) (wlp Q (fst (snd mc)))) (wlp Q (Cond mcr))) \<rho>)
       \<le> Tr (mat_mult Q b) + Tr (mat_mult Q (accum x)) + (Tr (mat_mult (mat_mult (dag a) a) \<rho>) + Tr (mat_mult (M_sum x) \<rho>)) -
          (Tr b + Tr (accum x))"
           apply(drule_tac x="a"in spec,auto)
            apply(drule_tac x="a"in spec,auto)
             apply(drule_tac x="aa"in spec,auto)
              apply(drule_tac x="aa"in spec)
               apply(drule_tac x="b"in spec,auto)
apply (smt exchange_tr less3_aux mult_exchange u_def uu_def)
apply(subgoal_tac " (\<forall>\<rho>. positive \<rho> \<longrightarrow> (\<forall>p. denofun aa \<rho> p \<longrightarrow> Tr (mat_mult (wlp Q aa) \<rho>) \<le> Tr (mat_mult Q p) + Tr \<rho> - Tr p))")
prefer 2
apply blast
 apply(drule_tac x="u a \<rho>"in spec)
 apply(subgoal_tac "positive (u a \<rho>)")
 prefer 2
apply (simp add: less3_aux u_def)
apply auto
 apply(drule_tac x="b"in spec,auto)
by (smt exchange_tr mult_exchange u_def uu_def)

lemma a1:"(\<And>a aa b . (a, aa, b) \<in> set x \<Longrightarrow>
               \<forall>Q. positive Q \<longrightarrow>
                   (\<forall>\<rho>. positive \<rho> \<longrightarrow> (\<forall>p. denofun aa \<rho> p \<longrightarrow> Tr (mat_mult (wlp Q aa) \<rho>) \<le> Tr (mat_mult Q p) + Tr \<rho> - Tr p))) \<Longrightarrow>
           \<forall>a aa b. (a, aa, b) \<in> set x \<longrightarrow> wellDefined aa \<Longrightarrow>
           positive Q \<Longrightarrow>
           \<forall>\<rho>. positive \<rho> \<longrightarrow>
               (\<forall>p. denofun (Cond x) \<rho> p \<longrightarrow>
                    Tr (mat_mult (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (uu (fst mc) (wlp Q (fst (snd mc)))) (wlp Q (Cond mcr))) \<rho>)
                    \<le> Tr (mat_mult Q p) + Tr (mat_mult (M_sum x) \<rho>) - Tr p)"
apply(auto)
apply(induct x,auto)
apply (simp add: zero_mult_r)
      apply(simp add:mult_allo1)
      apply(simp add:tr_allo)
      apply(simp add:mult_allo2)
      apply(simp add:tr_allo)
      apply(rule b2,auto)
      apply(rule b1,auto)
      done
 lemma a2:" (\<And>a aa b aaa ba xaaa.
               (a, aa, b) \<in> set x \<Longrightarrow>
               (aaa, ba) \<in> Basic_BNFs.snds (a, aa, b) \<Longrightarrow>
               xaaa \<in> Basic_BNFs.fsts (aaa, ba) \<Longrightarrow>
               \<forall>Q. positive Q \<longrightarrow>
                   (\<forall>\<rho>. positive \<rho> \<longrightarrow> (\<forall>p. denofun xaaa \<rho> p \<longrightarrow> Tr (mat_mult (wlp Q xaaa) \<rho>) \<le> Tr (mat_mult Q p) + Tr \<rho> - Tr p))) \<Longrightarrow>
           \<forall>a aa b. (a, aa, b) \<in> set x \<longrightarrow>
                    (\<forall>aaa ba. (aaa, ba) \<in> Basic_BNFs.snds (a, aa, b) \<longrightarrow>
                              (\<forall>xaaa. xaaa \<in> Basic_BNFs.fsts (aaa, ba) \<longrightarrow> wellDefined xaaa)) \<Longrightarrow>
           positive Q \<Longrightarrow>
           \<forall>\<rho>. positive \<rho> \<longrightarrow>
               (\<forall>p. denofun (Cond x) \<rho> p \<longrightarrow>
                    Tr (mat_mult (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (uu (fst mc) (wlp Q (fst (snd mc)))) (wlp Q (Cond mcr))) \<rho>)
                    \<le> Tr (mat_mult Q p) + Tr (mat_mult (M_sum x) \<rho>) - Tr p)"
apply(rule a1,auto)
using fsts.intros snds.intros apply fastforce+
done
lemma cond_wlp_aux:" (\<And>a aa b aaa ba xaaa.
               (a, aa, b) \<in> set x \<Longrightarrow>
               (aaa, ba) \<in> Basic_BNFs.snds (a, aa, b) \<Longrightarrow>
               xaaa \<in> Basic_BNFs.fsts (aaa, ba) \<Longrightarrow>
               \<forall>Q. positive Q \<longrightarrow>
                   (\<forall>\<rho>. positive \<rho> \<longrightarrow> (\<forall>p. denofun xaaa \<rho> p \<longrightarrow> Tr (mat_mult (wlp Q xaaa) \<rho>) \<le> Tr (mat_mult Q p) + Tr \<rho> - Tr p))) \<Longrightarrow>
           \<forall>a aa b. (a, aa, b) \<in> set x \<longrightarrow>
                    (\<forall>aaa ba. (aaa, ba) \<in> Basic_BNFs.snds (a, aa, b) \<longrightarrow>
                              (\<forall>xaaa. xaaa \<in> Basic_BNFs.fsts (aaa, ba) \<longrightarrow> wellDefined xaaa)) \<Longrightarrow>
            M_sum x = I \<Longrightarrow>
           positive Q \<Longrightarrow>
           \<forall>\<rho>. positive \<rho> \<longrightarrow>
               (\<forall>p. denofun (Cond x) \<rho> p \<longrightarrow>
                    Tr (mat_mult (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (uu (fst mc) (wlp Q (fst (snd mc)))) (wlp Q (Cond mcr))) \<rho>)
                    \<le> Tr (mat_mult Q p) + Tr (mat_mult (M_sum x) \<rho>) - Tr p)"
apply(rule a2,auto)
done
lemma cond_wlp:" (\<And>a aa b aaa ba xaaa.
               (a, aa, b) \<in> set x \<Longrightarrow>
               (aaa, ba) \<in> Basic_BNFs.snds (a, aa, b) \<Longrightarrow>
               xaaa \<in> Basic_BNFs.fsts (aaa, ba) \<Longrightarrow>
               \<forall>Q. positive Q \<longrightarrow>
                   (\<forall>\<rho>. positive \<rho> \<longrightarrow> (\<forall>p. denofun xaaa \<rho> p \<longrightarrow> Tr (mat_mult (wlp Q xaaa) \<rho>) \<le> Tr (mat_mult Q p) + Tr \<rho> - Tr p))) \<Longrightarrow>
           \<forall>a aa b. (a, aa, b) \<in> set x \<longrightarrow>
                    (\<forall>aaa ba. (aaa, ba) \<in> Basic_BNFs.snds (a, aa, b) \<longrightarrow>
                              (\<forall>xaaa. xaaa \<in> Basic_BNFs.fsts (aaa, ba) \<longrightarrow> wellDefined xaaa)) \<Longrightarrow>
            M_sum x = I \<Longrightarrow>
           positive Q \<Longrightarrow>
           \<forall>\<rho>. positive \<rho> \<longrightarrow>
               (\<forall>p. denofun (Cond x) \<rho> p \<longrightarrow>
                    Tr (mat_mult (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (uu (fst mc) (wlp Q (fst (snd mc)))) (wlp Q (Cond mcr))) \<rho>)
                    \<le> Tr (mat_mult Q p) + Tr \<rho> - Tr p)"
            apply(subgoal_tac "           \<forall>\<rho>. positive \<rho> \<longrightarrow>
               (\<forall>p. denofun (Cond x) \<rho> p \<longrightarrow>
                    Tr (mat_mult (case x of [] \<Rightarrow> zero | mc # mcr \<Rightarrow> mat_add (uu (fst mc) (wlp Q (fst (snd mc)))) (wlp Q (Cond mcr))) \<rho>)
                    \<le> Tr (mat_mult Q p) + Tr (mat_mult (M_sum x) \<rho>) - Tr p)")
            apply(simp add:Ident)
            apply(rule cond_wlp_aux ,auto)
            done
lemma soundwp:"wellDefined S\<Longrightarrow>\<forall>Q. positive Q\<longrightarrow>valid (wlp Q S) S Q"
apply(induct S)
prefer 6
using while_wlp apply blast
apply (simp add: Skip)
apply (simp add: Init)
apply (simp add: Utrans)
apply auto
apply (simp add: seq_wlp)
apply(simp add:valid_def)
apply(rule cond_wlp,auto)
done
lemma WLPsound:"positive Q\<Longrightarrow>wellDefined S\<Longrightarrow>valid (wlp Q S) S Q"
apply(simp add: soundwp)
done
lemma ord_wlp:"positive Q\<Longrightarrow>wellDefined S\<Longrightarrow>less P (wlp Q S)\<Longrightarrow>valid P S Q"
apply(rule_tac Pa="wlp Q S" in order,auto)
apply(rule WLPsound)
apply auto
done

declare uu_def[simp] zero_add[simp]
ML_file "Quantum_Hoare_tac.ML"
method_setup vcg = {*
  Scan.succeed (fn ctxt => SIMPLE_METHOD' (quantum_hoare_tac ctxt (K all_tac))) *}
method_setup vcg_simp = {*
  Scan.succeed (fn ctxt =>
    SIMPLE_METHOD' (quantum_hoare_tac ctxt (asm_full_simp_tac ctxt))) *}

end


theory ExF001
imports Main
begin

lemma "\<lbrakk> P a ; Q a \<rbrakk> \<Longrightarrow> \<exists>x. P x \<and> Q x"
proof -
assume "P a"
assume "Q a"
with \<open>P a\<close> have "P a \<and> Q a" by (rule conjI)
thus ?thesis by (rule exI)
qed


subsection "A small step semantics on annotated commands"

theory Collecting1
imports Collecting
begin

text\<open>The idea: the state is propagated through the annotated command as an
annotation \<^term>\<open>{s}\<close>, all other annotations are \<^term>\<open>{}\<close>. It is easy
to show that this semantics approximates the collecting semantics.\<close>

lemma step_preserves_le:
  "\<lbrakk> step S cs = cs; S' \<subseteq> S; cs' \<le> cs \<rbrakk> \<Longrightarrow>
   step S' cs' \<le> cs"
by (metis mono2_step)

lemma steps_empty_preserves_le: assumes "step S cs = cs"
shows "cs' \<le> cs \<Longrightarrow> (step {} ^^ n) cs' \<le> cs"
proof(induction n arbitrary: cs')
  case 0 thus ?case by simp
next
  case (Suc n) thus ?case
    using Suc.IH[OF step_preserves_le[OF assms empty_subsetI Suc.prems]]
    by(simp add:funpow_swap1)
qed

definition steps :: "state \<Rightarrow> com \<Rightarrow> nat \<Rightarrow> state set acom" where
"steps s c n = ((step {})^^n) (step {s} (annotate (\<lambda>p. {}) c))"

lemma steps_approx_fix_step: assumes "step S cs = cs" and "s \<in> S"
shows "steps s (strip cs) n \<le> cs"
proof-
  let ?bot = "annotate (\<lambda>p. {}) (strip cs)"
  have "?bot \<le> cs" by(induction cs) auto
  from step_preserves_le[OF assms(1)_ this, of "{s}"] \<open>s \<in> S\<close>
  have 1: "step {s} ?bot \<le> cs" by simp
  from steps_empty_preserves_le[OF assms(1) 1]
  show ?thesis by(simp add: steps_def)
qed

theorem steps_approx_CS: "steps s c n \<le> CS c"
by (metis CS_unfold UNIV_I steps_approx_fix_step strip_CS)

end


(*  Title:      ZF/Induct/Acc.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge
*)

section \<open>The accessible part of a relation\<close>

theory Acc imports ZF begin

text \<open>
  Inductive definition of \<open>acc(r)\<close>; see \<^cite>\<open>"paulin-tlca"\<close>.
\<close>

consts
  acc :: "i \<Rightarrow> i"

inductive
  domains "acc(r)" \<subseteq> "field(r)"
  intros
    vimage:  "\<lbrakk>r-``{a}: Pow(acc(r)); a \<in> field(r)\<rbrakk> \<Longrightarrow> a \<in> acc(r)"
  monos      Pow_mono

text \<open>
  The introduction rule must require \<^prop>\<open>a \<in> field(r)\<close>,
  otherwise \<open>acc(r)\<close> would be a proper class!

  \medskip
  The intended introduction rule:
\<close>

lemma accI: "\<lbrakk>\<And>b. \<langle>b,a\<rangle>:r \<Longrightarrow> b \<in> acc(r);  a \<in> field(r)\<rbrakk> \<Longrightarrow> a \<in> acc(r)"
  by (blast intro: acc.intros)

lemma acc_downward: "\<lbrakk>b \<in> acc(r);  \<langle>a,b\<rangle>: r\<rbrakk> \<Longrightarrow> a \<in> acc(r)"
  by (erule acc.cases) blast

lemma acc_induct [consumes 1, case_names vimage, induct set: acc]:
    "\<lbrakk>a \<in> acc(r);
        \<And>x. \<lbrakk>x \<in> acc(r);  \<forall>y. \<langle>y,x\<rangle>:r \<longrightarrow> P(y)\<rbrakk> \<Longrightarrow> P(x)
\<rbrakk> \<Longrightarrow> P(a)"
  by (erule acc.induct) (blast intro: acc.intros)

lemma wf_on_acc: "wf[acc(r)](r)"
  apply (rule wf_onI2)
  apply (erule acc_induct)
  apply fast
  done

lemma acc_wfI: "field(r) \<subseteq> acc(r) \<Longrightarrow> wf(r)"
  by (erule wf_on_acc [THEN wf_on_subset_A, THEN wf_on_field_imp_wf])

lemma acc_wfD: "wf(r) \<Longrightarrow> field(r) \<subseteq> acc(r)"
  apply (rule subsetI)
  apply (erule wf_induct2, assumption)
   apply (blast intro: accI)+
  done

lemma wf_acc_iff: "wf(r) \<longleftrightarrow> field(r) \<subseteq> acc(r)"
  by (rule iffI, erule acc_wfD, erule acc_wfI)

end


section \<open>Results\<close>

theory Results imports Soundness Completeness Sequent_Calculus_Verifier begin

text \<open>In this theory, we collect our soundness and completeness results and prove some extra results
  linking the SeCaV proof system, the usual semantics of SeCaV, and our bounded semantics.\<close>

subsection \<open>Alternate semantics\<close>

text \<open>The existence of a finite, well-formed proof tree with a formula at its root implies that the
  formula is valid under our bounded semantics.\<close>
corollary prover_soundness_usemantics:
  assumes \<open>tfinite t\<close> \<open>wf t\<close> \<open>is_env u e\<close> \<open>is_fdenot u f\<close>
  shows \<open>\<exists>p \<in> set (rootSequent t). usemantics u e f g p\<close>
  using assms prover_soundness_SeCaV sound_usemantics by blast

text \<open>The prover returns a finite, well-formed proof tree if and only if the sequent to be proved is
  valid under our bounded semantics.\<close>
theorem prover_usemantics:
  fixes A :: \<open>tm list\<close> and z :: \<open>fm list\<close>
  defines \<open>t \<equiv> secavProver (A, z)\<close>
  shows \<open>tfinite t \<and> wf t \<longleftrightarrow> uvalid z\<close>
  using assms prover_soundness_usemantics prover_completeness_usemantics
  unfolding secavProver_def by fastforce

text \<open>The prover returns a finite, well-formed proof tree for a single formula if and only if the
  formula is valid under our bounded semantics.\<close>
corollary
  fixes p :: fm
  defines \<open>t \<equiv> secavProver ([], [p])\<close>
  shows \<open>tfinite t \<and> wf t \<longleftrightarrow> uvalid [p]\<close>
  using assms prover_usemantics by simp

subsection \<open>SeCaV\<close>

text \<open>The prover returns a finite, well-formed proof tree if and only if the sequent to be proven is
  provable in the SeCaV proof system.\<close>
theorem prover_SeCaV:
  fixes A :: \<open>tm list\<close> and z :: \<open>fm list\<close>
  defines \<open>t \<equiv> secavProver (A, z)\<close>
  shows \<open>tfinite t \<and> wf t \<longleftrightarrow> (\<tturnstile> z)\<close>
  using assms prover_soundness_SeCaV prover_completeness_SeCaV
  unfolding secavProver_def by fastforce

text \<open>The prover returns a finite, well-formed proof tree if and only if the single formula to be
  proven is provable in the SeCaV proof system.\<close>
corollary
  fixes p :: fm
  defines \<open>t \<equiv> secavProver ([], [p])\<close>
  shows \<open>tfinite t \<and> wf t \<longleftrightarrow> (\<tturnstile> [p])\<close>
  using assms prover_SeCaV by blast

subsection \<open>Semantics\<close>

text \<open>If the prover returns a finite, well-formed proof tree, some formula in the sequent at the
  root of the tree is valid under the usual SeCaV semantics.\<close>
corollary prover_soundness_semantics:
  assumes \<open>tfinite t\<close> \<open>wf t\<close>
  shows \<open>\<exists>p \<in> set (rootSequent t). semantics e f g p\<close>
  using assms prover_soundness_SeCaV sound by blast

text \<open>If the prover returns a finite, well-formed proof tree, the single formula in the sequent at
  the root of the tree is valid under the usual SeCaV semantics.\<close>
corollary
  assumes \<open>tfinite t\<close> \<open>wf t\<close> \<open>snd (fst (root t)) = [p]\<close>
  shows \<open>semantics e f g p\<close>
  using assms prover_soundness_SeCaV complete_sound(2) by metis

text \<open>If a formula is valid under the usual SeCaV semantics, the prover will return a finite,
  well-formed proof tree with the formula at its root when called on it.\<close>
corollary prover_completeness_semantics:
  fixes A :: \<open>tm list\<close>
  assumes \<open>\<forall>(e :: nat \<Rightarrow> nat hterm) f g. semantics e f g p\<close>
  defines \<open>t \<equiv> secavProver (A, [p])\<close>
  shows \<open>fst (root t) = (A, [p]) \<and> wf t \<and> tfinite t\<close>
proof -
  have \<open>\<tturnstile> [p]\<close>
    using assms complete_sound(1) by blast
  then show ?thesis
    using assms prover_completeness_SeCaV by blast
qed

text \<open>The prover produces a finite, well-formed proof tree for a formula if and only if that formula
  is valid under the usual SeCaV semantics.\<close>
theorem prover_semantics:
  fixes A :: \<open>tm list\<close> and p :: fm
  defines \<open>t \<equiv> secavProver (A, [p])\<close>
  shows \<open>tfinite t \<and> wf t \<longleftrightarrow> (\<forall>(e :: nat \<Rightarrow> nat hterm) f g. semantics e f g p)\<close>
  using assms prover_soundness_semantics prover_completeness_semantics
  unfolding secavProver_def by fastforce

text \<open>Validity in the two semantics (in the proper universes) coincide.\<close>
theorem semantics_usemantics:
  \<open>(\<forall>(e :: nat \<Rightarrow> nat hterm) f g. semantics e f g p) \<longleftrightarrow>
   (\<forall>(u :: tm set) e f g. is_env u e \<longrightarrow> is_fdenot u f \<longrightarrow> usemantics u e f g p)\<close>
  using prover_semantics prover_usemantics by simp

end


(*<*)
theory Examples
  imports Monitor_Impl
begin
(*>*)

section \<open>Examples\<close>

abbreviation "TT \<equiv> Formula.Eq (Formula.Const (EInt 0)) (Formula.Const (EInt 0))"
abbreviation "Eventually I \<psi> \<equiv> Formula.Until TT I \<psi>"

abbreviation "p \<equiv> STR ''p''"
abbreviation "A \<equiv> STR ''A''"
abbreviation "B \<equiv> STR ''B''"

definition "\<phi>\<^sub>e\<^sub>x = Formula.Let p (Eventually (interval 0 10) (Formula.Pred A [Formula.Var 0]))
  (Formula.Pred p [Formula.Var 0])"
definition "\<phi>\<^sub>e\<^sub>x\<^sub>2 = Formula.Let p (Formula.And (Eventually (interval 0 10) (Formula.Pred B [Formula.Var 0])) (Eventually (interval 0 10) (Formula.Pred A [Formula.Var 0])))
  (Formula.Pred p [Formula.Var 0])"

lemma "mmonitorable \<phi>\<^sub>e\<^sub>x" by eval
lemma "mmonitorable \<phi>\<^sub>e\<^sub>x\<^sub>2" by eval

definition "s0 = minit \<phi>\<^sub>e\<^sub>x"
definition "m1 = mstep (Mapping.update A [{[EInt 0], [EInt 1]}] Mapping.empty, 1) s0"
definition "m2 = mstep (Mapping.empty, 2) (snd m1)"
definition "m3 = mstep (Mapping.update A [{[EInt 2]}] Mapping.empty, 2) (snd m2)"
definition "m4 = mstep (Mapping.update A [{[EInt 5]}] Mapping.empty, 12) (snd m3)"
definition "m5 = mstep (Mapping.update A [{[EInt 6]}] Mapping.empty, 13) (snd m4)"

value s0
value m1
value m2
value m3
value m4
value m5

(*<*)
end
(*>*)


section\<open>Relative DC\<close>

theory Pointed_DC_Relative
  imports
    Cardinal_Library_Relative

begin

consts dc_witness :: "i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> i"
primrec
  wit0   : "dc_witness(0,A,a,s,R) = a"
  witrec : "dc_witness(succ(n),A,a,s,R) = s`{x\<in>A. \<langle>dc_witness(n,A,a,s,R),x\<rangle>\<in>R}"

lemmas dc_witness_def = dc_witness_nat_def

relativize functional "dc_witness" "dc_witness_rel"
relationalize "dc_witness_rel" "is_dc_witness"
  (* definition
  is_dc_witness_fm where
  "is_dc_witness_fm(na, A, a, s, R, e) \<equiv> is_transrec_fm
                  (is_nat_case_fm
                    (a +\<^sub>\<omega> 8, (\<cdot>\<exists>\<cdot>\<cdot>4`2 is 0\<cdot> \<and> (\<cdot>\<exists>\<cdot>\<cdot>s +\<^sub>\<omega> 12`0 is 2\<cdot> \<and> Collect_fm(A +\<^sub>\<omega> 12, \<cdot>(\<cdot>\<exists>\<cdot>0 = 0\<cdot>\<cdot>) \<and> (\<cdot>\<exists>\<cdot>\<cdot>0 \<in> R +\<^sub>\<omega> 14\<cdot> \<and> pair_fm(3, 1, 0) \<cdot>\<cdot>)\<cdot>, 0) \<cdot>\<cdot>)\<cdot>\<cdot>), 2,
                     0), na, e)"
 *)
schematic_goal sats_is_dc_witness_fm_auto:
  assumes "na < length(env)" "e < length(env)"
  shows
    "   na \<in> \<omega> \<Longrightarrow>
    A \<in> \<omega> \<Longrightarrow>
    a \<in> \<omega> \<Longrightarrow>
    s \<in> \<omega> \<Longrightarrow>
    R \<in> \<omega> \<Longrightarrow>
    e \<in> \<omega> \<Longrightarrow>
    env \<in> list(Aa) \<Longrightarrow>
    0 \<in> Aa \<Longrightarrow>
    is_dc_witness(##Aa, nth(na, env), nth(A, env), nth(a, env), nth(s, env), nth(R, env), nth(e, env)) \<longleftrightarrow>
    Aa, env \<Turnstile> ?fm(nat, A, a, s, R, e)"
  unfolding is_dc_witness_def is_recursor_def
  by (rule is_transrec_iff_sats | simp_all)
    (rule iff_sats is_nat_case_iff_sats is_eclose_iff_sats sep_rules | simp add:assms)+

synthesize "is_dc_witness" from_schematic

manual_arity for "is_dc_witness_fm"
  unfolding is_dc_witness_fm_def apply (subst arity_transrec_fm)
       apply (simp add:arity) defer 3
      apply (simp add:arity) defer
     apply (subst arity_is_nat_case_fm)
           apply (simp add:arity del:arity_transrec_fm) prefer 5
  by (simp add:arity del:arity_transrec_fm)+

definition dcwit_body :: "[i,i,i,i,i] \<Rightarrow> o" where
  "dcwit_body(A,a,g,R) \<equiv> \<lambda>p. snd(p) = dc_witness(fst(p), A, a, g, R)"

relativize functional "dcwit_body" "dcwit_body_rel"
relationalize "dcwit_body_rel" "is_dcwit_body"

synthesize "is_dcwit_body" from_definition assuming "nonempty"
arity_theorem for "is_dcwit_body_fm"

context M_replacement
begin

lemma dc_witness_closed[intro,simp]:
  assumes "M(n)" "M(A)" "M(a)" "M(s)" "M(R)" "n\<in>nat"
  shows "M(dc_witness(n,A,a,s,R))"
  using \<open>n\<in>nat\<close>
proof(induct)
  case 0
  with \<open>M(a)\<close>
  show ?case
    unfolding dc_witness_def by simp
next
  case (succ x)
  with assms
  have "M(dc_witness(x,A,a,s,R))" (is "M(?b)")
    by simp
  moreover from this assms
  have "M(({?b}\<times>A)\<inter>R)" (is "M(?X)") by auto
  moreover
  have "{x\<in>A. \<langle>?b,x\<rangle>\<in>R} = {snd(y) . y\<in>?X}" (is "_ = ?Y")
    by(intro equalityI subsetI,force,auto)
  moreover from calculation
  have "M(?Y)"
    using lam_replacement_snd lam_replacement_imp_strong_replacement RepFun_closed
      snd_closed[OF transM]
    by auto
  ultimately
  show ?case
    using \<open>M(s)\<close> apply_closed
    unfolding dc_witness_def by simp
qed

lemma dc_witness_rel_char:
  assumes "M(A)"
  shows "dc_witness_rel(M,n,A,a,s,R) = dc_witness(n,A,a,s,R)"
proof -
  from assms
  have "{x \<in> A . \<langle>rec, x\<rangle> \<in> R} =  {x \<in> A . M(x) \<and> \<langle>rec, x\<rangle> \<in> R}" for rec
    by (auto dest:transM)
  then
  show ?thesis
    unfolding dc_witness_def dc_witness_rel_def by simp
qed

lemma (in M_basic) first_section_closed:
  assumes
    "M(A)" "M(a)" "M(R)"
  shows "M({x \<in> A . \<langle>a, x\<rangle> \<in> R})"
proof -
  have "{x \<in> A . \<langle>a, x\<rangle> \<in> R} = range({a} \<times> range(R) \<inter> R) \<inter> A"
    by (intro equalityI) auto
  with assms
  show ?thesis
    by simp
qed

lemma witness_into_A [TC]:
  assumes "a\<in>A"
    "\<forall>X[M]. X\<noteq>0 \<and> X\<subseteq>A \<longrightarrow> s`X\<in>A"
    "\<forall>y\<in>A. {x\<in>A. \<langle>y,x\<rangle>\<in>R } \<noteq> 0" "n\<in>nat"
    "M(A)" "M(a)" "M(s)" "M(R)"
  shows "dc_witness(n, A, a, s, R)\<in>A"
  using \<open>n\<in>nat\<close>
proof(induct n)
  case 0
  then show ?case using \<open>a\<in>A\<close> by simp
next
  case (succ x)
  with succ assms(1,3-)
  show ?case
    using nat_into_M first_section_closed
    by (simp, rule_tac rev_subsetD, rule_tac assms(2)[rule_format])
      auto
qed

end \<comment> \<open>\<^locale>\<open>M_replacement\<close>\<close>

locale M_DC = M_trancl + M_replacement + M_eclose +
  assumes
    separation_is_dcwit_body:
    "M(A) \<Longrightarrow> M(a) \<Longrightarrow> M(g) \<Longrightarrow> M(R) \<Longrightarrow> separation(M,is_dcwit_body(M, A, a, g, R))"
    and
    dcwit_replacement:"Ord(na) \<Longrightarrow>
    M(na) \<Longrightarrow>
    M(A) \<Longrightarrow>
    M(a) \<Longrightarrow>
    M(s) \<Longrightarrow>
    M(R) \<Longrightarrow>
    transrec_replacement
     (M, \<lambda>n f ntc.
            is_nat_case
             (M, a,
              \<lambda>m bmfm.
                 \<exists>fm[M]. \<exists>cp[M].
                    is_apply(M, f, m, fm) \<and>
                    is_Collect(M, A, \<lambda>x. \<exists>fmx[M]. (M(x) \<and> fmx \<in> R) \<and> pair(M, fm, x, fmx), cp) \<and>
                    is_apply(M, s, cp, bmfm),
              n, ntc),na)"
begin

lemma is_dc_witness_iff:
  assumes "Ord(na)" "M(na)" "M(A)" "M(a)" "M(s)" "M(R)" "M(res)"
  shows "is_dc_witness(M, na, A, a, s, R, res) \<longleftrightarrow> res = dc_witness_rel(M, na, A, a, s, R)"
proof -
  note assms
  moreover from this
  have "{x \<in> A . M(x) \<and> \<langle>f, x\<rangle> \<in> R} = {x \<in> A . \<langle>f, x\<rangle> \<in> R}" for f
    by (auto dest:transM)
  moreover from calculation
  have "M(fm) \<Longrightarrow> M({x \<in> A . M(x) \<and> \<langle>fm, x\<rangle> \<in> R})" for fm
    using first_section_closed by (auto dest:transM)
  moreover from calculation
  have "M(x) \<Longrightarrow> M(z) \<Longrightarrow> M(mesa) \<Longrightarrow>
    (\<exists>ya[M]. pair(M, x, ya, z) \<and>
      is_wfrec(M, \<lambda>n f. is_nat_case(M, a, \<lambda>m bmfm. \<exists>fm[M]. is_apply(M, f, m, fm) \<and>
        is_apply(M, s, {x \<in> A . \<langle>fm, x\<rangle> \<in> R}, bmfm), n), mesa, x, ya))
    \<longleftrightarrow>
    (\<exists>y[M]. pair(M, x, y, z) \<and>
      is_wfrec(M, \<lambda>n f. is_nat_case(M, a,
        \<lambda>m bmfm.
          \<exists>fm[M]. \<exists>cp[M]. is_apply(M, f, m, fm) \<and>
            is_Collect(M, A, \<lambda>x. M(x) \<and> \<langle>fm, x\<rangle> \<in> R, cp) \<and>  is_apply(M, s, cp, bmfm),n),
        mesa, x, y))" for x z mesa by simp
  moreover from calculation
  show ?thesis
    using assms dcwit_replacement[of na A a s R]
    unfolding is_dc_witness_def dc_witness_rel_def
    by (rule_tac recursor_abs) (auto dest:transM)
qed

lemma dcwit_body_abs:
  "fst(x) \<in> \<omega> \<Longrightarrow> M(A) \<Longrightarrow> M(a) \<Longrightarrow> M(g) \<Longrightarrow> M(R) \<Longrightarrow> M(x) \<Longrightarrow>
   is_dcwit_body(M,A,a,g,R,x) \<longleftrightarrow> dcwit_body(A,a,g,R,x)"
  using pair_in_M_iff apply_closed transM[of _ A]
    is_dc_witness_iff[of "fst(x)" "A" "a" "g" "R" "snd(x)"]
    fst_snd_closed dc_witness_closed
  unfolding dcwit_body_def is_dcwit_body_def
  by (auto dest:transM simp:absolut dc_witness_rel_char del:bexI intro!:bexI)

lemma Lambda_dc_witness_closed:
  assumes "g \<in> Pow\<^bsup>M\<^esup>(A)-{0} \<rightarrow> A" "a\<in>A" "\<forall>y\<in>A. {x \<in> A . \<langle>y, x\<rangle> \<in> R} \<noteq> 0"
    "M(g)" "M(A)" "M(a)" "M(R)"
  shows "M(\<lambda>n\<in>nat. dc_witness(n,A,a,g,R))"
proof -
  from assms
  have "(\<lambda>n\<in>nat. dc_witness(n,A,a,g,R)) = {p \<in> \<omega> \<times> A . is_dcwit_body(M,A,a,g,R,p)}"
    using witness_into_A[of a A g R]
      Pow_rel_char apply_type[of g "{x \<in> Pow(A) . M(x)}-{0}" "\<lambda>_.A"]
    unfolding lam_def split_def
    apply (intro equalityI subsetI)
     apply (auto) (* slow *)
    by (subst dcwit_body_abs, simp_all add:transM[of _ \<omega>] dcwit_body_def,
        subst (asm) dcwit_body_abs, auto dest:transM simp:dcwit_body_def)
      (* by (intro equalityI subsetI, auto) (* Extremely slow *)
    (subst dcwit_body_abs, simp_all add:transM[of _ \<omega>] dcwit_body_def,
      subst (asm) dcwit_body_abs, auto dest:transM simp:dcwit_body_def) *)
  with assms
  show ?thesis
    using separation_is_dcwit_body dc_witness_rel_char unfolding split_def by simp
qed

lemma witness_related:
  assumes "a\<in>A"
    "\<forall>X[M]. X\<noteq>0 \<and> X\<subseteq>A \<longrightarrow> s`X\<in>X"
    "\<forall>y\<in>A. {x\<in>A. \<langle>y,x\<rangle>\<in>R } \<noteq> 0" "n\<in>nat"
    "M(a)" "M(A)" "M(s)" "M(R)" "M(n)"
  shows "\<langle>dc_witness(n, A, a, s, R),dc_witness(succ(n), A, a, s, R)\<rangle>\<in>R"
proof -
  note assms
  moreover from this
  have "(\<forall>X[M]. X\<noteq>0 \<and> X\<subseteq>A \<longrightarrow> s`X\<in>A)" by auto
  moreover from calculation
  have "dc_witness(n, A, a, s, R)\<in>A" (is "?x \<in> A")
    using witness_into_A[of _ _ s R n] by simp
  moreover from assms
  have "M({x \<in> A . \<langle>dc_witness(n, A, a, s, R), x\<rangle> \<in> R})"
    using first_section_closed[of A "dc_witness(n, A, a, s, R)"]
    by simp
  ultimately
  show ?thesis by auto
qed

lemma witness_funtype:
  assumes "a\<in>A"
    "\<forall>X[M]. X\<noteq>0 \<and> X\<subseteq>A \<longrightarrow> s`X \<in> A"
    "\<forall>y\<in>A. {x\<in>A. \<langle>y,x\<rangle>\<in>R} \<noteq> 0"
    "M(A)" "M(a)" "M(s)" "M(R)"
  shows "(\<lambda>n\<in>nat. dc_witness(n, A, a, s, R)) \<in> nat \<rightarrow> A" (is "?f \<in> _ \<rightarrow> _")
proof -
  have "?f \<in> nat \<rightarrow> {dc_witness(n, A, a, s, R). n\<in>nat}" (is "_ \<in> _ \<rightarrow> ?B")
    using lam_funtype assms by simp
  then
  have "?B \<subseteq> A"
    using witness_into_A assms by auto
  with \<open>?f \<in> _\<close>
  show ?thesis
    using fun_weaken_type
    by simp
qed

lemma witness_to_fun:
  assumes "a\<in>A"
    "\<forall>X[M]. X\<noteq>0 \<and> X\<subseteq>A \<longrightarrow> s`X\<in>A"
    "\<forall>y\<in>A. {x\<in>A. \<langle>y,x\<rangle>\<in>R } \<noteq> 0"
    "M(A)" "M(a)" "M(s)" "M(R)"
  shows "\<exists>f \<in> nat\<rightarrow>A. \<forall>n\<in>nat. f`n =dc_witness(n,A,a,s,R)"
  using assms bexI[of _ "\<lambda>n\<in>nat. dc_witness(n,A,a,s,R)"] witness_funtype
  by simp

end \<comment> \<open>\<^locale>\<open>M_DC\<close>\<close>

locale M_library_DC = M_library + M_DC
begin

lemma AC_M_func:
  assumes "\<And>x. x \<in> A \<Longrightarrow> (\<exists>y. y \<in> x)" "M(A)"
  shows "\<exists>f \<in> A \<rightarrow>\<^bsup>M\<^esup> \<Union>(A). \<forall>x \<in> A. f`x \<in> x"
proof -
  from \<open>M(A)\<close>
  interpret mpiA:M_Pi_assumption_repl _ A "\<lambda>x . x"
    by unfold_locales (simp_all add:lam_replacement_identity)
  from \<open>M(A)\<close>
  interpret mpi2:M_Pi_assumption_repl _ "\<Union>A" "\<lambda>x . x"
    by unfold_locales (simp_all add:lam_replacement_identity)
  from \<open>M(A)\<close>
  interpret mpic_A:M_Pi_assumptions_choice _ A "\<lambda>x. x"
    apply unfold_locales
    using lam_replacement_constant lam_replacement_identity
      lam_replacement_identity[THEN lam_replacement_imp_strong_replacement]
      lam_replacement_minimum[THEN [5] lam_replacement_hcomp2]
    unfolding lam_replacement_def[symmetric]
    by auto
  from assms
  show ?thesis
    using apply_type mpiA.mem_Pi_rel_abs mpi2.mem_Pi_rel_abs function_space_rel_char
    by (rule_tac mpic_A.AC_Pi_rel[THEN rexE], simp,rename_tac f,rule_tac x=f in bexI)
     (auto, rule_tac C="\<lambda>x. x" in Pi_type,auto)
qed

lemma non_empty_family: "[| 0 \<notin> A;  x \<in> A |] ==> \<exists>y. y \<in> x"
  by (subgoal_tac "x \<noteq> 0", blast+)

lemma AC_M_func0: "0 \<notin> A \<Longrightarrow> M(A) \<Longrightarrow> \<exists>f \<in> A \<rightarrow>\<^bsup>M\<^esup> \<Union>(A). \<forall>x \<in> A. f`x \<in> x"
  by (rule AC_M_func) (simp_all add: non_empty_family)

lemma AC_M_func_Pow_rel:
  assumes "M(C)"
  shows "\<exists>f \<in> (Pow\<^bsup>M\<^esup>(C)-{0}) \<rightarrow>\<^bsup>M\<^esup> C. \<forall>x \<in> Pow\<^bsup>M\<^esup>(C)-{0}. f`x \<in> x"
proof -
  have "0\<notin>Pow\<^bsup>M\<^esup>(C)-{0}" by simp
  with assms
  obtain f where "f \<in> (Pow\<^bsup>M\<^esup>(C)-{0}) \<rightarrow>\<^bsup>M\<^esup> \<Union>(Pow\<^bsup>M\<^esup>(C)-{0})" "\<forall>x \<in> Pow\<^bsup>M\<^esup>(C)-{0}. f`x \<in> x"
    using AC_M_func0[OF \<open>0\<notin>_\<close>] by auto
  moreover
  have "x\<subseteq>C" if "x \<in> Pow\<^bsup>M\<^esup>(C) - {0}" for x
    using that Pow_rel_char assms
    by auto
  moreover
  have "\<Union>(Pow\<^bsup>M\<^esup>(C) - {0}) \<subseteq> C"
    using assms Pow_rel_char by auto
  ultimately
  show ?thesis
    using assms function_space_rel_char
    by (rule_tac bexI,auto,rule_tac Pi_weaken_type,simp_all)
qed

theorem pointed_DC:
  assumes "\<forall>x\<in>A. \<exists>y\<in>A. \<langle>x,y\<rangle>\<in> R" "M(A)" "M(R)"
  shows "\<forall>a\<in>A. \<exists>f \<in> nat\<rightarrow>\<^bsup>M\<^esup> A. f`0 = a \<and> (\<forall>n \<in> nat. \<langle>f`n,f`succ(n)\<rangle>\<in>R)"
proof -
  have 0:"\<forall>y\<in>A. {x \<in> A . \<langle>y, x\<rangle> \<in> R} \<noteq> 0"
    using assms by auto
  from \<open>M(A)\<close>
  obtain g where 1: "g \<in> Pow\<^bsup>M\<^esup>(A)-{0} \<rightarrow> A" "\<forall>X[M]. X \<noteq> 0 \<and> X \<subseteq> A \<longrightarrow> g ` X \<in> X"
    "M(g)"
    using AC_M_func_Pow_rel[of A] mem_Pow_rel_abs
      function_space_rel_char[of "Pow\<^bsup>M\<^esup>(A)-{0}" A] by auto
  then
  have 2:"\<forall>X[M]. X \<noteq> 0 \<and> X \<subseteq> A \<longrightarrow> g ` X \<in> A" by auto
  {
    fix a
    assume "a\<in>A"
    let ?f ="\<lambda>n\<in>nat. dc_witness(n,A,a,g,R)"
    note \<open>a\<in>A\<close>
    moreover from this
    have f0: "?f`0 = a" by simp
    moreover
    note \<open>a\<in>A\<close> \<open>M(g)\<close> \<open>M(A)\<close> \<open>M(R)\<close>
    moreover from calculation
    have "\<langle>?f ` n, ?f ` succ(n)\<rangle> \<in> R" if "n\<in>nat" for n
      using witness_related[OF \<open>a\<in>A\<close> _ 0, of g n] 1 that
      by (auto dest:transM)
    ultimately
    have "\<exists>f[M]. f\<in>nat \<rightarrow> A \<and> f ` 0 = a \<and> (\<forall>n\<in>nat. \<langle>f ` n, f ` succ(n)\<rangle> \<in> R)"
      using 0 1 \<open>a\<in>_\<close>
      by (rule_tac x="(\<lambda>n\<in>\<omega>. dc_witness(n, A, a, g, R))" in rexI)
        (simp_all, rule_tac witness_funtype,
          auto intro!: Lambda_dc_witness_closed dest:transM)
  }
  with \<open>M(A)\<close>
  show ?thesis using function_space_rel_char by auto
qed

lemma aux_DC_on_AxNat2 : "\<forall>x\<in>A\<times>nat. \<exists>y\<in>A. \<langle>x,\<langle>y,succ(snd(x))\<rangle>\<rangle> \<in> R \<Longrightarrow>
                  \<forall>x\<in>A\<times>nat. \<exists>y\<in>A\<times>nat. \<langle>x,y\<rangle> \<in> {\<langle>a,b\<rangle>\<in>R. snd(b) = succ(snd(a))}"
  by (rule ballI, erule_tac x="x" in ballE, simp_all)

lemma infer_snd : "c\<in> A\<times>B \<Longrightarrow> snd(c) = k \<Longrightarrow> c=\<langle>fst(c),k\<rangle>"
  by auto

corollary DC_on_A_x_nat :
  assumes "(\<forall>x\<in>A\<times>nat. \<exists>y\<in>A. \<langle>x,\<langle>y,succ(snd(x))\<rangle>\<rangle> \<in> R)" "a\<in>A" "M(A)" "M(R)"
  shows "\<exists>f \<in> nat\<rightarrow>\<^bsup>M\<^esup>A. f`0 = a \<and> (\<forall>n \<in> nat. \<langle>\<langle>f`n,n\<rangle>,\<langle>f`succ(n),succ(n)\<rangle>\<rangle>\<in>R)" (is "\<exists>x\<in>_.?P(x)")
proof -
  let ?R'="{\<langle>a,b\<rangle>\<in>R. snd(b) = succ(snd(a))}"
  from assms(1)
  have "\<forall>x\<in>A\<times>nat. \<exists>y\<in>A\<times>nat. \<langle>x,y\<rangle> \<in> ?R'"
    using aux_DC_on_AxNat2 by simp
  moreover
  note \<open>a\<in>_\<close> \<open>M(A)\<close>
  moreover from this
  have "M(A \<times> \<omega>)" by simp
  have "lam_replacement(M, \<lambda>x. succ(snd(fst(x))))"
    using lam_replacement_fst lam_replacement_snd lam_replacement_hcomp
      lam_replacement_hcomp[of _ "\<lambda>x. succ(snd(x))"]
      lam_replacement_succ by simp
  with \<open>M(R)\<close>
  have "M(?R')"
    using separation_eq lam_replacement_fst lam_replacement_snd
      lam_replacement_succ lam_replacement_hcomp lam_replacement_identity
    unfolding split_def by simp
  ultimately
  obtain f where
    F:"f\<in>nat\<rightarrow>\<^bsup>M\<^esup> A\<times>\<omega>" "f ` 0 = \<langle>a,0\<rangle>"  "\<forall>n\<in>nat. \<langle>f ` n, f ` succ(n)\<rangle> \<in> ?R'"
    using pointed_DC[of "A\<times>nat" ?R'] by blast
  with \<open>M(A)\<close>
  have "M(f)" using function_space_rel_char by simp
  then
  have "M(\<lambda>x\<in>nat. fst(f`x))" (is "M(?f)")
    using lam_replacement_fst lam_replacement_hcomp
      lam_replacement_constant lam_replacement_identity
      lam_replacement_apply
    by (rule_tac lam_replacement_imp_lam_closed, auto)
  with F \<open>M(A)\<close>
  have "?f\<in>nat\<rightarrow>\<^bsup>M\<^esup> A" "?f ` 0 = a" using function_space_rel_char by auto
  have 1:"n\<in> nat \<Longrightarrow> f`n= \<langle>?f`n, n\<rangle>" for n
  proof(induct n set:nat)
    case 0
    then show ?case using F by simp
  next
    case (succ x)
    with \<open>M(A)\<close>
    have "\<langle>f`x, f`succ(x)\<rangle> \<in> ?R'" "f`x \<in> A\<times>nat" "f`succ(x)\<in>A\<times>nat"
      using F function_space_rel_char[of \<omega> "A\<times>\<omega>"] by auto
    then
    have "snd(f`succ(x)) = succ(snd(f`x))" by simp
    with succ \<open>f`x\<in>_\<close>
    show ?case using infer_snd[OF \<open>f`succ(_)\<in>_\<close>] by auto
  qed
  have "\<langle>\<langle>?f`n,n\<rangle>,\<langle>?f`succ(n),succ(n)\<rangle>\<rangle> \<in> R" if "n\<in>nat" for n
    using that 1[of "succ(n)"] 1[OF \<open>n\<in>_\<close>] F(3) by simp
  with \<open>f`0=\<langle>a,0\<rangle>\<close>
  show ?thesis
    using rev_bexI[OF \<open>?f\<in>_\<close>] by simp
qed

lemma aux_sequence_DC :
  assumes "\<forall>x\<in>A. \<forall>n\<in>nat. \<exists>y\<in>A. \<langle>x,y\<rangle> \<in> S`n"
    "R={\<langle>\<langle>x,n\<rangle>,\<langle>y,m\<rangle>\<rangle> \<in> (A\<times>nat)\<times>(A\<times>nat). \<langle>x,y\<rangle>\<in>S`m }"
  shows "\<forall> x\<in>A\<times>nat . \<exists>y\<in>A. \<langle>x,\<langle>y,succ(snd(x))\<rangle>\<rangle> \<in> R"
  using assms Pair_fst_snd_eq by auto

lemma aux_sequence_DC2 : "\<forall>x\<in>A. \<forall>n\<in>nat. \<exists>y\<in>A. \<langle>x,y\<rangle> \<in> S`n \<Longrightarrow>
        \<forall>x\<in>A\<times>nat. \<exists>y\<in>A. \<langle>x,\<langle>y,succ(snd(x))\<rangle>\<rangle> \<in> {\<langle>\<langle>x,n\<rangle>,\<langle>y,m\<rangle>\<rangle>\<in>(A\<times>nat)\<times>(A\<times>nat). \<langle>x,y\<rangle>\<in>S`m }"
  by auto

lemma sequence_DC:
  assumes "\<forall>x\<in>A. \<forall>n\<in>nat. \<exists>y\<in>A. \<langle>x,y\<rangle> \<in> S`n" "M(A)" "M(S)"
  shows "\<forall>a\<in>A. (\<exists>f \<in> nat\<rightarrow>\<^bsup>M\<^esup> A. f`0 = a \<and> (\<forall>n \<in> nat. \<langle>f`n,f`succ(n)\<rangle>\<in>S`succ(n)))"
proof -
  from \<open>M(S)\<close>
  have "lam_replacement(M, \<lambda>x. S ` snd(snd(x)))"
    using lam_replacement_snd lam_replacement_hcomp
      lam_replacement_hcomp[of _ "\<lambda>x. S`snd(x)"] lam_replacement_apply by simp
  with assms
  have "M({x \<in> (A \<times> \<omega>) \<times> A \<times> \<omega> . (\<lambda>\<langle>\<langle>x,n\<rangle>,y,m\<rangle>. \<langle>x, y\<rangle> \<in> S ` m)(x)})"
    using lam_replacement_fst lam_replacement_snd lam_replacement_apply[of S]
      lam_replacement_product[of "\<lambda>x. fst(fst(x))" "\<lambda>x. fst(snd(x))",
        THEN [2] separation_in, of "\<lambda>x. S ` snd(snd(x))"]
      lam_replacement_hcomp unfolding split_def by simp
  with assms
  show ?thesis
    by (rule_tac ballI) (drule aux_sequence_DC2, drule DC_on_A_x_nat, auto)
qed

end \<comment> \<open>\<^locale>\<open>M_library_DC\<close>\<close>

end


theory T185
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=10,timeout=86400]
oops
end


theory T185
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z)))
"
nitpick[card nat=8,timeout=86400]
oops
end