theory Lib
imports
  Ordinary_Differential_Equations.ODE_Analysis
begin
section \<open>Generic Mathematical Lemmas\<close>
text\<open>General lemmas that don't have anything to do with dL specifically and could be fit for
  general-purpose libraries, mostly dealing with derivatives, ODEs and vectors.\<close>

lemma vec_extensionality:"(\<And>i. v$i = w$i) \<Longrightarrow> (v = w)"
  by (simp add: vec_eq_iff)

lemma norm_axis: "norm (axis i x) = norm x"
  unfolding axis_def norm_vec_def
  unfolding L2_set_def
  by(clarsimp simp add: if_distrib[where f=norm] if_distrib[where f="\<lambda>x. x\<^sup>2"] sum.If_cases)

lemma bounded_linear_axis: "bounded_linear (axis i)"
proof
  show "axis i (x + y) = axis i x + axis i y" "axis i (r *\<^sub>R x) = r *\<^sub>R axis i x" for x y :: "'a" and r
    by (auto simp: vec_eq_iff axis_def)
  show "\<exists>K. \<forall>x::'a. norm (axis i x) \<le> norm x * K"
    by (auto simp add: norm_axis intro!: exI[of _ 1])
qed

lemma bounded_linear_vec:
  fixes f::"('a::finite) \<Rightarrow> 'b::real_normed_vector \<Rightarrow> 'c::real_normed_vector"
  assumes bounds:"\<And>i. bounded_linear (f i)"
  shows "bounded_linear (\<lambda>x. \<chi> i. f i x)"
proof unfold_locales
  fix r x y
  interpret bounded_linear "f i" for i by fact
  show "(\<chi> i. f i (x + y)) = (\<chi> i. f i x) + (\<chi> i. f i y)"
    by (vector add)
  show "(\<chi> i. f i (r *\<^sub>R x)) = r *\<^sub>R (\<chi> i. f i x)"
    by (vector scaleR)
  obtain K where "norm (f i x) \<le> norm x * K i" for x i
    using bounded by metis
  then have "norm (\<chi> i. f i x) \<le> norm x * (\<Sum>i\<in>UNIV. K i)" (is "?lhs \<le> ?rhs") for x
    unfolding sum_distrib_left
    unfolding norm_vec_def
    by (auto intro!: L2_set_le_sum_abs[THEN order_trans] sum_mono simp: abs_mult)
  then show "\<exists>K. \<forall>x. norm (\<chi> i. f i x) \<le> norm x * K"
    by blast
qed

lift_definition blinfun_vec::"('a::finite \<Rightarrow> 'b::real_normed_vector \<Rightarrow>\<^sub>L real) \<Rightarrow> 'b \<Rightarrow>\<^sub>L (real ^ 'a)" is "(\<lambda>(f::('a \<Rightarrow> 'b \<Rightarrow> real)) (x::'b). \<chi> (i::'a). f i x)"
  by(rule bounded_linear_vec, simp)

lemmas blinfun_vec_simps[simp] = blinfun_vec.rep_eq

lemma continuous_blinfun_vec:"(\<And>i. continuous_on UNIV (blinfun_apply (g i))) \<Longrightarrow> continuous_on UNIV (blinfun_vec g)"
  by (simp add: continuous_on_vec_lambda)

lemma blinfun_elim:"\<And>g. (blinfun_apply (blinfun_vec g)) = (\<lambda>x. \<chi> i. g i x)"
  using blinfun_vec.rep_eq by auto

lemma sup_plus:
  fixes f g::"('b::metric_space) \<Rightarrow> real"
  assumes nonempty:"R \<noteq> {}"
  assumes bddf:"bdd_above (f ` R)"
  assumes bddg:"bdd_above (g ` R)"
  shows "(SUP x\<in>R. f x  + g x) \<le> (SUP x\<in>R. f x) + (SUP x\<in>R. g x)"
proof -
  have bddfg:"bdd_above((\<lambda>x. f x + g x ) ` R)"
    using bddf bddg apply (auto simp add: bdd_above_def)
    using add_mono_thms_linordered_semiring(1) by blast
  have eq:"(SUP x\<in>R. f x + g x) \<le> (SUP x\<in>R. f x) + (SUP x\<in>R. g x)
    \<longleftrightarrow> (\<forall>x\<in>R. (f x + g x) \<le> (SUP x\<in>R. f x) + (SUP x\<in>R. g x))"
    apply(rule cSUP_le_iff)
     subgoal by (rule nonempty)
    subgoal by (rule bddfg)
    done
  have fs:"\<And>x. x \<in> R \<Longrightarrow> f x \<le> (SUP x\<in>R. f x)"
    using bddf
    by (simp add: cSUP_upper)
  have gs:"\<And>x. x \<in> R \<Longrightarrow> g x \<le> (SUP x\<in>R. g x)"
    using bddg
    by (simp add: cSUP_upper)
  have "(\<forall>x\<in>R. (f x + g x) \<le> (SUP x\<in>R. f x) + (SUP x\<in>R. g x))"
    apply auto
    subgoal for x using fs[of x] gs[of x] by auto
    done
  then show ?thesis by (auto simp add: eq)
qed

lemma continuous_blinfun_vec':
  fixes f::"'a::{finite,linorder} \<Rightarrow> 'b::{metric_space, real_normed_vector,abs} \<Rightarrow> 'b \<Rightarrow>\<^sub>L real"
  fixes S::"'b set"
  assumes conts:"\<And>i. continuous_on UNIV (f i)"
  shows "continuous_on UNIV (\<lambda>x. blinfun_vec (\<lambda> i. f i x))"
proof (auto simp add:  LIM_def continuous_on_def)
  fix x1 and \<epsilon>::real
  assume \<epsilon>:"0 < \<epsilon>"
  let ?n = "card (UNIV::'a set)"
  have conts':" \<And>i x1 \<epsilon>. 0 < \<epsilon> \<Longrightarrow> \<exists>\<delta>>0. \<forall>x2. x2 \<noteq> x1 \<and> dist x2 x1 < \<delta> \<longrightarrow> dist (f i  x2) (f i x1) < \<epsilon>"
    using conts by(auto simp add: LIM_def continuous_on_def)
  have conts'':"\<And>i. \<exists>\<delta>>0. \<forall>x2. x2 \<noteq> x1 \<and> dist x2 x1 < \<delta> \<longrightarrow> dist (f i  x2) (f i x1) < (\<epsilon>/?n)"
    subgoal for i using conts'[of "\<epsilon> / ?n"  x1 i] \<epsilon> by auto done
  let ?f = "(\<lambda>x. blinfun_vec (\<lambda> i. f i x))"
  let ?P\<delta> = "(\<lambda> i \<delta>. (\<delta>>0 \<and> (\<forall>x2. x2 \<noteq> x1 \<and> dist x2 x1 < \<delta> \<longrightarrow> dist (f i  x2) (f i x1) < (\<epsilon>/?n))))"
  let ?\<delta>i = "(\<lambda>i. SOME \<delta>. ?P\<delta> i \<delta>)"
  have Ps:"\<And>i. \<exists>\<delta>. ?P\<delta> i \<delta>" using conts'' by auto
  have P\<delta>i:"\<And>i. ?P\<delta> i (?\<delta>i i)"
    subgoal for i using someI[of "?P\<delta> i" ] Ps[of i] by auto done
  have finU:"finite (UNIV::'a set)" by auto
  let ?\<delta> = "linorder_class.Min  (?\<delta>i ` UNIV)"
  have \<delta>0s:"\<And>i. ?\<delta>i i > 0" using P\<delta>i by blast
  then have \<delta>0s':"\<And>i. 0 < ?\<delta>i i" by auto
  have bounds:"bdd_below (?\<delta>i ` UNIV)"
    unfolding bdd_below_def
    using \<delta>0s less_eq_real_def by blast
  have \<delta>s:"\<And>i. ?\<delta> \<le> ?\<delta>i i"
    using bounds cINF_lower[of ?\<delta>i] by auto
  have finite:"finite ((?\<delta>i ` UNIV))" by auto
  have nonempty:"((?\<delta>i ` UNIV)) \<noteq> {}" by auto
  have \<delta>:"?\<delta> > 0 " using Min_gr_iff[OF finite nonempty] \<delta>0s'
    by blast
  have conts''':"\<And>i x2. x2 \<noteq> x1 \<Longrightarrow> dist x2 x1 < ?\<delta>i i \<Longrightarrow> dist (f i  x2) (f i x1) < (\<epsilon>/?n)"
    subgoal for i x2
      using conts''[of i] apply auto
      subgoal for \<delta>
        apply(erule allE[where x=x2])
        using P\<delta>i  \<delta>s[of i] apply (auto simp add: \<delta>s[of i])
        done
      done
    done
  have "\<And>x2. x2 \<noteq> x1 \<and> dist x2 x1 < ?\<delta> \<Longrightarrow> dist (blinfun_vec (\<lambda>i. f i x2)) (blinfun_vec (\<lambda>i. f i x1)) < \<epsilon>"
  proof (auto)
    fix x2
    assume ne:"x2 \<noteq> x1"
    assume dist:"\<forall>i. dist x2 x1 < ?\<delta>i i"
    have dists:"\<And>i. dist x2 x1 < ?\<delta>i i"
      subgoal for i using dist \<delta>s[of i] by auto done
    have euclid:"\<And>y. norm(?f x1 y - ?f x2 y) = (L2_set (\<lambda>i. norm(f i x1 y - f i x2 y)) UNIV)"
      by (simp add: norm_vec_def)
    have finite:"finite (UNIV::'a set)" by auto
    have nonempty: "(UNIV::'a set) \<noteq> {}" by auto
    have nonemptyB: "(UNIV::'b set) \<noteq> {}" by auto
    have nonemptyR: "(UNIV::real set) \<noteq> {}" by auto
    have SUP_leq:"\<And>f::('b \<Rightarrow> real). \<And> g::('b \<Rightarrow> real). \<And> S::'b set. S \<noteq> {} \<Longrightarrow> bdd_above (g ` S) \<Longrightarrow> (\<And>x. x \<in> (S::'b set) \<Longrightarrow> ((f x)::real) \<le> ((g x)::real)) \<Longrightarrow> (SUP x\<in>S. f x) \<le> (SUP x\<in>S. g x)"
      by(rule cSup_mono, auto)
    have SUP_sum_comm':"\<And>R S f . finite (S::'a set) \<Longrightarrow> (R::'d::metric_space set) \<noteq> {} \<Longrightarrow>
      (\<And>i x. ((f i x)::real) \<ge> 0) \<Longrightarrow>
      (\<And>i. bdd_above (f i ` R)) \<Longrightarrow>
      (SUP x\<in>R . (\<Sum>i \<in> S. f i x)) \<le> (\<Sum>i \<in> S. (SUP x\<in>R. f i x))"
    proof -
      fix  R::"'d set" and S ::"('a)set"  and f  ::"'a \<Rightarrow> 'd \<Rightarrow> real"
      assume non:"R \<noteq> {} "
      assume fin:"finite S"
      assume every:"(\<And>i x. 0 \<le> f i x)"
      assume bddF:"\<And>i. bdd_above (f i ` R)"
      then have bddF':"\<And>i. \<exists>M. \<forall>x \<in>R. f i x \<le> M "
        unfolding bdd_above_def by auto
      let ?boundP = "(\<lambda>i M. \<forall>x \<in>R. f i x \<le> M)"
      let ?bound = "(\<lambda>i::'a. SOME M. \<forall>x \<in>R. f i x \<le> M)"
      have "\<And>i. \<exists>M. ?boundP i M" using bddF' by auto
      then have each_bound:"\<And>i. ?boundP i (?bound i)"
        subgoal for i using someI[of "?boundP i"] by blast done
      let ?bigBound = "(\<lambda>F. \<Sum>i\<in>F. (?bound i))"
      have bddG:"\<And>i::'a. \<And>F. bdd_above ((\<lambda>x. \<Sum>i\<in>F. f i x) ` R)"
        subgoal for i F
          using bddF[of i] unfolding bdd_above_def apply auto
          apply(rule exI[where x="?bigBound F"])
          subgoal for M
            apply auto
            subgoal for x
              using each_bound by (simp add: sum_mono)
            done
          done
        done
      show "?thesis R S f" using fin assms
      proof (induct)
        case empty
        have "((SUP x\<in>R. \<Sum>i\<in>{}. f i x)::real) \<le> (\<Sum>i\<in>{}. SUP a\<in>R. f i a)"   by (simp add: non)
        then show ?case by auto
      next
        case (insert x F)
        have "((SUP xa\<in>R. \<Sum>i\<in>insert x F. f i xa)::real) \<le> (SUP xa\<in>R. f x xa +  (\<Sum>i\<in>F. f i xa))"
          using insert.hyps(2) by auto
        moreover have "...  \<le> (SUP xa\<in> R. f x xa) + (SUP xa\<in>R. (\<Sum>i\<in>F. f i xa))"
          by(rule sup_plus, rule non, rule bddF, rule bddG)
        moreover have "... \<le> (SUP xa\<in> R. f x xa) + (\<Sum>i\<in>F. SUP a\<in>R. f i a)"
          using add_le_cancel_left conts insert.hyps(3) by blast
        moreover have "... \<le> (\<Sum>i\<in>(insert x F). SUP a\<in>R. f i a)"
          by (simp add: insert.hyps(2))
        ultimately have "((SUP xa\<in>R. \<Sum>i\<in>insert x F. f i xa)::real) \<le> (\<Sum>i\<in>(insert x F). SUP a\<in>R. f i a)"
          by linarith
        then show ?case by auto
      qed
    qed
    have SUP_sum_comm:"\<And>R S y1 y2 . finite (S::'a set) \<Longrightarrow> (R::'b set) \<noteq> {} \<Longrightarrow> (SUP x\<in>R . (\<Sum>i \<in> S. norm(f i y1 x - f i y2 x)/norm(x))) \<le> (\<Sum>i \<in> S. (SUP x\<in>R. norm(f i y1 x - f i y2 x)/norm(x)))"
      apply(rule SUP_sum_comm')
         apply(auto)[3]
      proof (unfold bdd_above_def)
        fix R S y1 y2 i
          { fix rr :: "real \<Rightarrow> real"
            obtain bb :: "real \<Rightarrow> ('b \<Rightarrow> real) \<Rightarrow> 'b set \<Rightarrow> 'b" where
              ff1: "\<And>r f B. r \<notin> f ` B \<or> f (bb r f B) = r"
              by moura
            { assume "\<exists>r. \<not> rr r \<le> norm (f i y1 - f i y2)"
              then have "\<exists>r. norm (blinfun_apply (f i y1) (bb (rr r) (\<lambda>b. norm (blinfun_apply (f i y1) b - blinfun_apply (f i y2) b) / norm b) R) - blinfun_apply (f i y2) (bb (rr r) (\<lambda>b. norm (blinfun_apply (f i y1) b - blinfun_apply (f i y2) b) / norm b) R)) / norm (bb (rr r) (\<lambda>b. norm (blinfun_apply (f i y1) b - blinfun_apply (f i y2) b) / norm b) R) \<noteq> rr r"
                by (metis (no_types) le_norm_blinfun minus_blinfun.rep_eq)
              then have "\<exists>r. rr r \<le> r \<or> rr r \<notin> (\<lambda>b. norm (blinfun_apply (f i y1) b - blinfun_apply (f i y2) b) / norm b) ` R"
                using ff1 by meson }
              then have "\<exists>r. rr r \<le> r \<or> rr r \<notin> (\<lambda>b. norm (blinfun_apply (f i y1) b - blinfun_apply (f i y2) b) / norm b) ` R"
                by blast }
        then show "\<exists>r. \<forall>ra\<in>(\<lambda>b. norm (blinfun_apply (f i y1) b - blinfun_apply (f i y2) b) / norm b) ` R. ra \<le> r"
          by meson
      qed
    have SUM_leq:"\<And>S::('a) set. \<And> f g ::('a \<Rightarrow> real). S \<noteq> {} \<Longrightarrow> finite S \<Longrightarrow> (\<And>x. x \<in> S \<Longrightarrow> f x < g x) \<Longrightarrow> (\<Sum>x\<in>S. f x) < (\<Sum>x\<in>S. g x)"
      by(rule sum_strict_mono, auto)
    have L2:"\<And>f S. L2_set (\<lambda>x. norm(f x)) S \<le> (\<Sum>x \<in> S. norm(f x))"
      using L2_set_le_sum norm_ge_zero by metis
    have L2':"\<And>y. (L2_set (\<lambda>i. norm(f i x1 y - f i x2 y)) UNIV)/norm(y) \<le> (\<Sum>i\<in>UNIV. norm(f i x1 y - f i x2 y))/norm(y)"
      subgoal for y
        using L2[of "(\<lambda> x. f x x1 y - f x x2 y)" UNIV]
        by (auto simp add: divide_right_mono)
      done
    have "\<And>i. (SUP y\<in>UNIV.  norm((f i x1 - f i x2) y)/norm(y)) = norm(f i x1 - f i x2)"
      by (simp add: onorm_def norm_blinfun.rep_eq)
    then have each_norm:"\<And>i. (SUP y\<in>UNIV.  norm(f i x1 y - f i x2 y)/norm(y)) = norm(f i x1 - f i x2)"
      by (metis (no_types, lifting) SUP_cong blinfun.diff_left)
    have bounded_linear:"\<And>i. bounded_linear (\<lambda>y. f i x1 y - f i x2 y)"
      by (simp add: blinfun.bounded_linear_right bounded_linear_sub)
    have each_bound:"\<And>i. bdd_above ((\<lambda>y. norm(f i x1 y - f i x2 y)/norm(y)) ` UNIV)"
      using bounded_linear unfolding bdd_above_def
    proof -
      fix i :: 'a
      { fix rr :: "real \<Rightarrow> real"
        have "\<And>a r. norm (blinfun_apply (f a x1) r - blinfun_apply (f a x2) r) / norm r \<le> norm (f a x1 - f a x2)"
          by (metis le_norm_blinfun minus_blinfun.rep_eq)
        then have "\<And>r R. r \<notin> (\<lambda>r. norm (blinfun_apply (f i x1) r - blinfun_apply (f i x2) r) / norm r) ` R \<or> r \<le> norm (f i x1 - f i x2)"
          by blast
        then have "\<exists>r. rr r \<le> r \<or> rr r \<notin> range (\<lambda>r. norm (blinfun_apply (f i x1) r - blinfun_apply (f i x2) r) / norm r)"
          by blast }
      then show "\<exists>r. \<forall>ra\<in>range (\<lambda>r. norm (blinfun_apply (f i x1) r - blinfun_apply (f i x2) r) / norm r). ra \<le> r"
        by meson
    qed
    have bdd_above:"(bdd_above ((\<lambda>y. (\<Sum>i\<in>UNIV. norm(f i x1 y - f i x2 y)/norm(y))) ` UNIV))"
      using each_bound unfolding bdd_above_def apply auto
    proof -
      assume each:"(\<And>i. \<exists>M. \<forall>x. \<bar>blinfun_apply (f i x1) x - blinfun_apply (f i x2) x\<bar> / norm x \<le> M)"
      let ?boundP = "(\<lambda>i M. \<forall>x. \<bar>blinfun_apply (f i x1) x - blinfun_apply (f i x2) x\<bar> / norm x \<le> M)"
      let ?bound = "(\<lambda>i. SOME x. ?boundP i x)"
      have bounds:"\<And>i. ?boundP i (?bound i)"
        subgoal for i using each someI[of "?boundP i"] by blast done
      let ?bigBound = "\<Sum>i\<in>(UNIV::'a set). ?bound i"
      show "\<exists>M. \<forall>x. (\<Sum>i\<in>UNIV. \<bar>blinfun_apply (f i x1) x - blinfun_apply (f i x2) x\<bar> / norm x) \<le> M"
        apply(rule exI[where x= ?bigBound])
        by(auto simp add: bounds sum_mono)
    qed
    have bdd_above:"(bdd_above ((\<lambda>y. (\<Sum>i\<in>UNIV. norm(f i x1 y - f i x2 y))/norm(y)) ` UNIV))"
      using bdd_above unfolding bdd_above_def apply auto
    proof -
      fix M :: real
      assume a1: "\<forall>x. (\<Sum>i\<in>UNIV. \<bar>blinfun_apply (f i x1) x - blinfun_apply (f i x2) x\<bar> / norm x) \<le> M"
      { fix bb :: "real \<Rightarrow> 'b"
        have "\<And>b. (\<Sum>a\<in>UNIV. \<bar>blinfun_apply (f a x1) b - blinfun_apply (f a x2) b\<bar>) / norm b \<le> M"
          using a1 by (simp add: sum_divide_distrib)
        then have "\<exists>r. (\<Sum>a\<in>UNIV. \<bar>blinfun_apply (f a x1) (bb r) - blinfun_apply (f a x2) (bb r)\<bar>) / norm (bb r) \<le> r"
          by blast }
      then show "\<exists>r. \<forall>b. (\<Sum>a\<in>UNIV. \<bar>blinfun_apply (f a x1) b - blinfun_apply (f a x2) b\<bar>) / norm b \<le> r"
        by meson
    qed
    have "dist (?f x2) (?f x1) = norm((?f x2) - (?f x1))"
      by (simp add: dist_blinfun_def)
    moreover have "... = (SUP y\<in>UNIV. norm(?f x1 y - ?f x2 y)/norm(y))"
      by (metis (no_types, lifting) SUP_cong blinfun.diff_left norm_blinfun.rep_eq norm_minus_commute onorm_def)
    moreover have "... = (SUP y\<in>UNIV. (L2_set (\<lambda>i. norm(f i x1 y - f i x2 y)) UNIV)/norm(y))"
      using  euclid by auto
    moreover have "... \<le> (SUP y\<in>UNIV. (\<Sum>i\<in>UNIV. norm(f i x1 y - f i x2 y))/norm(y))"
      using L2' SUP_cong SUP_leq bdd_above by auto
    moreover have "... = (SUP y\<in>UNIV. (\<Sum>i\<in>UNIV. norm(f i x1 y - f i x2 y)/norm(y)))"
      by (simp add: sum_divide_distrib)
    moreover have "... \<le> (\<Sum>i\<in>UNIV. (SUP y\<in>UNIV.  norm(f i x1 y - f i x2 y)/norm(y)))"
      by(rule SUP_sum_comm[OF finite  nonemptyB, of x1 x2])
    moreover have "... = (\<Sum>i\<in>UNIV. norm(f i x1 - f i x2))"
      using each_norm by simp
    moreover have "... = (\<Sum>i\<in>UNIV. dist(f i x1) (f i x2))"
      by (simp add: dist_blinfun_def)
    moreover have "... < (\<Sum>i\<in>(UNIV::'a set). \<epsilon> / ?n)"
      using conts'''[OF ne dists] using SUM_leq[OF nonempty, of "(\<lambda>i.  dist (f i x1) (f i x2))" "(\<lambda>i.  \<epsilon> / ?n)"]
      by (simp add: dist_commute)
    moreover have "... = \<epsilon>"
      by(auto)
    ultimately show "dist (?f x2) (?f x1) < \<epsilon>"
      by linarith
  qed
  then show "\<exists>s>0. \<forall>x2. x2 \<noteq> x1 \<and> dist x2 x1 < s \<longrightarrow> dist (blinfun_vec (\<lambda>i. f i x2)) (blinfun_vec (\<lambda>i. f i x1)) < \<epsilon>"
    using \<delta> by blast
qed

lemma has_derivative_vec[derivative_intros]:
  assumes "\<And>i. ((\<lambda>x. f i x) has_derivative (\<lambda>h. f' i h)) F"
  shows "((\<lambda>x. \<chi> i. f i x) has_derivative (\<lambda>h. \<chi> i. f' i h)) F"
proof -
  have *: "(\<chi> i. f i x) = (\<Sum>i\<in>UNIV. axis i (f i x))" "(\<chi> i. f' i x) = (\<Sum>i\<in>UNIV. axis i (f' i x))" for x
    by (simp_all add: axis_def sum.If_cases vec_eq_iff)
  show ?thesis
    unfolding *
    by (intro has_derivative_sum bounded_linear.has_derivative[OF bounded_linear_axis] assms)
qed

lemma has_derivative_proj:
  fixes j::"('a::finite)"
  fixes f::"'a \<Rightarrow> real \<Rightarrow> real"
  assumes assm:"((\<lambda>x. \<chi> i. f i x) has_derivative (\<lambda>h. \<chi> i. f' i h)) F"
  shows "((\<lambda>x. f j x) has_derivative (\<lambda>h. f' j h)) F"
proof -
  have bounded_proj:"bounded_linear (\<lambda> x::(real^'a). x $ j)"
    by (simp add: bounded_linear_vec_nth)
  show "?thesis"
    using bounded_linear.has_derivative[OF bounded_proj, of "(\<lambda>x. \<chi> i. f i x)" "(\<lambda>h. \<chi> i. f' i h)", OF assm]
    by auto
qed

lemma has_derivative_proj':
  fixes i::"'a::finite"
  shows "\<forall>x. ((\<lambda> x. x $ i) has_derivative (\<lambda>x::(real^'a). x $ i)) (at x)"
proof -
  have bounded_proj:"bounded_linear (\<lambda> x::(real^'a). x $ i)"
    by (simp add: bounded_linear_vec_nth)
  show "?thesis"
    using bounded_proj unfolding has_derivative_def by auto
qed

lemma constant_when_zero:
  fixes v::"real \<Rightarrow> (real, 'i::finite) vec"
  assumes x0: "(v t0) $ i = x0"
  assumes sol: "(v solves_ode f) T S"
  assumes f0: "\<And>s x. s \<in> T \<Longrightarrow> f s x $ i = 0"
  assumes t0:"t0 \<in> T"
  assumes t:"t \<in> T"
  assumes convex:"convex T"
  shows "v t $ i = x0"
proof -
  from solves_odeD[OF sol]
  have deriv: "(v has_vderiv_on (\<lambda>t. f t (v t))) T" by simp
  then have "((\<lambda>t. v t $ i) has_vderiv_on (\<lambda>t. 0)) T"
    using f0
    by (auto simp: has_vderiv_on_def has_vector_derivative_def cart_eq_inner_axis
      intro!: derivative_eq_intros)
  from has_vderiv_on_zero_constant[OF convex this]
  obtain c where c:"\<And>x. x \<in> T \<Longrightarrow> v x $ i = c" by blast
  with x0 have "c = x0" "v t $ i = c"
    using t t0 c x0 by blast+
  then show ?thesis by simp
qed

lemma
  solves_ode_subset:
  assumes x: "(x solves_ode f) T X"
  assumes s: "S \<subseteq> T"
  shows "(x solves_ode f) S X"
  apply(rule solves_odeI)
   using has_vderiv_on_subset s solves_ode_vderivD x apply force
  using assms by (auto intro!: solves_odeI dest!: solves_ode_domainD)

lemma
  solves_ode_supset_range:
  assumes x: "(x solves_ode f) T X"
  assumes y: "X \<subseteq> Y"
  shows "(x solves_ode f) T Y"
  apply(rule solves_odeI)
   using has_vderiv_on_subset y solves_ode_vderivD x apply force
  using assms by (auto intro!: solves_odeI dest!: solves_ode_domainD)

lemma
  usolves_ode_subset:
  assumes x: "(x usolves_ode f from t0) T X"
  assumes s: "S \<subseteq> T"
  assumes t0: "t0 \<in> S"
  assumes S: "is_interval S"
  shows "(x usolves_ode f from t0) S X"
proof (rule usolves_odeI)
  note usolves_odeD[OF x]
  show "(x solves_ode f) S X" by (rule solves_ode_subset; fact)
  show "t0 \<in> S" "is_interval S" by(fact+)
  fix z t
  assume s: "{t0 -- t} \<subseteq> S" and z: "(z solves_ode f) {t0 -- t} X" and z0: "z t0 = x t0"
  then have "t0 \<in> {t0 -- t}" "is_interval {t0 -- t}"
    by auto
  moreover note s
  moreover have "(z solves_ode f) {t0--t} X"
    using solves_odeD[OF z] \<open>S \<subseteq> T\<close>
    by (intro solves_ode_subset_range[OF z]) force
  moreover note z0
  moreover have "t \<in> {t0 -- t}" by simp
  ultimately show "z t = x t"
    by (meson \<open>\<And>z ta T'. \<lbrakk>t0 \<in> T'; is_interval T'; T' \<subseteq> T; (z solves_ode f) T' X; z t0 = x t0; ta \<in> T'\<rbrakk> \<Longrightarrow> z ta = x ta\<close> assms(2) dual_order.trans)
qed

\<comment> \<open>Example of using lemmas above to show a lemma that could be useful for dL: The constant ODE\<close>
\<comment> \<open>0 does not change the state.\<close>
lemma example:
  fixes x t::real and i::"('sz::finite)"
  assumes "t > 0"
  shows "x = (ll_on_open.flow UNIV (\<lambda>t. \<lambda>x. \<chi> (i::('sz::finite)). 0) UNIV 0 (\<chi> i. x) t) $ i"
proof -
  let ?T = UNIV
  let ?f = "(\<lambda>t. \<lambda>x. \<chi> i::('sz::finite). 0)"
  let ?X = UNIV
  let ?t0.0 = 0
  let ?x0.0 = "\<chi> i::('sz::finite). x"
  interpret ll: ll_on_open "UNIV" "(\<lambda>t x. \<chi> i::('sz::finite). 0)" UNIV
    using gt_ex
    by unfold_locales
      (auto simp: interval_def continuous_on_def local_lipschitz_def intro!: lipschitz_intros)
  have foo1:"?t0.0 \<in> ?T" by auto
  have foo2:"?x0.0 \<in> ?X" by auto
  let ?v = "ll.flow  ?t0.0 ?x0.0"
  from ll.flow_solves_ode[OF foo1 foo2]
  have solves:"(ll.flow  ?t0.0 ?x0.0 solves_ode ?f) (ll.existence_ivl  ?t0.0 ?x0.0) ?X"  by (auto)
  then have solves:"(?v solves_ode ?f) (ll.existence_ivl  ?t0.0 ?x0.0) ?X" by auto
  have thex0: "(?v ?t0.0) $ (i::('sz::finite)) = x" by auto
  have sol_help: "(?v solves_ode ?f) (ll.existence_ivl  ?t0.0 ?x0.0) ?X" using solves by auto
  have ivl:"ll.existence_ivl ?t0.0 ?x0.0 = UNIV"
    by (rule ll.existence_ivl_eq_domain)
       (auto intro!: exI[where x=0] simp: vec_eq_iff)
  have sol: "(?v solves_ode ?f) UNIV ?X" using solves ivl by auto
  have thef0: "\<And>t x. ?f t x $ i = 0" by auto
  from constant_when_zero [OF thex0 sol thef0]
  have "?v t $ i = x"
    by auto
  thus ?thesis by auto
 qed

lemma MVT_ivl:
  fixes f::"'a::ordered_euclidean_space\<Rightarrow>'b::ordered_euclidean_space"
  assumes fderiv: "\<And>x. x \<in> D \<Longrightarrow> (f has_derivative J x) (at x within D)"
  assumes J_ivl: "\<And>x. x \<in> D \<Longrightarrow> J x u \<ge> J0"
  assumes line_in: "\<And>x. x \<in> {0..1} \<Longrightarrow> a + x *\<^sub>R u \<in> D"
  shows "f (a + u) - f a \<ge> J0"
proof -
  from MVT_corrected[OF fderiv line_in] obtain t where
    t: "t\<in>Basis \<rightarrow> {0<..<1}" and
    mvt: "f (a + u) - f a = (\<Sum>i\<in>Basis. (J (a + t i *\<^sub>R u) u \<bullet> i) *\<^sub>R i)"
    by auto
  note mvt
  also have "\<dots> \<ge> J0"
  proof -
    have J: "\<And>i. i \<in> Basis \<Longrightarrow> J0 \<le> J (a + t i *\<^sub>R u) u"
      using J_ivl t line_in by (auto simp: Pi_iff)
    show ?thesis
      using J
      unfolding atLeastAtMost_iff eucl_le[where 'a='b]
      by auto
  qed
  finally show ?thesis .
qed

lemma MVT_ivl':
  fixes f::"'a::ordered_euclidean_space\<Rightarrow>'b::ordered_euclidean_space"
  assumes fderiv: "(\<And>x. x \<in> D \<Longrightarrow> (f has_derivative J x) (at x within D))"
  assumes J_ivl: "\<And>x. x \<in> D \<Longrightarrow> J x (a - b) \<ge> J0"
  assumes line_in: "\<And>x. x \<in> {0..1} \<Longrightarrow> b + x *\<^sub>R (a - b) \<in> D"
  shows "f a \<ge> f b + J0"
proof -
  have "f (b + (a - b)) - f b \<ge> J0"
    apply (rule MVT_ivl[OF fderiv ])
      apply assumption
     apply (rule J_ivl) apply assumption
    using line_in
    apply (auto simp: diff_le_eq le_diff_eq ac_simps)
    done
  thus ?thesis
    by (auto simp: diff_le_eq le_diff_eq ac_simps)
qed
end


(* Title: thys/HaltingProblems_K_H.thy
   Author: Franz Regensburger (FABR) 02/2022
 *)

subsection \<open>Undecidability of Halting Problems\<close>

theory HaltingProblems_K_H
  imports
    SimpleGoedelEncoding
    SemiIdTM
    TuringReducible

begin

(* -------------------------------------------------------------------------- *)

(*
declare adjust.simps[simp del]

declare seq_tm.simps [simp del]
declare shift.simps[simp del]
declare composable_tm.simps[simp del]
declare step.simps[simp del]
declare steps.simps[simp del]
*)

subsubsection \<open>A locale for variations of the Halting Problem\<close>

text \<open>
  The following locale assumes that there is an injective coding function \<open>t2c\<close>
  from Turing machines to natural numbers. In this locale, we will show that the
  Special Halting Problem K1 and the General Halting Problem H1 are not Turing decidable.
\<close>

locale hpk =
  fixes t2c :: "tprog0 \<Rightarrow> nat"
  assumes
    t2c_inj: "inj t2c"

begin

text \<open>The function @{term tm_to_nat} is a witness that the locale hpk is inhabited.\<close>

interpretation tm_to_nat: hpk "tm_to_nat :: tprog0 \<Rightarrow> nat"
proof unfold_locales
  show "inj tm_to_nat" by (rule inj_tm_to_nat)
qed

text \<open>We define the function @{term c2t} as the unique inverse of the
injective function  @{term t2c}.
\<close>

(* Note 1:
 * It does not matter how we define c2t n if \<not>(\<exists>p. t2c p = n).
 * We never need to know that value
 * since we are only interested in the equation
 *
 *   "c2t (t2c p) = p"
 *)

(* Note 1:
   * We use Hilbert' non-constructive operators for
   *   definite   choice \<iota> (iota)     (THE in  Isabelle/HOL)
   *   indefinite choice \<epsilon> (epsilon)  (SOME in Isabelle/HOL)
   *)

definition c2t :: "nat \<Rightarrow> instr list"
  where
    "c2t = (\<lambda>n. if (\<exists>p. t2c p = n)
                 then (THE  p. t2c p = n)
                 else (SOME p. True) )"

lemma t2c_inj': "inj_on t2c {x. True}"
  by (auto simp add: t2c_inj )

lemma c2t_comp_t2c_eq: "c2t (t2c p) = p"
proof -
  have "\<forall>p\<in>{x. True}. c2t (t2c p) = p"
  proof (rule encode_decode_A_eq[OF t2c_inj'])
    show "c2t = (\<lambda>w. if \<exists>t\<in>{x. True}. t2c t = w then THE t. t \<in> {x. True} \<and> t2c t = w else SOME t. t \<in> {x. True})"
      by (auto simp add: c2t_def)
  qed
  then show ?thesis by auto
qed

subsubsection \<open>Undecidability of the Special Halting Problem K1\<close>

(* Just as a reminder:

    definition TMC_has_num_res :: "tprog0 \<Rightarrow> nat list \<Rightarrow> bool"

      where
        "TMC_has_num_res p ns \<equiv>
         \<lbrace> \<lambda>tap. tap = ([], <ns>) \<rbrace> p \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"

    lemma TMC_yields_num_res_unfolded_into_Hoare_halt:

      "TMC_yields_num_res tm ns n \<equiv>
         \<lbrace>(\<lambda>tap. tap = ([], <ns>))\<rbrace> tm \<lbrace>(\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <n::nat> @ Bk\<up> l))\<rbrace>"

*)

definition K1 :: "(nat list) set"
  where
     "K1 \<equiv> {nl. (\<exists>n. nl = [n] \<and> TMC_has_num_res (c2t n) [n]) }"

text \<open>Assuming the existence of a Turing Machine K1D1, which is able to decide the set K1,
 we derive a contradiction using the machine @{term "tm_semi_id_eq0"}.
 Thus, we show that the {\em Special Halting Problem K1} is not Turing decidable.
\label{sec_K1_H1}
 The proof uses a diagonal argument.
\<close>

(* some convenience lemmas will keep the main proof quit neat *)

lemma mk_composable_decider_K1D1:
  assumes "\<exists>K1D1'. (\<forall>nl.
          (nl \<in> K1 \<longrightarrow>TMC_yields_num_res K1D1' nl (1::nat))
       \<and>  (nl \<notin> K1 \<longrightarrow>TMC_yields_num_res K1D1' nl (0::nat) ))"

  shows  "\<exists>K1D1'. (\<forall>nl. composable_tm0 K1D1' \<and>
          (nl \<in> K1 \<longrightarrow>TMC_yields_num_res K1D1' nl (1::nat))
       \<and>  (nl \<notin> K1 \<longrightarrow>TMC_yields_num_res K1D1' nl (0::nat) ))"
proof -
  from assms have
    "\<exists>K1D1'. (\<forall>nl.
          (nl \<in> K1 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc,Oc] @ Bk \<up> l)\<rbrace>)
       \<and>  (nl \<notin> K1 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>) )"
    unfolding TMC_yields_num_res_unfolded_into_Hoare_halt
    by (simp add: tape_of_nat_def)

    (* create a composable version of the potentially non-composable machine K1D1' *)

  then obtain K1D1' where
    "(\<forall>nl.
          (nl \<in> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>)
       \<and>  (nl \<notin> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>))"
    by blast

  then have "composable_tm0 (mk_composable0 K1D1') \<and> (\<forall>nl.
          (nl \<in> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> mk_composable0 K1D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>)
       \<and>  (nl \<notin> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> mk_composable0 K1D1' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>))"
    using Hoare_halt_tm_impl_Hoare_halt_mk_composable0 composable_tm0_mk_composable0 by blast

  then have "composable_tm0 (mk_composable0 K1D1') \<and> (\<forall>nl.
          (nl \<in> K1 \<longrightarrow> TMC_yields_num_res (mk_composable0 K1D1') nl (1::nat) )
       \<and>  (nl \<notin> K1 \<longrightarrow> TMC_yields_num_res (mk_composable0 K1D1') nl (0::nat) ))"
    unfolding TMC_yields_num_res_unfolded_into_Hoare_halt
    by (simp add: tape_of_nat_def)

  then show ?thesis by auto
qed

lemma res_1_fed_into_tm_semi_id_eq0_loops:
  assumes "composable_tm0 D"
    and   "TMC_yields_num_res D nl (1::nat)"
  shows   "TMC_loops (D |+| tm_semi_id_eq0) nl"
  unfolding TMC_loops_def
proof
  fix stp
  show "\<not> is_final (steps0 (1, [], <nl::nat list>) (D |+| tm_semi_id_eq0) stp)"
    using assms tm_semi_id_eq0_loops''
      Hoare_plus_unhalt Hoare_unhalt_def
      tape_of_nat_def tape_of_list_def
      TMC_yields_num_res_unfolded_into_Hoare_halt
    by simp
qed

lemma loops_imp_has_no_res: "TMC_loops tm [n] \<Longrightarrow> \<not> TMC_has_num_res tm [n]"
proof -
  assume "TMC_loops tm [n]"
  then show "\<not> TMC_has_num_res tm [n]"
    using TMC_has_num_res_iff TMC_loops_def
    by blast
qed

lemma yields_res_imp_has_res: "TMC_yields_num_res tm [n] (m::nat) \<Longrightarrow> TMC_has_num_res tm [n]"
proof -
  assume "TMC_yields_num_res tm [n] (m::nat)"
  then show "TMC_has_num_res tm [n]"
    by (metis TMC_has_num_res_iff TMC_yields_num_res_def is_finalI)
qed

lemma res_0_fed_into_tm_semi_id_eq0_yields_0:
  assumes "composable_tm0 D"
    and   "TMC_yields_num_res D nl (0::nat)"
  shows   "TMC_yields_num_res (D |+| tm_semi_id_eq0) nl 0"
  unfolding TMC_yields_num_res_unfolded_into_Hoare_halt
  using assms Hoare_plus_halt tm_semi_id_eq0_halts''
    tape_of_nat_def tape_of_list_def
    TMC_yields_num_res_unfolded_into_Hoare_halt
  by simp

(* here is the main lemma about the Halting problem K1 *)

lemma existence_of_decider_K1D1_for_K1_imp_False:
  assumes major: "\<exists>K1D1'. (\<forall>nl.
            (nl \<in> K1 \<longrightarrow>TMC_yields_num_res K1D1' nl (1::nat))
         \<and>  (nl \<notin> K1 \<longrightarrow>TMC_yields_num_res K1D1' nl (0::nat) ))"
  shows False
proof -
  (* first, create a composable version of the potentially non-composable machine K1D1' *)

  from major have
    "\<exists>K1D1'. (\<forall>nl. composable_tm0 K1D1' \<and>
            (nl \<in> K1 \<longrightarrow> TMC_yields_num_res K1D1' nl (1::nat))
         \<and>  (nl \<notin> K1 \<longrightarrow> TMC_yields_num_res K1D1' nl (0::nat) ))"
    by (rule mk_composable_decider_K1D1)

  then obtain K1D1 where
    w_K1D1: "\<forall>nl. composable_tm0 K1D1 \<and>
            (nl \<in> K1 \<longrightarrow> TMC_yields_num_res K1D1 nl (1::nat))
         \<and>  (nl \<notin> K1 \<longrightarrow> TMC_yields_num_res K1D1 nl (0::nat) )"
    by blast

  (* second, using our composable decider K1D1 we construct a machine tm_contra that will
     contradict our major assumption using a diagonal argument *)

  define tm_contra where "tm_contra = K1D1 |+| tm_semi_id_eq0"

  (* third, we derive the crucial lemma "c2t (t2c tm_contra) = tm_contra" *)
  have c2t_comp_t2c_eq_for_tm_contra: "c2t (t2c tm_contra) = tm_contra"
    by (auto simp add: c2t_comp_t2c_eq)

  (* now, we derive the contradiction *)
  show False
    (* using the classical axiom TND: A \<or> \<not>A,
   * we proof by cases: [t2c tm_contra] \<in> K1 \<or> [t2c tm_contra] \<notin> K1 *)

  proof (cases "[t2c tm_contra] \<in> K1")
    case True
    from \<open>[t2c tm_contra] \<in> K1\<close> and w_K1D1
    have "TMC_yields_num_res K1D1 [t2c tm_contra] (1::nat)"
      by auto

    then have "TMC_loops tm_contra [t2c tm_contra]"
      using res_1_fed_into_tm_semi_id_eq0_loops w_K1D1 tm_contra_def
      by blast

    then have "\<not>(TMC_has_num_res tm_contra [t2c tm_contra])"
      using loops_imp_has_no_res by blast

    then have "\<not>(TMC_has_num_res (c2t (t2c tm_contra))) [t2c tm_contra]"
      by (auto simp add: c2t_comp_t2c_eq_for_tm_contra)

    then have "[t2c tm_contra] \<notin> K1"
      by (auto simp add: K1_def)

    with  \<open>[t2c tm_contra] \<in> K1\<close> show False by auto

  next
    case False
    from \<open>[t2c tm_contra] \<notin> K1\<close> and w_K1D1
    have "TMC_yields_num_res K1D1 [t2c tm_contra] (0::nat)"
      by auto

    then have "TMC_yields_num_res tm_contra [t2c tm_contra] (0::nat)"
      using res_0_fed_into_tm_semi_id_eq0_yields_0 w_K1D1 tm_contra_def
      by auto

    then have "TMC_has_num_res tm_contra [t2c tm_contra]"
      using yields_res_imp_has_res by blast

    then have "TMC_has_num_res (c2t (t2c tm_contra)) [t2c tm_contra]"
      by (auto simp add: c2t_comp_t2c_eq_for_tm_contra)

    then have "[t2c tm_contra] \<in> K1"
      by (auto simp add: K1_def)

    with \<open>[t2c tm_contra] \<notin> K1\<close> show False by auto
  qed
qed

(* FABR NOTE:

   We are not able to show a result like "\<not>(turing_decidable H2)"

   Reason:
   Our notion of Turing decidability is based on: turing_decidable :: "(nat list) set \<Rightarrow> bool"

   The lemma of theory TuringUnComputable_H2

      lemma existence_of_decider_H2D0_for_H2_imp_False:
        assumes "\<exists>H2D0'. (\<forall>nl (tm::instr list).
                ((tm,nl) \<in> H2 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <(code tm, nl)>)\<rbrace> H2D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk\<up>l)\<rbrace>)
             \<and>  ((tm,nl) \<notin> H2 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <(code tm, nl)>)\<rbrace> H2D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @Bk\<up>l)\<rbrace>) )"
        shows False

   is about pairs (tm,nl) :: ((instr list) \<times> (nat list)) set

    definition H2 :: "((instr list) \<times> (nat list)) set"
      where
         "H2 \<equiv> {(tm,nl). TMC_has_num_res tm nl }"

   We need to derive a variation of this result
   where we use a set of lists [code tm, nl] :: (nat list) set
   that fits into our setting.

    definition H1 :: "(nat list) set"
      where
         "H1 \<equiv> {nl. (\<exists>n m. nl = [n,m] \<and> TMC_has_num_res (c2t n) [m]) }"

*)

subsubsection \<open>The Special Halting Problem K1 is reducible to the General Halting Problem H1\<close>

text \<open>The proof is  by reduction of \<open>K1\<close> to \<open>H1\<close>.
\<close>

(* Convenience lemmas for the reduction of K1 to H1 *)

definition H1 :: "(nat list) set"
  where
    "H1 \<equiv> {nl. (\<exists>n m. nl = [n,m] \<and> TMC_has_num_res (c2t n) [m]) }"

lemma NilNotIn_K1: "[] \<notin> K1"
  unfolding K1_def
  using CollectD list.simps(3) by auto

lemma NilNotIn_H1: "[] \<notin> H1"
  unfolding H1_def
  using CollectD list.simps(3) by auto

lemma tm_strong_copy_total_correctness_Nil':
  "length nl = 0 \<Longrightarrow> TMC_yields_num_list_res tm_strong_copy nl []"
  unfolding TMC_yields_num_list_res_unfolded_into_Hoare_halt
proof -
  assume "length nl = 0"
  then have "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace> tm_strong_copy \<lbrace>\<lambda>tap. tap = ([Bk,Bk,Bk,Bk],[]) \<rbrace>"
    using tm_strong_copy_total_correctness_Nil by simp
  then have F1: "\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> tm_strong_copy \<lbrace>\<lambda>tap. tap = (Bk \<up> 4, <[]> @ Bk \<up> 0)\<rbrace>"
    by (metis One_nat_def Suc_1 \<open>length nl = 0\<close>
        append_Nil length_0_conv numeral_4_eq_4 numeral_eqs_upto_12(2)
        replicate_0 replicate_Suc tape_of_list_empty)
  show "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>)\<rbrace>
              tm_strong_copy
            \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[]::nat list> @ Bk \<up> l)\<rbrace>"
  proof (rule Hoare_haltI)
    fix l::"cell list"
    fix r::"cell list"
    assume "(l, r) = ([], <nl::nat list>)"
    show "\<exists>n. is_final (steps0 (1, l, r) tm_strong_copy n) \<and>
                 (\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[]::nat list> @ Bk \<up> l)) holds_for steps0 (1, l, r) tm_strong_copy n"
      by (smt F1 Hoare_haltE \<open>(l, r) = ([], <nl>)\<close> holds_for.elims(2) holds_for.simps)
  qed
qed

lemma tm_strong_copy_total_correctness_len_eq_1':
  "length nl = 1 \<Longrightarrow> TMC_yields_num_list_res tm_strong_copy nl [hd nl, hd nl]"
  unfolding TMC_yields_num_list_res_unfolded_into_Hoare_halt
proof -
  assume "length nl = 1"
  then show "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace>
                     tm_strong_copy
                   \<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[hd nl, hd nl]> @ Bk \<up> l) \<rbrace>"
    using tm_strong_copy_total_correctness_len_eq_1 by simp
qed

lemma tm_strong_copy_total_correctness_len_gt_1':
  "1 < length nl \<Longrightarrow> TMC_yields_num_list_res tm_strong_copy nl [hd nl]"
  unfolding TMC_yields_num_list_res_unfolded_into_Hoare_halt
proof -
  assume "1 < length nl"
  then have "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace>
                     tm_strong_copy
                   \<lbrace> \<lambda>tap. \<exists>l. tap = ([Bk,Bk], <[hd nl]> @ Bk \<up> l) \<rbrace>"
    using tm_strong_copy_total_correctness_len_gt_1 by simp
  then show "\<lbrace>\<lambda>tap. tap = ([], <nl::nat list>) \<rbrace>
                     tm_strong_copy
                   \<lbrace> \<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <[hd nl]> @ Bk \<up> l) \<rbrace>"
    by (smt Hoare_haltE Hoare_haltI One_nat_def Pair_inject Pair_inject holds_for.elims(2)
        holds_for.simps is_final.elims(2) replicate.simps(1) replicate.simps(2))
qed

(* --- *)

theorem turing_reducible_K1_H1: "turing_reducible K1 H1"
  unfolding turing_reducible_unfolded_into_TMC_yields_condition
proof -
  have "\<forall>nl::nat list. \<exists>ml::nat list.
              TMC_yields_num_list_res tm_strong_copy nl ml \<and> (nl \<in> K1 \<longleftrightarrow> ml \<in> H1)"
  proof
    fix nl::"nat list"
    have "length nl = 0 \<or> length nl = 1 \<or> 1 < length nl"
      by arith
    then
    show "\<exists>ml. TMC_yields_num_list_res tm_strong_copy nl ml \<and> (nl \<in> K1) = (ml \<in> H1)"
    proof
      assume "length nl = 0"
      then have "TMC_yields_num_list_res tm_strong_copy nl []"
        by (rule tm_strong_copy_total_correctness_Nil')
      moreover have "(nl \<in> K1) = ([] \<in> H1)"
        using NilNotIn_H1 NilNotIn_K1 \<open>length nl = 0\<close> length_0_conv by blast
      ultimately
      show "\<exists>ml. TMC_yields_num_list_res tm_strong_copy nl ml \<and> (nl \<in> K1) = (ml \<in> H1)" by blast
    next
      assume "length nl = 1 \<or> 1 < length nl"
      then show "\<exists>ml. TMC_yields_num_list_res tm_strong_copy nl ml \<and> (nl \<in> K1) = (ml \<in> H1)"
      proof
        assume "1 < length nl"
        then have "TMC_yields_num_list_res tm_strong_copy nl [hd nl]"
          by (rule tm_strong_copy_total_correctness_len_gt_1')
        moreover have "(nl \<in> K1) = ([hd nl] \<in> H1)"
          using H1_def K1_def \<open>1 < length nl\<close> by auto
        ultimately
        show "\<exists>ml. TMC_yields_num_list_res tm_strong_copy nl ml \<and> (nl \<in> K1) = (ml \<in> H1)" by blast
      next
        assume "length nl = 1"
        then have "TMC_yields_num_list_res tm_strong_copy nl [hd nl, hd nl]"
          by (rule tm_strong_copy_total_correctness_len_eq_1')
        moreover have "(nl \<in> K1) = ([hd nl, hd nl] \<in> H1)"
          by (smt CollectD Cons_eq_append_conv H1_def K1_def One_nat_def \<open>length nl = 1\<close>
              append_Cons diff_Suc_1 hd_Cons_tl length_0_conv length_tl list.inject
              mem_Collect_eq not_Cons_self2  self_append_conv2 zero_neq_one)
        ultimately
        show "\<exists>ml. TMC_yields_num_list_res tm_strong_copy nl ml \<and> (nl \<in> K1) = (ml \<in> H1)" by blast
      qed
    qed
  qed
  then show "\<exists>tm. \<forall>nl. \<exists>ml. TMC_yields_num_list_res tm nl ml \<and> (nl \<in> K1) = (ml \<in> H1)"
    by auto
qed

(* --------------------------------------------------------------------------------------------- *)

subsubsection \<open>Corollaries about the undecidable sets K1 and H1\<close>

corollary not_Turing_decidable_K1: "\<not>(turing_decidable K1)"
proof
  assume "turing_decidable K1"
  then have "(\<exists>D. (\<forall>nl.
            (nl \<in> K1 \<longrightarrow>TMC_yields_num_res D nl (1::nat))
         \<and>  (nl \<notin> K1 \<longrightarrow>TMC_yields_num_res D nl (0::nat) )))"
    by (auto simp add: turing_decidable_unfolded_into_TMC_yields_conditions
        tape_of_nat_def)
  with existence_of_decider_K1D1_for_K1_imp_False show False
    by blast
qed

corollary not_Turing_decidable_H1: "\<not>turing_decidable H1"
proof (rule turing_reducible_AB_and_non_decA_imp_non_decB)
  show "turing_reducible K1 H1"
    by (rule turing_reducible_K1_H1)
next
  show "\<not> turing_decidable K1"
    by (rule not_Turing_decidable_K1)
qed

(* --------------------------------------------------------------------------------------------- *)

subsubsection \<open>Proof variant: The special Halting Problem K1 is not Turing Decidable\<close>

text\<open>Assuming the existence of a Turing Machine K1D0, which is able to decide the set K1,
 we derive a contradiction using the machine @{term "tm_semi_id_gt0"}.
 Thus, we show that the {\em Special Halting Problem K1} is not Turing decidable.
 The proof uses a diagonal argument.
\label{sec_K1_v}\<close>

lemma existence_of_decider_K1D0_for_K1_imp_False:
  assumes "\<exists>K1D0'. (\<forall>nl.
          (nl \<in> K1 \<longrightarrow>TMC_yields_num_res K1D0' nl (0::nat))
       \<and>  (nl \<notin> K1 \<longrightarrow>TMC_yields_num_res K1D0' nl (1::nat) ))"
  shows False
proof -
  from assms have
    "\<exists>K1D0'. (\<forall>nl.
          (nl \<in> K1 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>)
       \<and>  (nl \<notin> K1 \<longrightarrow>\<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>) )"
    unfolding TMC_yields_num_res_unfolded_into_Hoare_halt
    by (simp add: tape_of_nat_def)
  then obtain K1D0' where
    "(\<forall>nl.
          (nl \<in> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>)
       \<and>  (nl \<notin> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>))"
    by blast

  (* first, create a composable version of the potentially non-composable machine K1D0' *)

  then have "composable_tm0 (mk_composable0 K1D0') \<and> (\<forall>nl.
          (nl \<in> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> mk_composable0 K1D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>)
       \<and>  (nl \<notin> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> mk_composable0 K1D0' \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>))"
    using Hoare_halt_tm_impl_Hoare_halt_mk_composable0 composable_tm0_mk_composable0 by blast

  then have "\<exists>K1D0. composable_tm0 K1D0 \<and> (\<forall>nl.
          (nl \<in> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>)
       \<and>  (nl \<notin> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>))"
    by blast

  then obtain K1D0 where w_K1D0: "composable_tm0 K1D0 \<and> (\<forall>nl.
          (nl \<in> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>)
       \<and>  (nl \<notin> K1 \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <nl>)\<rbrace> K1D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>))"
    by blast

  define tm_contra where "tm_contra = K1D0 |+| tm_semi_id_gt0"

  (* second, we derive some theorems from our assumptions *)
  then have c2t_comp_t2c_TM_eq_for_tm_contra: "c2t (t2c tm_contra) = tm_contra"
    by (auto simp add: c2t_comp_t2c_eq)

  (* now, we derive the contradiction *)
  show False
  proof (cases "[t2c tm_contra] \<in> K1")
    case True
    from \<open>[t2c tm_contra] \<in> K1\<close> and w_K1D0 have
      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> K1D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace>"
      by auto

    then have
      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> tm_contra \<up>"
      unfolding tm_contra_def
    proof (rule Hoare_plus_unhalt)
      show "\<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc] @ Bk \<up> l)\<rbrace> tm_semi_id_gt0 \<up>"
        by (rule tm_semi_id_gt0_loops'')
    next
      from w_K1D0 show "composable_tm0 K1D0" by auto
    qed

    then have
      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> c2t (t2c tm_contra) \<up>"
      by (auto simp add: c2t_comp_t2c_TM_eq_for_tm_contra)

    then have "\<not>\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> c2t (t2c tm_contra) \<lbrace> \<lambda>tap. (\<exists>k n l. tap = (Bk \<up> k, <n::nat> @ Bk \<up> l)) \<rbrace>"
      using Hoare_halt_impl_not_Hoare_unhalt by blast

    then have "\<not>( TMC_has_num_res (c2t (t2c tm_contra)) [t2c tm_contra])"
      by (auto simp add:  TMC_has_num_res_def)

    then have "[t2c tm_contra] \<notin> K1"
      by (auto simp add: K1_def)

    with  \<open>[t2c tm_contra] \<in> K1\<close> show False by auto
  next
    case False
    from \<open>[t2c tm_contra] \<notin> K1\<close> and w_K1D0 have
      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> K1D0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>"
      by auto

    then have
      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> tm_contra \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>"
      unfolding tm_contra_def
    proof (rule Hoare_plus_halt)
      show "\<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace> tm_semi_id_gt0 \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>"
        by (rule  tm_semi_id_gt0_halts'')
    next
      from w_K1D0 show "composable_tm0 K1D0" by auto
    qed

    then have
      "\<lbrace>\<lambda>tap. tap = ([], <[t2c tm_contra]>)\<rbrace> c2t (t2c tm_contra) \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, [Oc, Oc] @ Bk \<up> l)\<rbrace>"
      by (auto simp add: c2t_comp_t2c_TM_eq_for_tm_contra)

    then have
      " TMC_has_num_res (c2t (t2c tm_contra)) [t2c tm_contra]"

      by (auto simp add: Hoare_halt_with_OcOc_imp_std_tap tape_of_nat_def)

    then have "[t2c tm_contra] \<in> K1"
      by (auto simp add: K1_def)

    with \<open>[t2c tm_contra] \<notin> K1\<close> show False by auto
  qed
qed

end (* locale hpk *)

end


theory UnionFind
imports Main
    "Collections.Partial_Equivalence_Relation"
begin

section "firstpart of SeprefUF"

  type_synonym 'a per = "('a\<times>'a) set"

  definition "per_init D \<equiv> {(i,i) | i. i\<in>D}"
  definition [simp]: "per_compare R a b \<equiv> (a,b)\<in>R"

  definition per_init' :: "nat \<Rightarrow> nat per" where "per_init' n \<equiv> {(i,i) |i. i<n}"

  lemma per_init_of_nat_range: "per_init {i. i<N} = per_init' N"
    by (auto simp: per_init_def per_init'_def)

  lemma per_init_per[simp, intro!]:
    "part_equiv (per_init D)"
    unfolding per_init_def
    by (auto simp: part_equiv_def sym_def trans_def)

  lemma per_init_self: "(a,b)\<in>per_init D \<Longrightarrow> a=b"
    unfolding per_init_def by simp

  lemma per_union_impl: "(i,j)\<in>R \<Longrightarrow> (i,j)\<in>per_union R a b"
    by (auto simp: per_union_def)

  lemma per_union_related:
    "part_equiv R \<Longrightarrow> a\<in>Domain R \<Longrightarrow> b\<in>Domain  R \<Longrightarrow> (a,b)\<in>per_union R a b"
    unfolding per_union_def
    by (auto simp: part_equiv_refl)

  lemma part_equiv_refl':
    "part_equiv R \<Longrightarrow> x\<in>Domain R \<Longrightarrow> (x,x)\<in>R"
    using part_equiv_refl[of R x] by blast

  definition per_supset_rel :: "('a per \<times> 'a per) set" where
    "per_supset_rel
      \<equiv> {(p1,p2). p1 \<inter> Domain p2 \<times> Domain p2 = p2 \<and> p1 - (Domain p2 \<times> Domain p2) \<subseteq> Id}"

  lemma per_supset_rel_dom: "(p1, p2) \<in> per_supset_rel \<Longrightarrow> Domain p1 \<supseteq> Domain p2"
    by (auto simp: per_supset_rel_def)

  lemma per_supset_compare:
    "(p1, p2) \<in> per_supset_rel \<Longrightarrow> x1\<in>Domain p2 \<Longrightarrow> x2\<in>Domain p2 \<Longrightarrow> per_compare p1 x1 x2 \<longleftrightarrow> per_compare p2 x1 x2"
    by (auto simp: per_supset_rel_def)

  lemma per_supset_union: "(p1, p2) \<in> per_supset_rel \<Longrightarrow> x1\<in>Domain p2 \<Longrightarrow> x2\<in>Domain p2 \<Longrightarrow>
    (per_union p1 x1 x2, per_union p2 x1 x2) \<in> per_supset_rel"
    apply (clarsimp simp: per_supset_rel_def per_union_def Domain_unfold )
    apply (intro subsetI conjI)
    apply blast
    apply force
    done

end


(*  Author:  Florian Haftmann, TUM
*)

section \<open>Proof of concept for algebraically founded bit word types\<close>

theory Word_Type
  imports
    Main
    "HOL-Library.Type_Length"
begin

subsection \<open>Truncating bit representations of numeric types\<close>

class semiring_bits = semiring_div_parity +
  assumes semiring_bits: "(1 + 2 * a) mod of_nat (2 * n) = 1 + 2 * (a mod of_nat n)"
begin

definition bitrunc :: "nat \<Rightarrow> 'a \<Rightarrow> 'a"
  where bitrunc_eq_mod: "bitrunc n a = a mod of_nat (2 ^ n)"

lemma bitrunc_bitrunc [simp]:
  "bitrunc n (bitrunc n a) = bitrunc n a"
  by (simp add: bitrunc_eq_mod)

lemma bitrunc_0 [simp]:
  "bitrunc 0 a = 0"
  by (simp add: bitrunc_eq_mod)

lemma bitrunc_Suc [simp]:
  "bitrunc (Suc n) a = bitrunc n (a div 2) * 2 + a mod 2"
proof -
  define b and c
    where "b = a div 2" and "c = a mod 2"
  then have a: "a = b * 2 + c"
    and "c = 0 \<or> c = 1"
    by (simp_all add: div_mult_mod_eq parity)
  from \<open>c = 0 \<or> c = 1\<close>
  have "bitrunc (Suc n) (b * 2 + c) = bitrunc n b * 2 + c"
  proof
    assume "c = 0"
    moreover have "(2 * b) mod (2 * 2 ^ n) = 2 * (b mod 2 ^ n)"
      by (simp add: mod_mult_mult1)
    ultimately show ?thesis
      by (simp add: bitrunc_eq_mod ac_simps)
  next
    assume "c = 1"
    with semiring_bits [of b "2 ^ n"] show ?thesis
      by (simp add: bitrunc_eq_mod ac_simps)
  qed
  with a show ?thesis
    by (simp add: b_def c_def)
qed

lemma bitrunc_of_0 [simp]:
  "bitrunc n 0 = 0"
  by (simp add: bitrunc_eq_mod)

lemma bitrunc_plus:
  "bitrunc n (bitrunc n a + bitrunc n b) = bitrunc n (a + b)"
  by (simp add: bitrunc_eq_mod mod_add_eq)

lemma bitrunc_of_1_eq_0_iff [simp]:
  "bitrunc n 1 = 0 \<longleftrightarrow> n = 0"
  by (induct n) simp_all

end

instance nat :: semiring_bits
  by standard (simp add: mod_Suc Suc_double_not_eq_double)

instance int :: semiring_bits
  by standard (simp add: pos_zmod_mult_2)

lemma bitrunc_uminus:
  fixes k :: int
  shows "bitrunc n (- (bitrunc n k)) = bitrunc n (- k)"
  by (simp add: bitrunc_eq_mod mod_minus_eq)

lemma bitrunc_minus:
  fixes k l :: int
  shows "bitrunc n (bitrunc n k - bitrunc n l) = bitrunc n (k - l)"
  by (simp add: bitrunc_eq_mod mod_diff_eq)

lemma bitrunc_nonnegative [simp]:
  fixes k :: int
  shows "bitrunc n k \<ge> 0"
  by (simp add: bitrunc_eq_mod)

definition signed_bitrunc :: "nat \<Rightarrow> int \<Rightarrow> int"
  where signed_bitrunc_eq_bitrunc:
    "signed_bitrunc n k = bitrunc (Suc n) (k + 2 ^ n) - 2 ^ n"

lemma signed_bitrunc_eq_bitrunc':
  assumes "n > 0"
  shows "signed_bitrunc (n - Suc 0) k = bitrunc n (k + 2 ^ (n - 1)) - 2 ^ (n - 1)"
  using assms by (simp add: signed_bitrunc_eq_bitrunc)

lemma signed_bitrunc_0 [simp]:
  "signed_bitrunc 0 k = - (k mod 2)"
proof (cases "even k")
  case True
  then have "odd (k + 1)"
    by simp
  then have "(k + 1) mod 2 = 1"
    by (simp add: even_iff_mod_2_eq_zero)
  with True show ?thesis
    by (simp add: signed_bitrunc_eq_bitrunc)
next
  case False
  then show ?thesis
    by (simp add: signed_bitrunc_eq_bitrunc odd_iff_mod_2_eq_one)
qed

lemma signed_bitrunc_Suc [simp]:
  "signed_bitrunc (Suc n) k = signed_bitrunc n (k div 2) * 2 + k mod 2"
  using zero_not_eq_two by (simp add: signed_bitrunc_eq_bitrunc algebra_simps)

lemma signed_bitrunc_of_0 [simp]:
  "signed_bitrunc n 0 = 0"
  by (simp add: signed_bitrunc_eq_bitrunc bitrunc_eq_mod)

lemma signed_bitrunc_of_minus_1 [simp]:
  "signed_bitrunc n (- 1) = - 1"
  by (induct n) simp_all

lemma signed_bitrunc_eq_iff_bitrunc_eq:
  assumes "n > 0"
  shows "signed_bitrunc (n - Suc 0) k = signed_bitrunc (n - Suc 0) l \<longleftrightarrow> bitrunc n k = bitrunc n l" (is "?P \<longleftrightarrow> ?Q")
proof -
  from assms obtain m where m: "n = Suc m"
    by (cases n) auto
  show ?thesis
  proof
    assume ?Q
    have "bitrunc (Suc m) (k + 2 ^ m) =
      bitrunc (Suc m) (bitrunc (Suc m) k + bitrunc (Suc m) (2 ^ m))"
      by (simp only: bitrunc_plus)
    also have "\<dots> =
      bitrunc (Suc m) (bitrunc (Suc m) l + bitrunc (Suc m) (2 ^ m))"
      by (simp only: \<open>?Q\<close> m [symmetric])
    also have "\<dots> = bitrunc (Suc m) (l + 2 ^ m)"
      by (simp only: bitrunc_plus)
    finally show ?P
      by (simp only: signed_bitrunc_eq_bitrunc m) simp
  next
    assume ?P
    with assms have "(k + 2 ^ (n - Suc 0)) mod 2 ^ n = (l + 2 ^ (n - Suc 0)) mod 2 ^ n"
      by (simp add: signed_bitrunc_eq_bitrunc' bitrunc_eq_mod)
    then have "(i + (k + 2 ^ (n - Suc 0))) mod 2 ^ n = (i + (l + 2 ^ (n - Suc 0))) mod 2 ^ n" for i
      by (metis mod_add_eq)
    then have "k mod 2 ^ n = l mod 2 ^ n"
      by (metis add_diff_cancel_right' uminus_add_conv_diff)
    then show ?Q
      by (simp add: bitrunc_eq_mod)
  qed
qed

subsection \<open>Bit strings as quotient type\<close>

subsubsection \<open>Basic properties\<close>

quotient_type (overloaded) 'a word = int / "\<lambda>k l. bitrunc LENGTH('a) k = bitrunc LENGTH('a::len0) l"
  by (auto intro!: equivpI reflpI sympI transpI)

instantiation word :: (len0) "{semiring_numeral, comm_semiring_0, comm_ring}"
begin

lift_definition zero_word :: "'a word"
  is 0
  .

lift_definition one_word :: "'a word"
  is 1
  .

lift_definition plus_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  is plus
  by (subst bitrunc_plus [symmetric]) (simp add: bitrunc_plus)

lift_definition uminus_word :: "'a word \<Rightarrow> 'a word"
  is uminus
  by (subst bitrunc_uminus [symmetric]) (simp add: bitrunc_uminus)

lift_definition minus_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  is minus
  by (subst bitrunc_minus [symmetric]) (simp add: bitrunc_minus)

lift_definition times_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  is times
  by (auto simp add: bitrunc_eq_mod intro: mod_mult_cong)

instance
  by standard (transfer; simp add: algebra_simps)+

end

instance word :: (len) comm_ring_1
  by standard (transfer; simp)+

subsubsection \<open>Conversions\<close>

context semiring_1
begin

lift_definition unsigned :: "'b::len0 word \<Rightarrow> 'a"
  is "of_nat \<circ> nat \<circ> bitrunc LENGTH('b)"
  by simp

lemma unsigned_0 [simp]:
  "unsigned 0 = 0"
  by transfer simp

end

context semiring_char_0
begin

lemma word_eq_iff_unsigned:
  "a = b \<longleftrightarrow> unsigned a = unsigned b"
  by safe (transfer; simp add: eq_nat_nat_iff)

end

context ring_1
begin

lift_definition signed :: "'b::len word \<Rightarrow> 'a"
  is "of_int \<circ> signed_bitrunc (LENGTH('b) - 1)"
  by (simp add: signed_bitrunc_eq_iff_bitrunc_eq [symmetric])

lemma signed_0 [simp]:
  "signed 0 = 0"
  by transfer simp

end

lemma unsigned_of_nat [simp]:
  "unsigned (of_nat n :: 'a word) = bitrunc LENGTH('a::len) n"
  by transfer (simp add: nat_eq_iff bitrunc_eq_mod zmod_int)

lemma of_nat_unsigned [simp]:
  "of_nat (unsigned a) = a"
  by transfer simp

lemma of_int_unsigned [simp]:
  "of_int (unsigned a) = a"
  by transfer simp

context ring_char_0
begin

lemma word_eq_iff_signed:
  "a = b \<longleftrightarrow> signed a = signed b"
  by safe (transfer; auto simp add: signed_bitrunc_eq_iff_bitrunc_eq)

end

lemma signed_of_int [simp]:
  "signed (of_int k :: 'a word) = signed_bitrunc (LENGTH('a::len) - 1) k"
  by transfer simp

lemma of_int_signed [simp]:
  "of_int (signed a) = a"
  by transfer (simp add: signed_bitrunc_eq_bitrunc bitrunc_eq_mod mod_simps)

subsubsection \<open>Properties\<close>

subsubsection \<open>Division\<close>

instantiation word :: (len0) modulo
begin

lift_definition divide_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  is "\<lambda>a b. bitrunc LENGTH('a) a div bitrunc LENGTH('a) b"
  by simp

lift_definition modulo_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> 'a word"
  is "\<lambda>a b. bitrunc LENGTH('a) a mod bitrunc LENGTH('a) b"
  by simp

instance ..

end

subsubsection \<open>Orderings\<close>

instantiation word :: (len0) linorder
begin

lift_definition less_eq_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> bool"
  is "\<lambda>a b. bitrunc LENGTH('a) a \<le> bitrunc LENGTH('a) b"
  by simp

lift_definition less_word :: "'a word \<Rightarrow> 'a word \<Rightarrow> bool"
  is "\<lambda>a b. bitrunc LENGTH('a) a < bitrunc LENGTH('a) b"
  by simp

instance
  by standard (transfer; auto)+

end

context linordered_semidom
begin

lemma word_less_eq_iff_unsigned:
  "a \<le> b \<longleftrightarrow> unsigned a \<le> unsigned b"
  by (transfer fixing: less_eq) (simp add: nat_le_eq_zle)

lemma word_less_iff_unsigned:
  "a < b \<longleftrightarrow> unsigned a < unsigned b"
  by (transfer fixing: less) (auto dest: preorder_class.le_less_trans [OF bitrunc_nonnegative])

end

end


(* Author: Dmitriy Traytel *)

section "Initial Normalization of the Input"

(*<*)
theory Init_Normalization
imports Pi_Regular_Exp "HOL-Library.Simps_Case_Conv"
begin
(*>*)

fun toplevel_inters where
  "toplevel_inters (Inter r s) = toplevel_inters r \<union> toplevel_inters s"
| "toplevel_inters r = {r}"

lemma toplevel_inters_nonempty[simp]:
  "toplevel_inters r \<noteq> {}"
  by (induct r) auto

lemma toplevel_inters_finite[simp]:
  "finite (toplevel_inters r)"
  by (induct r) auto

context alphabet
begin

lemma toplevel_inters_wf:
  "wf n s = (\<forall>r\<in>toplevel_inters s. wf n r)"
  by (induct s) auto

end

context project
begin

lemma toplevel_inters_lang:
  "r \<in> toplevel_inters s \<Longrightarrow> lang n s \<subseteq> lang n r"
  by (induct s) auto

lemma toplevel_inters_lang_INT:
  "lang n s = (\<Inter>r\<in>toplevel_inters s. lang n r)"
  by (induct s) auto

lemma toplevel_inters_in_lang:
  "w \<in> lang n s = (\<forall>r\<in>toplevel_inters s. w \<in> lang n r)"
  by (induct s) auto

lemma lang_flatten_INTERSECT_finite[simp]:
  "finite X \<Longrightarrow> w \<in> lang n (flatten INTERSECT X) =
    (if X = {} then w \<in> lists (\<Sigma> n) else (\<forall>r \<in> X. w \<in> lang n r))"
  unfolding lang_INTERSECT by auto

end

fun merge_distinct where
  "merge_distinct [] xs = xs"
| "merge_distinct xs [] = xs"
| "merge_distinct (a # xs) (b # ys) =
    (if a = b then merge_distinct xs (b # ys)
    else if a < b then a # merge_distinct xs (b # ys)
    else b # merge_distinct (a # xs) ys)"

lemma set_merge_distinct[simp]: "set (merge_distinct xs ys) = set xs \<union> set ys"
  by (induct xs ys rule: merge_distinct.induct) auto

lemma sorted_merge_distinct[simp]: "\<lbrakk>sorted xs; sorted ys\<rbrakk> \<Longrightarrow> sorted (merge_distinct xs ys)"
  by (induct xs ys rule: merge_distinct.induct) (auto)

lemma distinct_merge_distinct[simp]: "\<lbrakk>sorted xs; distinct xs; sorted ys; distinct ys\<rbrakk> \<Longrightarrow>
  distinct (merge_distinct xs ys)"
  by (induct xs ys rule: merge_distinct.induct) (auto)

lemma sorted_list_of_set_merge_distinct[simp]: "\<lbrakk>sorted xs; distinct xs; sorted ys; distinct ys\<rbrakk> \<Longrightarrow>
  merge_distinct xs ys = sorted_list_of_set (set xs \<union> set ys)"
  by (auto intro: sorted_distinct_set_unique)

fun zip_with_option where
  "zip_with_option f (Some a) (Some b) = Some (f a b)"
| "zip_with_option _ _ _ = None"

lemma zip_with_option_eq_Some[simp]:
  "zip_with_option f x y = Some z \<longleftrightarrow> (\<exists>a b. z = f a b \<and> x = Some a \<and> y = Some b)"
  by (induct f x y rule: zip_with_option.induct) auto

fun Pluss where
  "Pluss (Plus r s) = zip_with_option merge_distinct (Pluss r) (Pluss s)"
| "Pluss Zero = Some []"
| "Pluss Full = None"
| "Pluss r = Some [r]"

lemma Pluss_None[symmetric]: "Pluss r = None \<longleftrightarrow> Full \<in> toplevel_summands r"
  by (induct r) auto

lemma Pluss_Some: "Pluss r = Some xs \<longleftrightarrow>
  (Full \<notin> set xs \<and> xs = sorted_list_of_set (toplevel_summands r - {Zero}))"
proof (induct r arbitrary: xs)
  case (Plus r s)
  show ?case
  proof safe
    assume "Pluss (Plus r s) = Some xs"
    then obtain a b where *: "Pluss r = Some a" "Pluss s = Some b" "xs = merge_distinct a b" by auto
    with Plus(1)[of a] Plus(2)[of b]
      show "xs = sorted_list_of_set (toplevel_summands (Plus r s) - {Zero})" by (simp add: Un_Diff)
    assume "Full \<in> set xs" with Plus(1)[of a] Plus(2)[of b] * show False by (simp add: Pluss_None)
  next
    assume "Full \<notin> set (sorted_list_of_set (toplevel_summands (Plus r s) - {Zero}))"
    with Plus(1)[of "sorted_list_of_set (toplevel_summands r - {Zero})"]
      Plus(2)[of "sorted_list_of_set (toplevel_summands s - {Zero})"]
      show "Pluss (Plus r s) = Some (sorted_list_of_set (toplevel_summands (Plus r s) - {Zero}))"
        by (simp add: Un_Diff)
  qed
qed force+

fun Inters where
  "Inters (Inter r s) = zip_with_option merge_distinct (Inters r) (Inters s)"
| "Inters Zero = None"
| "Inters Full = Some []"
| "Inters r = Some [r]"

lemma Inters_None[symmetric]: "Inters r = None \<longleftrightarrow> Zero \<in> toplevel_inters r"
  by (induct r) auto

lemma Inters_Some: "Inters r = Some xs \<longleftrightarrow>
  (Zero \<notin> set xs \<and> xs = sorted_list_of_set (toplevel_inters r - {Full}))"
proof (induct r arbitrary: xs)
  case (Inter r s)
  show ?case
  proof safe
    assume "Inters (Inter r s) = Some xs"
    then obtain a b where *: "Inters r = Some a" "Inters s = Some b" "xs = merge_distinct a b" by auto
    with Inter(1)[of a] Inter(2)[of b]
      show "xs = sorted_list_of_set (toplevel_inters (Inter r s) - {Full})" by (simp add: Un_Diff)
    assume "Zero \<in> set xs" with Inter(1)[of a] Inter(2)[of b] * show False by (simp add: Inters_None)
  next
    assume "Zero \<notin> set (sorted_list_of_set (toplevel_inters (Inter r s) - {Full}))"
    with Inter(1)[of "sorted_list_of_set (toplevel_inters r - {Full})"]
      Inter(2)[of "sorted_list_of_set (toplevel_inters s - {Full})"]
      show "Inters (Inter r s) = Some (sorted_list_of_set (toplevel_inters (Inter r s) - {Full}))"
        by (simp add: Un_Diff)
  qed
qed force+

definition inPlus where
  "inPlus r s = (case Pluss (Plus r s) of None \<Rightarrow> Full | Some rs \<Rightarrow> PLUS rs)"

lemma inPlus_alt: "inPlus r s = (let X = toplevel_summands (Plus r s) - {Zero} in
  flatten PLUS (if Full \<in> X then {Full} else X))"
proof (cases "Pluss r" "Pluss s" rule: option.exhaust[case_product option.exhaust])
  case Some_Some then show ?thesis by (simp add: inPlus_def Pluss_None) (simp add: Pluss_Some Un_Diff)
qed (simp_all add: inPlus_def Pluss_None)

fun inTimes where
  "inTimes Zero _ = Zero"
| "inTimes _ Zero = Zero"
| "inTimes One r = r"
| "inTimes r One = r"
| "inTimes (Times r s) t = Times r (inTimes s t)"
| "inTimes r s = Times r s"

fun inStar where
  "inStar Zero = One"
| "inStar Full = Full"
| "inStar One = One"
| "inStar (Star r) = Star r"
| "inStar r = Star r"

definition inInter where
  "inInter r s = (case Inters (Inter r s) of None \<Rightarrow> Zero | Some rs \<Rightarrow> INTERSECT rs)"

lemma inInter_alt: "inInter r s = (let X = toplevel_inters (Inter r s) - {Full} in
  flatten INTERSECT (if Zero \<in> X then {Zero} else X))"
proof (cases "Inters r" "Inters s" rule: option.exhaust[case_product option.exhaust])
  case Some_Some then show ?thesis by (simp add: inInter_def Inters_None) (simp add: Inters_Some Un_Diff)
qed (simp_all add: inInter_def Inters_None)

fun inNot where
  "inNot Zero = Full"
| "inNot Full = Zero"
| "inNot (Not r) = r"
| "inNot (Plus r s) = Inter (inNot r) (inNot s)"
| "inNot (Inter r s) = Plus (inNot r) (inNot s)"
| "inNot r = Not r"

fun inPr where
  "inPr Zero = Zero"
| "inPr One = One"
| "inPr (Plus r s) = Plus (inPr r) (inPr s)"
| "inPr r = Pr r"

primrec inorm where
  "inorm Zero = Zero"
| "inorm Full = Full"
| "inorm One = One"
| "inorm (Atom a) = Atom a"
| "inorm (Plus r s) = Plus (inorm r) (inorm s)"
| "inorm (Times r s) = Times (inorm r) (inorm s)"
| "inorm (Star r) = inStar (inorm r)"
| "inorm (Not r) = inNot (inorm r)"
| "inorm (Inter r s) = inInter (inorm r) (inorm s)"
| "inorm (Pr r) = inPr (inorm r)"

context alphabet begin

lemma wf_inPlus[simp]: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> wf n (inPlus r s)"
  by (subst (asm) (1 2) toplevel_summands_wf) (auto simp: inPlus_alt)

lemma wf_inTimes[simp]: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> wf n (inTimes r s)"
  by (induct r s rule: inTimes.induct) auto

lemma wf_inStar[simp]: "wf n r \<Longrightarrow> wf n (inStar r)"
  by (induct r rule: inStar.induct) auto

lemma wf_inNot[simp]: "wf n r \<Longrightarrow> wf n (inNot r)"
  by (induct r rule: inNot.induct) auto

lemma wf_inPr[simp]: "wf (Suc n) r \<Longrightarrow> wf n (inPr r)"
  by (induct r rule: inPr.induct) auto

lemma wf_inorm[simp]: "wf n r \<Longrightarrow> wf n (inorm r)"
  by (induct r arbitrary: n) auto

end

context project begin

lemma lang_inTimes[simp]: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> lang n (inTimes r s) = lang n (Times r s)"
  by (induct r s rule: inTimes.induct) (auto simp: conc_assoc)

lemma lang_inStar[simp]: "wf n r \<Longrightarrow> lang n (inStar r) = lang n (Star r)"
  by (induct r rule: inStar.induct)
    (auto intro: star_if_lang dest: subsetD[OF star_subset_lists, rotated])

lemma Zero_toplevel_inters[dest]: "Zero \<in> toplevel_inters r \<Longrightarrow> lang n r = {}"
  by (metis lang.simps(1) subset_empty toplevel_inters_lang)

lemma toplevel_inters_Full: "\<lbrakk>toplevel_inters r = {Full}; wf n r\<rbrakk> \<Longrightarrow> lang n r = lists (\<Sigma> n)"
  by (metis antisym lang.simps(2) subsetI toplevel_inters.simps(3) toplevel_inters_in_lang)

lemma toplevel_inters_subset_singleton[simp]: "toplevel_inters r \<subseteq> {s} \<longleftrightarrow> toplevel_inters r = {s}"
  by (metis subset_refl subset_singletonD toplevel_inters_nonempty)

lemma lang_inInter[simp]: "\<lbrakk>wf n r; wf n s\<rbrakk> \<Longrightarrow> lang n (inInter r s) = lang n (Inter r s)"
  using lang_subset_lists[of n, unfolded lang.simps(2)[symmetric]]
    toplevel_inters_nonempty[of r] toplevel_inters_nonempty[of s]
  apply (auto 0 2 simp: inInter_alt toplevel_inters_in_lang[of _ n r] toplevel_inters_in_lang[of _ n s]
     toplevel_inters_wf[of n r] toplevel_inters_wf[of n s] Ball_def simp del: toplevel_inters_nonempty
     dest!: toplevel_inters_Full[of _ n] split: if_splits)
  by fastforce+

lemma lang_inNot[simp]: "wf n r \<Longrightarrow> lang n (inNot r) = lang n (Not r)"
  by (induct r rule: inNot.induct) (auto dest: lang_subset_lists)

lemma lang_inPr[simp]: "wf (Suc n) r \<Longrightarrow> lang n (inPr r) = lang n (Pr r)"
  by (induct r rule: inPr.induct) auto

lemma lang_inorm[simp]: "wf n r \<Longrightarrow> lang n (inorm r) = lang n r"
  by (induct r arbitrary: n) auto

end

(*<*)
end
(*>*)


(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

theory Padding
imports "~~/src/HOL/Main"
begin

definition padup :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "padup align n \<equiv> (align - n mod align) mod align"

lemma padup_dvd:
  "0 < b \<Longrightarrow> (padup b n = 0) = (b dvd n)"
unfolding padup_def
apply(subst dvd_eq_mod_eq_0)
apply(subst mod_if [where m="b - n mod b"])
apply clarsimp
apply(insert mod_less_divisor [of b n])
apply arith
done

lemma dvd_padup_add:
  "0 < x \<Longrightarrow> x dvd y + padup x y"
apply(clarsimp simp: padup_def)
apply(subst mod_if [where m="x - y mod x"])
apply(clarsimp split: split_if_asm)
apply(rule conjI)
 apply clarsimp
 apply(subst ac_simps)
 apply(subst diff_add_assoc)
  apply(rule mod_less_eq_dividend)
 apply(rule dvd_add)
  apply simp
 apply(subst mod_div_equality')
 apply(subst diff_diff_right)
  apply(subst ac_simps)
  apply(subst mult_div_cancel)
  apply simp
 apply simp
apply(auto simp: dvd_eq_mod_eq_0)
done

end


theory VC_To_FNS
  imports Main "../Three_Sat_To_Set_Cover" Graph_Theory.Digraph Graph_Theory.Arc_Walk
    "../VC_Set_To_VC_List/VC_Set_To_VC_List" "Poly_Reductions_Lib.Graph_Auxiliaries"
begin

section\<open>VC To FNS\<close>
subsubsection\<open>Preliminaries\<close>

definition "del_verts G vs = foldr (\<lambda>v G. pre_digraph.del_vert G v) vs G"

lemma e_in_arcs_del_verts_e_in_arcs:
  assumes "e \<in> arcs (del_verts G R)"
  shows "e \<in> arcs G"
  using assms unfolding del_verts_def
  by(induction R arbitrary: G)(auto simp add: pre_digraph.arcs_del_vert)

lemma foldr_del_vert:
  shows "(pre_digraph.del_vert (foldr (\<lambda>v G. pre_digraph.del_vert G v) R G) v) =
    (foldr (\<lambda>v G. pre_digraph.del_vert G v) (v#R) G)"
  by(induction R arbitrary: G)(auto)

lemma e_not_in_del_vert_head_e:
  shows "e \<notin> arcs (pre_digraph.del_vert G (head G e))"
  unfolding pre_digraph.del_vert_def by simp

lemma head_del_verts_eq_head_before:
  shows "head (del_verts G R) e = head G e"
  unfolding del_verts_def pre_digraph.del_vert_def by(induction R arbitrary: G)(auto)

lemma tail_del_verts_eq_tail_before:
  shows "tail (del_verts G R) e = tail G e"
  unfolding del_verts_def pre_digraph.del_vert_def by(induction R arbitrary: G)(auto)

lemma e_in_arcs_del_verts_impl_not_vertex_in_E:
  assumes "e \<in> arcs (del_verts G R)"
  shows "head G e \<notin> set R \<and> tail G e \<notin> set R"
  using assms tail_del_verts_eq_tail_before head_del_verts_eq_head_before
  by (induction R arbitrary: G) (force simp add: pre_digraph.arcs_del_vert del_verts_def)+

lemma e_in_arcs_not_in_R:
  assumes "e \<in> arcs G" "head G e \<notin> set R" "tail G e \<notin> set R"
  shows "e \<in> arcs (del_verts G R)"
  using assms
proof(induction R arbitrary: G)
  case Nil
  then show ?case
    unfolding del_verts_def
    by auto
next
  case (Cons a R)
  then have e_in: "e \<in> arcs (pre_digraph.del_vert G a)"
    by (simp add: pre_digraph.del_vert_def)
  then have "e \<in> arcs (foldr (\<lambda> v G. pre_digraph.del_vert G v) R G)"
    using Cons
    unfolding del_verts_def
    by (simp add: pre_digraph.head_del_vert pre_digraph.tail_del_vert)
  then show ?case
    by (metis (mono_tags, lifting) e_in del_verts_def
        foldr_del_vert head_del_verts_eq_head_before mem_Collect_eq pre_digraph.arcs_del_vert
        tail_del_verts_eq_tail_before)
qed

subsubsection \<open>Main Definitions\<close>

definition
  "is_fns (G::('a,'b) pre_digraph) (R:: 'a list)  \<equiv> \<not>(\<exists>p. pre_digraph.cycle (del_verts G R) p) "

definition
  "fns \<equiv> {(G, k). \<exists>R. wf_digraph G \<and> length R < k \<and> is_fns G R \<and> set R \<subseteq> verts G}"

definition "vc_to_fns \<equiv> \<lambda>(E, k).(if ugraph E \<and> k \<le> card (\<Union> E)
  then (\<lparr>verts = {v. v \<in> \<Union> E}, arcs = {(u, v)| u v. {u, v} \<in> E}, tail = fst, head = snd \<rparr>, k+1)
  else (\<lparr>verts = {}, arcs = {}, tail = fst, head = snd \<rparr>, 0))"

lemma else_not_in_fns:
  shows "(\<lparr>verts = {}, arcs = {}, tail = fst, head = snd \<rparr>, 0) \<notin> fns"
  using fns_def by auto

subsection \<open>From VC to FNS\<close>

context
  fixes E k assumes in_vc: "(E, k) \<in> vertex_cover"
  fixes G k' assumes G_def: "(G, k') = vc_to_fns (E, k)"
  fixes Cov assumes Cov_def: "Cov \<subseteq> \<Union> E" "card Cov \<le> k" "is_vertex_cover E Cov"
  fixes R assumes R_def: "R = set_to_list Cov"
begin

lemma G_def_2:
  shows "G = \<lparr>verts = {v. v \<in> \<Union> E}, arcs = {(u, v)| u v. {u, v} \<in> E}, tail = fst, head = snd\<rparr>"
proof -
  have ugraph: "ugraph E" "k \<le> card (\<Union> E)"
    using in_vc vertex_cover_def
    by auto
  then have "vc_to_fns (E, k)
    = (\<lparr>verts = {v. v \<in> \<Union> E}, arcs = {(u, v)| u v. {u, v} \<in> E}, tail = fst, head = snd \<rparr>, k+1)"
    by(auto simp add: vc_to_fns_def)
  then show ?thesis
    using G_def
    by simp
qed

lemma wf_digraph_G:
  shows "wf_digraph G"
  using G_def_2 by(auto simp add: wf_digraph_def)

lemma ugraph_E_card_k:
  shows "ugraph E" "k \<le> card (\<Union> E)"
  using in_vc vertex_cover_def by auto

lemma finite_E:
  shows "finite (\<Union> E)"
  using ugraph_vertex_set_finite ugraph_E_card_k by auto

lemma k_k':
  shows "k' = k+1"
  using ugraph_E_card_k G_def unfolding vc_to_fns_def by simp

lemma finite_Cov:
  shows "finite Cov"
  using Cov_def finite_E by (meson finite_subset)

lemma distinct_R:
  shows "distinct R"
  using R_def set_to_list_def distinct_set_to_list finite_Cov by auto

lemma card_R_equal:
  shows "length R = card Cov"
  using R_def set_to_list_def distinct_R distinct_card finite_Cov set_set_to_list by fastforce

lemma card_R:
  shows "length R < k+1"
  using card_R_equal Cov_def by simp

lemma in_arcs_G_imp_in_set_R:
  assumes "e \<in> arcs G"
  shows "head G e \<in> set R \<or> tail G e \<in> set R"
proof -
  obtain v u where vu_def: "v = head G e" "u = tail G e"
    by auto
  then obtain e' where e'_def: "e' = {v, u}"
    by auto
  then have "e' \<in> E"
    using G_def_2 assms vu_def
    by(auto simp add: G_def_2 insert_commute)
  then have "u \<in> Cov \<or> v \<in> Cov"
    using Cov_def e'_def
    unfolding is_vertex_cover_def
    by fast
  then show ?thesis
    using vu_def R_def finite_Cov set_set_to_list
    by auto
qed

lemma arcs_del_g_empty:
  shows "arcs (del_verts G R) = {}"
  using in_arcs_G_imp_in_set_R e_in_arcs_del_verts_impl_not_vertex_in_E
    e_in_arcs_del_verts_e_in_arcs
  by fast

lemma is_fns_R:
  shows "is_fns G R"
  using empty_arcs_impl_no_cycle arcs_del_g_empty is_fns_def by metis

lemma R_subset_verts:
  shows "set R \<subseteq> verts G"
  using R_def Cov_def G_def_2 set_set_to_list finite_Cov unfolding set_to_list_def by auto

lemma in_fns_context:
  shows "vc_to_fns (E, k) \<in> fns"
  using fns_def card_R wf_digraph_G is_fns_R k_k' G_def R_subset_verts by fastforce

end

subsection\<open>From FNS to VC\<close>

context
  fixes G k' assumes G_def: "(G, k') \<in> fns"
  fixes E k assumes Ek_def: "(G, k') = vc_to_fns (E, k)"
  fixes R assumes R_def: "is_fns G R" "length R < k'" "set R \<subseteq> verts G"
  fixes Cov assumes Cov_def: "Cov = set R"
begin

lemma cardE_k:
  shows "k \<le> card (\<Union> E)"
  using Ek_def G_def by(auto split: if_split_asm simp: else_not_in_fns vc_to_fns_def)

lemma ugraphE:
  shows "ugraph E"
  using Ek_def G_def unfolding vc_to_fns_def by(auto split: if_split_asm simp add: else_not_in_fns)

lemma G_def_3:
  shows "G = \<lparr>verts = {v. v \<in> \<Union> E}, arcs = {(u, v)| u v. {u, v} \<in> E},
    tail = fst, head = snd\<rparr>" "k' = k+1"
  using Ek_def G_def
  by(auto split: if_split_asm simp add: else_not_in_fns vc_to_fns_def)

lemma wf_digraph_G_2:
  shows "wf_digraph G"
  using G_def fns_def by auto

lemma e_in_E_e_explicit:
  assumes "e \<in> E"
  shows "\<exists>u v. e = {u ,v} \<and> u \<noteq> v"
  using ugraphE assms unfolding ugraph_def by (simp add: e_in_E_e_explicit)

lemma G_symmetric:
  assumes "(u, v) \<in> arcs G"
  shows "(v, u) \<in> arcs G"
  using assms G_def_3 by (auto simp add: assms G_def_3 insert_commute)

lemma wf_digraph_del_verts:
  assumes "wf_digraph G'"
  shows "wf_digraph (del_verts G' E')"
  using assms unfolding del_verts_def
  by(induction E' arbitrary: G')(auto simp add: wf_digraph.wf_digraph_del_vert)

lemma cycle_in_R:
  assumes "(u, v) \<in> arcs G" "(v, u) \<in> arcs G" "u \<noteq> v"
  shows "u \<in> set R \<or> v \<in> set R"
proof(rule ccontr)
  assume "\<not>(u \<in> set R \<or> v \<in> set R)"
  then have "u \<notin> set R \<and> v \<notin> set R"
    by auto
  then have 1: "(v, u) \<in> arcs (del_verts G R)"  "(u, v) \<in> arcs (del_verts G R)" "u \<noteq> v"
    using G_def_3 e_in_arcs_not_in_R assms
    by force+
  have 2: "tail (del_verts G R) = fst" "head (del_verts G R) = snd"
    using G_def_3
    by(auto simp add: tail_del_verts_eq_tail_before head_del_verts_eq_head_before)
  have "wf_digraph (del_verts G R)"
    using wf_digraph_G_2 wf_digraph_del_verts
    by auto
  then have "pre_digraph.cycle (del_verts G R) [(v, u), (u, v)]"
    using edge_cycle 1 2
    by fast
  then show False
    using R_def is_fns_def
    by blast
qed

lemma G_fst_snd:
  shows "tail G = fst" "head G = snd"
  using G_def_3 by auto

lemma in_arcs_one_in_R:
  assumes "e \<in> arcs G" "e = (u, v)" "u \<noteq> v"
  shows "u \<in> set R \<or> v \<in> set R"
  using assms G_symmetric cycle_in_R by blast

lemma Cov_properties:
  shows "Cov \<subseteq> \<Union> E" "card Cov \<le> k" "is_vertex_cover E Cov"
proof -
  have "set R \<subseteq> \<Union> E"
    using R_def G_def_3
    by auto
  then show "Cov \<subseteq> \<Union> E"
    using Cov_def
    by simp
next
  have "length R \<le> k"
    using R_def G_def_3
    by linarith
  then show "card Cov \<le> k"
    using Cov_def card_length dual_order.trans
    by blast
next
  have "\<forall>e\<in>E. \<exists>v\<in>Cov. v \<in> e"
  proof
    fix e assume 1: "e \<in> E"
    then obtain u v where 2: "e = {u, v}" "u \<noteq> v"
      using e_in_E_e_explicit by metis
    then have "(u, v) \<in> arcs G"
      using G_def_3 1
      by auto
    then have "u \<in> set R \<or> v \<in> set R"
      using in_arcs_one_in_R 2
      by simp
    then show "\<exists>v\<in> Cov. v\<in> e"
      using Cov_def 2
      by auto
  qed
  then show "is_vertex_cover E Cov"
    using is_vertex_cover_def
    by auto
qed

lemma in_vc_context:
  shows "(E, k) \<in> vertex_cover"
  using vertex_cover_def ugraphE cardE_k Cov_properties by blast

end

subsection\<open>Main theorem\<close>

lemma in_fns:
  assumes "(E, k) \<in> vertex_cover"
  shows "vc_to_fns (E, k) \<in> fns"
proof -
  obtain G k' where 1: "(G, k') = vc_to_fns (E, k)"
    using assms
    by (metis surjective_pairing)
  obtain Cov where 2: "Cov \<subseteq> \<Union> E" "card Cov \<le> k" "is_vertex_cover E Cov"
    using assms
    by(auto simp add: vertex_cover_def)
  obtain R where 3: "R = set_to_list Cov"
    by simp
  then show ?thesis
    using 1 2 3 in_fns_context assms
    by blast
qed

lemma in_vc:
  assumes "vc_to_fns (E ,k) \<in> fns"
  shows "(E, k) \<in> vertex_cover"
proof -
  obtain G k' where 1: "(G, k') = vc_to_fns (E, k)"
    by (metis surj_pair)
  then obtain R where 2: "is_fns G R" "length R < k'" "set R \<subseteq> verts G"
    using assms fns_def
    by(auto simp add: assms fns_def)
  then obtain Cov where 3: "Cov = set R"
    by auto
  then show ?thesis
    using in_vc_context 1 2 3 assms
    by metis
qed

theorem is_reduction_vc_to_fns:
  "is_reduction vc_to_fns vertex_cover fns"
  unfolding is_reduction_def using in_vc in_fns by auto

end


(* Author: Fabian Immler, TUM *)

section {* Sequence of Properties on Subsequences *}

theory Diagonal_Subsequence
imports Complex_Main
begin

locale subseqs =
  fixes P::"nat\<Rightarrow>(nat\<Rightarrow>nat)\<Rightarrow>bool"
  assumes ex_subseq: "\<And>n s. subseq s \<Longrightarrow> \<exists>r'. subseq r' \<and> P n (s o r')"
begin

definition reduce where "reduce s n = (SOME r'. subseq r' \<and> P n (s o r'))"

lemma subseq_reduce[intro, simp]:
  "subseq s \<Longrightarrow> subseq (reduce s n)"
  unfolding reduce_def by (rule someI2_ex[OF ex_subseq]) auto

lemma reduce_holds:
  "subseq s \<Longrightarrow> P n (s o reduce s n)"
  unfolding reduce_def by (rule someI2_ex[OF ex_subseq]) (auto simp: o_def)

primrec seqseq where
  "seqseq 0 = id"
| "seqseq (Suc n) = seqseq n o reduce (seqseq n) n"

lemma subseq_seqseq[intro, simp]: "subseq (seqseq n)"
proof (induct n)
  case 0 thus ?case by (simp add: subseq_def)
next
  case (Suc n) thus ?case by (subst seqseq.simps) (auto intro!: subseq_o)
qed

lemma seqseq_holds:
  "P n (seqseq (Suc n))"
proof -
  have "P n (seqseq n o reduce (seqseq n) n)"
    by (intro reduce_holds subseq_seqseq)
  thus ?thesis by simp
qed

definition diagseq where "diagseq i = seqseq i i"

lemma subseq_mono: "subseq f \<Longrightarrow> a \<le> b \<Longrightarrow> f a \<le> f b"
  by (metis le_eq_less_or_eq subseq_mono)

lemma subseq_strict_mono: "subseq f \<Longrightarrow> a < b \<Longrightarrow> f a < f b"
  by (simp add: subseq_def)

lemma diagseq_mono: "diagseq n < diagseq (Suc n)"
proof -
  have "diagseq n < seqseq n (Suc n)"
    using subseq_seqseq[of n] by (simp add: diagseq_def subseq_def)
  also have "\<dots> \<le> seqseq n (reduce (seqseq n) n (Suc n))"
    by (auto intro: subseq_mono seq_suble)
  also have "\<dots> = diagseq (Suc n)" by (simp add: diagseq_def)
  finally show ?thesis .
qed

lemma subseq_diagseq: "subseq diagseq"
  using diagseq_mono by (simp add: subseq_Suc_iff diagseq_def)

primrec fold_reduce where
  "fold_reduce n 0 = id"
| "fold_reduce n (Suc k) = fold_reduce n k o reduce (seqseq (n + k)) (n + k)"

lemma subseq_fold_reduce[intro, simp]: "subseq (fold_reduce n k)"
proof (induct k)
  case (Suc k) from subseq_o[OF this subseq_reduce] show ?case by (simp add: o_def)
qed (simp add: subseq_def)

lemma ex_subseq_reduce_index: "seqseq (n + k) = seqseq n o fold_reduce n k"
  by (induct k) simp_all

lemma seqseq_fold_reduce: "seqseq n = fold_reduce 0 n"
  by (induct n) (simp_all)

lemma diagseq_fold_reduce: "diagseq n = fold_reduce 0 n n"
  using seqseq_fold_reduce by (simp add: diagseq_def)

lemma fold_reduce_add: "fold_reduce 0 (m + n) = fold_reduce 0 m o fold_reduce m n"
  by (induct n) simp_all

lemma diagseq_add: "diagseq (k + n) = (seqseq k o (fold_reduce k n)) (k + n)"
proof -
  have "diagseq (k + n) = fold_reduce 0 (k + n) (k + n)"
    by (simp add: diagseq_fold_reduce)
  also have "\<dots> = (seqseq k o fold_reduce k n) (k + n)"
    unfolding fold_reduce_add seqseq_fold_reduce ..
  finally show ?thesis .
qed

lemma diagseq_sub:
  assumes "m \<le> n" shows "diagseq n = (seqseq m o (fold_reduce m (n - m))) n"
  using diagseq_add[of m "n - m"] assms by simp

lemma subseq_diagonal_rest: "subseq (\<lambda>x. fold_reduce k x (k + x))"
  unfolding subseq_Suc_iff fold_reduce.simps o_def
proof
  fix n
  have "fold_reduce k n (k + n) < fold_reduce k n (k + Suc n)" (is "?lhs < _")
    by (auto intro: subseq_strict_mono)
  also have "\<dots> \<le> fold_reduce k n (reduce (seqseq (k + n)) (k + n) (k + Suc n))"
    by (rule subseq_mono) (auto intro!: seq_suble subseq_mono)
  finally show "?lhs < \<dots>" .
qed

lemma diagseq_seqseq: "diagseq o (op + k) = (seqseq k o (\<lambda>x. fold_reduce k x (k + x)))"
  by (auto simp: o_def diagseq_add)

lemma diagseq_holds:
  assumes subseq_stable: "\<And>r s n. subseq r \<Longrightarrow> P n s \<Longrightarrow> P n (s o r)"
  shows "P k (diagseq o (op + (Suc k)))"
  unfolding diagseq_seqseq by (intro subseq_stable subseq_diagonal_rest seqseq_holds)

end

end