header{* Runge-Kutta methods*}
theory Runge_Kutta
imports
  One_Step_Method
  "~~/src/HOL/Library/Float"
  "../../Affine_Arithmetic/Executable_Euclidean_Space"
begin

text{*\label{sec:rk}*}

subsection {* Definitions *}
text{*\label{sec:rk-definition}*}

declare setsum.cong[fundef_cong]
fun rk_eval :: "(nat\<Rightarrow>nat\<Rightarrow>real) \<Rightarrow> (nat\<Rightarrow>real) \<Rightarrow> (real\<times>'a::real_vector \<Rightarrow> 'a) \<Rightarrow> real \<Rightarrow> real \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a" where
  "rk_eval A c f t h x j =
  f (t + h * c j, x + h *\<^sub>R (\<Sum>l=1 ..< j. A j l *\<^sub>R rk_eval A c f t h x l))"

primrec rk_eval_dynamic :: "(nat\<Rightarrow>nat\<Rightarrow>real) \<Rightarrow> (nat\<Rightarrow>real) \<Rightarrow> (real\<times>'a::{comm_monoid_add, scaleR} \<Rightarrow> 'a) \<Rightarrow> real \<Rightarrow> real \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> (nat \<Rightarrow> 'a)" where
  "rk_eval_dynamic A c f t h x 0 = (\<lambda>i. 0)"
| "rk_eval_dynamic A c f t h x (Suc j) =
  (let K = rk_eval_dynamic A c f t h x j in
  K(Suc j:=f (t + h * c (Suc j), x + h *\<^sub>R (\<Sum>l=1..j. A (Suc j) l *\<^sub>R K l))))"

definition rk_increment where
  "rk_increment f s A b c h t x = (\<Sum>j=1..s. b j *\<^sub>R rk_eval A c f t h x j)"

definition rk_increment' where
  "rk_increment' error f s A b c h t x =
  eucl_down error (\<Sum>j=1..s. b j *\<^sub>R rk_eval A c f t h x j)"

definition euler_increment where
  "euler_increment f = rk_increment f 1 (\<lambda>i j. 0) (\<lambda>i. 1) (\<lambda>i. 0)"

definition euler where
  "euler f = grid_function (discrete_evolution (euler_increment f))"

definition euler_increment' where
"euler_increment' e f = rk_increment' e f 1 (\<lambda>i j. 0) (\<lambda>i. 1) (\<lambda>i. 0)"

definition euler' where
  "euler' e f = grid_function (discrete_evolution (euler_increment' e f))"

subsection {* Euler method is consistent *}
text{*\label{sec:rk-euler-cons}*}

lemma euler_increment:
  fixes f::"_ \<Rightarrow> 'a::real_vector"
  shows "euler_increment f h t x = f (t, x)"
  unfolding euler_increment_def rk_increment_def
  by (subst rk_eval.simps) (simp del: rk_eval.simps)

lemma euler_float_increment:
  fixes f::"_ \<Rightarrow> 'a::executable_euclidean_space"
  shows "euler_increment' e f h t x = eucl_down e (f (t, x))"
  unfolding euler_increment'_def rk_increment'_def
  by (subst rk_eval.simps) (simp del: rk_eval.simps)

lemma euler_lipschitz:
  fixes x::"real \<Rightarrow> real"
  fixes f::"_ \<Rightarrow> 'a::real_normed_vector"
  assumes t: "t \<in> {t0..T}"
  assumes lipschitz: "\<forall>t\<in>{t0..T}. lipschitz D' (\<lambda>x. f (t, x)) L"
  shows "lipschitz D' (euler_increment f h t) L"
  using t lipschitz
  by (simp add: lipschitz_def euler_increment del: One_nat_def)

subsection {* Set-Based Consistency of Euler Method *}
text {*\label{sec:setconsistent}*}

locale derivative_set_bounded = derivative_on_convex +
  fixes  F F'
  assumes f_set_bounded: "bounded F" "\<And>t x. t\<in>T \<Longrightarrow> x\<in>X \<Longrightarrow> (x, f (t, x)) \<in> F"
  assumes f'_ivl_bounded: "is_interval F'" "bounded F'" "\<And>t x d. t\<in>T \<Longrightarrow> (x, d) \<in> F \<Longrightarrow>
    f' (t,x) (1, d) \<in> F'"
begin

lemma F_nonempty: "F \<noteq> {}"
  and F'_nonempty: "F' \<noteq> {}"
  using nonempty
  unfolding ex_in_conv[symmetric]
  by (auto intro!: f_set_bounded f'_ivl_bounded)

lemma euler_consistent_traj_set:
  fixes t
  assumes ht: "0 \<le> h" "t + h \<le> u"
  assumes T: "{t..u} \<subseteq> T"
  assumes x': "\<And>s. s \<in> {t..u} \<Longrightarrow> (x has_vector_derivative f (s, x s)) (at s within {t..u})"
  assumes x: "\<And>s. s \<in> {t..u} \<Longrightarrow> x s \<in> X"
  shows "x (t + h) - discrete_evolution (euler_increment f) (t + h) t (x t) \<in> op *\<^sub>R (h\<^sup>2 / 2) ` F'"
proof cases
  assume "h = 0"
  from F'_nonempty obtain f' where "f' \<in> F'" by auto
  from this `h = 0` show ?thesis
    by (auto simp: discrete_evolution_def)
next
  assume "h \<noteq> 0"
  from this ht have "t < u" by simp
  from ht have line_subset: "(\<lambda>ta. t + ta * h) ` {0..1} \<subseteq> {t..u}"
    by (auto intro!: order_trans[OF add_left_mono[OF mult_left_le_one_le]])
  hence line_in: "\<And>s. 0 \<le> s \<Longrightarrow> s \<le> 1 \<Longrightarrow> t + s * h \<in> {t..u}"
    by (rule set_mp) auto
  from ht have subset: "{t .. t + h} \<subseteq> {t .. u}" by simp
  let ?T = "{t..u}"
  from ht have subset: "{t .. t + h} \<subseteq> {t .. u}" by simp
  from `t < u` have "t \<in> ?T" by auto
  from `t < u` have tx: "t \<in> T" "x t \<in> X" using assms by auto
  from tx assms have "0 \<le> norm (f (t, x t))" by simp
  have x_diff: "\<And>s. s \<in> ?T \<Longrightarrow> x differentiable at s within ?T"
    by (rule differentiableI, rule x'[simplified has_vector_derivative_def])
  have f': "\<And>t x. t \<in> ?T \<Longrightarrow> x \<in> X \<Longrightarrow> (f has_derivative f' (t, x)) (at (t, x) within (?T \<times> X))"
    using T by (intro has_derivative_subset[OF f']) auto
  let ?p = "(\<lambda>t. f' (t, x t) (1, f (t, x t)))"
  def diff \<equiv> "\<lambda>n::nat. if n = 0 then x else if n = 1 then \<lambda>t. f (t, x t) else ?p"
  have diff_0[simp]: "diff 0 = x" by (simp add: diff_def)
  {
    fix m::nat and ta::real
    assume mta: "m < 2" "t \<le> ta" "ta \<le> t + h"
    have image_subset: "(\<lambda>xa. (xa, x xa)) ` {t..u} \<subseteq> {t..u} \<times> X"
      using assms by auto
    note has_derivative_in_compose[where f="(\<lambda>xa. (xa, x xa))" and g = f, derivative_intros]
    note has_derivative_subset[OF _ image_subset, derivative_intros]
    note f'[derivative_intros]
    note x'[simplified has_vector_derivative_def, derivative_intros]
    have [simp]: "\<And>c x'. c *\<^sub>R f' (ta, x ta) x' = f' (ta, x ta) (c *\<^sub>R x')"
      using mta ht assms by (auto intro!: f' linear_cmul[symmetric] has_derivative_linear)
    have "((\<lambda>t. f (t, x t)) has_vector_derivative f' (ta, x ta) (1, f (ta, x ta))) (at ta within {t..u})"
      unfolding has_vector_derivative_def
      using assms ht mta by (auto intro!: derivative_eq_intros)
    hence "(diff m has_vector_derivative diff (Suc m) ta) (at ta within {t..t + h})"
      using mta ht
      by (auto simp: diff_def intro!: has_vector_derivative_within_subset[OF _ subset] x')
  } note diff = this
  from taylor_up_within_vector[of 2 t "t + h" diff x t, OF _ _ diff] ht `h\<noteq>0`
  obtain tt where tt: "tt \<in> Basis \<rightarrow> {t <..< t + h}"
    and taylor: "x (t + h) = x t + h *\<^sub>R f (t, x t) + (h\<^sup>2/2) *\<^sub>R (\<Sum>i\<in>Basis. ((?p (tt i)) \<bullet> i) *\<^sub>R i)"
    by (auto simp: Pi_iff Bex_def numeral_2_eq_2 diff_def two_real_nat
      scaleR_setsum_right ac_simps power2_eq_square inverse_eq_divide setprod_numseg)
  hence "x (t + h) - discrete_evolution (euler_increment f) (t + h) t (x t) =
    (h\<^sup>2 / 2) *\<^sub>R (\<Sum>i\<in>Basis. ((?p (tt i)) \<bullet> i) *\<^sub>R i)" (is "?d = _")
    by (auto simp: discrete_evolution_def euler_increment)
  also have "\<dots> \<in> op *\<^sub>R (h\<^sup>2 / 2) ` F'"
    apply (rule image_eqI[OF refl mem_box_componentwiseI[OF f'_ivl_bounded(1)]])
    using T tt ht
    apply (force simp: Pi_iff intro: f_set_bounded x image_eqI[OF refl f'_ivl_bounded(3)])
    done
  finally show ?thesis .
qed

end

locale derivative_norm_bounded = derivative_on_convex +
  fixes B B'
  assumes X_bounded: "bounded X"
  assumes f_bounded: "\<And>t x. t\<in>T \<Longrightarrow> x\<in>X \<Longrightarrow> norm (f (t,x)) \<le> B"
  assumes f'_bounded: "\<And>t x. t\<in>T \<Longrightarrow> x\<in>X \<Longrightarrow> onorm (f' (t,x)) \<le> B'"
begin

lemma f_bound_nonneg: "0 \<le> B"
proof -
  from nonempty obtain t x where "t \<in> T" "x \<in> X" by auto
  have "0 \<le> norm (f (t, x))" by simp
  also have "\<dots> \<le> B" by (rule f_bounded) fact+
  finally show ?thesis .
qed

lemma f'_bound_nonneg: "0 \<le> B'"
proof -
  from nonempty f_bounded ex_norm_eq_1[where 'a="real*'a"]
    obtain t x and d::"real*'a" where tx: "t \<in> T" "x \<in> X" "norm d = 1" by auto
  have "0 \<le> norm (f' (t, x) d)" by simp
  also have "... \<le> B'"
    apply (rule order_trans)
     apply (rule onorm[OF has_derivative_bounded_linear[OF f']])
       using tx
       apply (auto intro!: f'_bounded f' has_derivative_linear)
    done
  finally show ?thesis .
qed

sublocale g: global_lipschitz _ _ _ B'
proof
  show "0 \<le> B'" using f'_bound_nonneg .
  fix t assume "t \<in> T"
  show "lipschitz X (\<lambda>x. f (t, x)) B'"
  proof (rule lipschitzI)
    fix x y
    let ?I = "T \<times> X"
    have "convex ?I" by (intro convex convex_Times)
    moreover have "\<forall>x\<in>?I. (f has_derivative f' x) (at x within ?I)" "\<forall>x\<in>?I. onorm (f' x) \<le> B'"
      using f' f'_bounded
      by (auto simp add: intro!: f'_bounded has_derivative_linear)
    moreover assume "x \<in> X" "y \<in> X"
    with `t \<in> T` have "(t, x) \<in> ?I" "(t, y) \<in> ?I" by simp_all
    ultimately have "norm (f (t, x) - f (t, y)) \<le> B' * norm ((t, x) - (t, y))"
      by (rule differentiable_bound)
    thus "dist (f (t, x)) (f (t, y)) \<le> B' * dist x y"
      by (simp add: dist_norm norm_Pair)
  qed
qed

definition euler_C::"real" where "euler_C = (sqrt DIM('a) * (B' * (B + 1) / 2))"

lemma euler_C_nonneg: "euler_C \<ge> 0"
 using f_bounded f_bound_nonneg f'_bound_nonneg
 by (simp add: euler_C_def)

sublocale derivative_set_bounded T X f f' "X \<times> cball 0 B"
    "{- (B' * (B + 1)) *\<^sub>R One.. (B' * (B + 1)) *\<^sub>R One}"
proof
  show "bounded (X \<times> cball 0 B)" using X_bounded by (auto intro!: bounded_Times)
  show "is_interval {-(B' * (B + 1)) *\<^sub>R One.. (B' * (B + 1)) *\<^sub>R One::'a}"
    "bounded {-(B' * (B + 1)) *\<^sub>R One.. (B' * (B + 1)) *\<^sub>R One::'a}"
    by (auto intro!: is_interval_closed_interval bounded_closed_interval)
  fix t x assume "t \<in> T" "x \<in> X"
  thus "(x, f (t, x)) \<in> X \<times> cball 0 B"
    by (auto simp: dist_norm f_bounded)
next
  fix t and x d::'a assume "t \<in> T" "(x, d) \<in> X \<times> cball 0 B"
  hence "x \<in> X" "norm d \<le> B" by (auto simp: dist_norm)
  have "norm (f' (t, x) (1, d)) \<le> onorm (f' (t, x)) * norm (1::real, d)"
    by (auto intro!: onorm has_derivative_bounded_linear f' `t \<in> T` `x \<in> X`)
  also have "\<dots> \<le> B' * (B + 1)"
    by (auto intro!: mult_mono f'_bounded f_bounded `t \<in> T` `x \<in> X` f'_bound_nonneg
      order_trans[OF norm_Pair_le] `norm d \<le> B`)
  finally have "f' (t, x) (1, d) \<in> cball 0 (B' * (B + 1))"
    by (auto simp: dist_norm)
  also note cball_in_cube
  finally show "f' (t, x) (1, d) \<in> {- (B' * (B + 1)) *\<^sub>R One..(B' * (B + 1)) *\<^sub>R One}" by simp
qed

lemma euler_consistent_traj:
  fixes t
  assumes T: "{t..u} \<subseteq> T"
  assumes x': "\<And>s. s \<in> {t..u} \<Longrightarrow> (x has_vector_derivative f (s, x s)) (at s within {t..u})"
  assumes x: "\<And>s. s \<in> {t..u} \<Longrightarrow> x s \<in> X"
  shows "consistent x t u euler_C 1 (euler_increment f)"
proof
  fix h::real
  assume ht: "0 < h" "t + h \<le> u" hence "t < u" "0 < h\<^sup>2 / 2" by simp_all
  from euler_consistent_traj_set ht T x' x
  have "x (t + h) - discrete_evolution (euler_increment f) (t + h) t (x t) \<in>
      op *\<^sub>R (h\<^sup>2 / 2) ` {- (B' * (B + 1)) *\<^sub>R One..(B' * (B + 1)) *\<^sub>R One}"
    by auto
  also have "\<dots> = {- ((h\<^sup>2 / 2) * (B' * (B + 1))) *\<^sub>R One.. ((h\<^sup>2 / 2) * (B' * (B + 1))) *\<^sub>R One}"
    by (simp add: scaleR_image_atLeastAtMost[OF `0 < h\<^sup>2 / 2`])
  also
  note centered_cube_in_cball
  finally show "dist (x (t + h)) (discrete_evolution (euler_increment f) (t + h) t (x t))
      \<le> euler_C * h ^ (1 + 1)"
    by (auto simp: euler_C_def dist_norm algebra_simps norm_minus_commute power2_eq_square)
qed

end

locale grid_from = grid +
  fixes t0
  assumes grid_min: "t0 = t 0"

locale euler_consistent =
  has_solution i +
  ivp_on_interval i t1 +
  derivative_norm_bounded T X' f B f' B'
  for i::"'a::ordered_euclidean_space ivp" and t t1 X' B f' B' +
  fixes r
  assumes domain_subset: "X \<subseteq> X'"
  assumes lipschitz_area: "\<And>t. t \<in> T \<Longrightarrow> cball (solution t) \<bar>r\<bar> \<subseteq> X'"
begin

lemma euler_consistent_solution:
  fixes t'
  assumes t': "t' \<in> T"
  shows "consistent solution t' t1 euler_C 1 (euler_increment f)"
proof (rule euler_consistent_traj)
  show "{t'..t1} \<subseteq> T" using t' interval by simp
  fix s
  assume "s \<in> {t'..t1}" hence "s \<in> T" using `{t'..t1} \<subseteq> T` by auto
  show "(solution has_vector_derivative f (s, solution s)) (at s within {t'..t1})"
    by (rule has_vector_derivative_within_subset[OF _ `{t'..t1} \<subseteq> T`]) (rule solution(2)[OF `s \<in> T`])
  have "solution s \<in> ivp_X i" by (rule solution(3)[OF `s \<in> T`])
  thus "solution s \<in> X'" using domain_subset ..
qed

end

sublocale euler_consistent \<subseteq>
  consistent_one_step t0 t1 solution "euler_increment f" 1 euler_C r B'
proof
  show "0 < (1::nat)" by simp
  show "0 \<le> euler_C" using euler_C_nonneg by simp
  show "0 \<le> B'" using lipschitz by simp
  fix s x assume s: "s \<in> {t0..t1}"
  show "consistent solution s t1 euler_C 1 (euler_increment f)"
    using interval s f_bounded f'_bounded f'
      strip
    by (intro euler_consistent_solution) auto
  fix h
  assume "h\<in>{0..t1 - s}"
  have "lipschitz X' (euler_increment f h s) B'"
    using s lipschitz interval strip
    by (auto intro!: euler_lipschitz)
  thus "lipschitz (cball (solution s) \<bar>r\<bar>) (euler_increment f h s) B'"
    using lipschitz_area s interval
    by (force intro: lipschitz_subset)
qed

subsection {* Euler method is convergent *}
text{*\label{sec:rk-euler-conv}*}

locale max_step1 = grid +
  fixes t1 L B r
  assumes max_step: "\<And>j. t j \<le> t1 \<Longrightarrow> max_stepsize j \<le> \<bar>r\<bar> * L / B / (exp (L * (t1 - t 0) + 1) - 1)"

sublocale max_step1 < max_step: max_step t t1 1 L B r
using max_step by unfold_locales simp_all

locale euler_convergent =
  euler_consistent + max_step1 t t1 B' euler_C r +
  assumes grid_from: "t0 = t 0"

sublocale euler_convergent \<subseteq>
  convergent_one_step t0 t1 solution "euler_increment f" 1 euler_C r B' t
  by unfold_locales (simp add: grid_from)

locale euler_on_strip =
  ivp_on_interval i t1 + continuous T X f +
  derivative_norm_bounded T UNIV f B f' B' +
  grid: grid_from t t0 +
  max_step1 t t1 B' euler_C r
  for i::"'a::ordered_euclidean_space ivp" and t t1 r B f' B' +
  assumes strip: "X = UNIV"

sublocale euler_on_strip \<subseteq> unique_on_strip i t1 B'
  using lipschitz by unfold_locales (simp_all add: strip)

sublocale euler_on_strip \<subseteq> convergent: euler_convergent i t t1 UNIV B f' B' r
  using lipschitz strip grid_min
  by unfold_locales simp_all

context euler_on_strip begin

lemma convergence:
  assumes "t j \<le> t1"
  shows "dist (solution (t j)) (euler f x0 t j)
    \<le> euler_C / B' * (exp (B' * (t1 - t0) + 1) - 1) * max_stepsize j"
  using assms convergence
  by (simp add: euler_def grid_min[symmetric] solution_t0)

end

subsection {* Euler method on Rectangle is convergent *}
text{*\label{sec:rk-euler-conv-on-rect}*}

locale ivp_rectangle_bounded_derivative = solution_in_rectangle i t1 b B +
  derivative_norm_bounded T "{x0 - (b + \<bar>r\<bar>) *\<^sub>R One..x0 + (b + \<bar>r\<bar>) *\<^sub>R One}" f f' B B' for i t1 b r B f' B'

sublocale ivp_rectangle_bounded_derivative \<subseteq> unique_on_rectangle i t1 b B B'
  "{x0 - (b + \<bar>r\<bar>) *\<^sub>R One..x0 + (b + \<bar>r\<bar>) *\<^sub>R One}"
  using b_pos by unfold_locales (auto simp: rectangle intro!: scaleR_mono One_nonneg)

sublocale ivp_rectangle_bounded_derivative \<subseteq>
  euler_consistent i t t1 "{x0 - (b + \<bar>r\<bar>) *\<^sub>R One..x0 + (b + \<bar>r\<bar>) *\<^sub>R One}" f' B B'
proof
  show "X \<subseteq> {x0 - (b + \<bar>r\<bar>) *\<^sub>R One..x0 + (b + \<bar>r\<bar>) *\<^sub>R One}" using lipschitz_on_domain .
  fix t assume "t \<in> T"
  from cball_in_cube
  have "cball (solution t) \<bar>r\<bar> \<subseteq> {solution t - setsum (op *\<^sub>R \<bar>r\<bar>) Basis..solution t + setsum (op *\<^sub>R \<bar>r\<bar>) Basis}"
    by (simp add: scaleR_setsum_right)
  also have "\<dots> \<subseteq> {x0 - (b + \<bar>r\<bar>) *\<^sub>R One..x0 + (b + \<bar>r\<bar>) *\<^sub>R One}"
    using rectangle interval solution_in_D[of t] `t \<in> T`
    by (auto simp: scaleR_setsum_right algebra_simps setsum.distrib)
  finally show "cball (solution t) \<bar>r\<bar> \<subseteq> {x0 - (b + \<bar>r\<bar>) *\<^sub>R One..x0 + (b + \<bar>r\<bar>) *\<^sub>R One}" .
qed

locale euler_on_rectangle =
  ivp_rectangle_bounded_derivative i t1 b r B f' B' +
  grid_from t t0 +
  max_step1 t t1 B' euler_C r
  for i::"'a::ordered_euclidean_space ivp" and t t1 b r B f' B'

sublocale euler_on_rectangle \<subseteq>
  convergent: euler_convergent i t t1 "{x0 - (b + \<bar>r\<bar>) *\<^sub>R One..x0 + (b + \<bar>r\<bar>) *\<^sub>R One}" f' B B'
proof unfold_locales
qed (rule grid_min)

lemma "B \<ge> (0::real) \<Longrightarrow> 0 \<le> (exp (B + 1) - 1)" by (simp add: algebra_simps)

context euler_on_rectangle begin

lemma convergence:
  assumes "t j \<le> t1"
  shows "dist (solution (t j)) (euler f x0 t j)
    \<le> sqrt DIM('a) * (B + 1) / 2 * (exp (B' * (t1 - t0) + 1) - 1) * max_stepsize j"
proof -
  have "dist (solution (t j)) (euler f x0 t j)
    \<le> sqrt DIM('a) * (B + 1) / 2 * B' / B' * ((exp (B' * (t1 - t0) + 1) - 1) * max_stepsize j)"
    using assms convergence f'_bound_nonneg
    unfolding euler_C_def
    by (simp add: euler_def grid_min[symmetric] solution_t0 ac_simps)
  also have "\<dots> \<le> sqrt DIM('a) * (B + 1) / 2 * ((exp (B' * (t1 - t0) + 1) - 1) * max_stepsize j)"
    using f_bound_nonneg f'_bound_nonneg
    by (auto intro!: mult_right_mono mult_nonneg_nonneg max_stepsize_nonneg add_nonneg_nonneg
      simp: le_diff_eq)
  finally show ?thesis by simp
qed

end

subsection {* Stability and Convergence of Approximate Euler *}
text{*\label{sec:rk-euler-stable}*}

locale euler_rounded_on_rectangle =
  ivp_rectangle_bounded_derivative i t1' b r B f' B' +
  grid: grid_from t t0' +
  max_step_r_2: max_step1 t t2' B' euler_C "r/2"
  for i::"'a::executable_euclidean_space ivp" and t :: "nat \<Rightarrow> real" and t0' t1' t2'::real and x0' :: 'a
  and b r B f' B' +
  fixes g::"(real\<times>'a)\<Rightarrow>'a" and e::int
  assumes t0_float: "t0 = t0'"
  assumes ordered_bounds: "t1' \<le> t2'"
  assumes approx_f_e: "\<And>j x. t j \<le> t1' \<Longrightarrow> dist (f (t j, x)) ((g (t j, x))) \<le> sqrt (DIM('a)) * 2 powr -e"
  assumes initial_error: "dist x0 (x0') \<le> euler_C / B' * (exp 1 - 1) * stepsize 0"
  assumes rounding_error: "\<And>j. t j \<le> t1' \<Longrightarrow> sqrt (DIM('a)) * 2 powr -e \<le> euler_C / 2 * stepsize j"
begin

lemma approx_f: "t j \<le> t1' \<Longrightarrow> dist (f (t j, x)) ((g (t j, x)))
    \<le> euler_C / 2 * stepsize j"
  using approx_f_e[of j x] rounding_error[of j] by auto

lemma t0_le: "t 0 \<le> t1'"
  unfolding grid_min[symmetric] t0_float[symmetric]
  by (metis interval_notempty)

end

sublocale euler_rounded_on_rectangle \<subseteq> grid': grid_from t t0'
  using grid t0_float grid_min by unfold_locales auto

sublocale euler_rounded_on_rectangle \<subseteq> max_step_r: max_step1 t t2' B' euler_C r
proof unfold_locales
  fix j
  assume "(t j) \<le> t2'"
  moreover with grid_mono[of 0 j] have "t 0 \<le> t2'" by (simp add: less_eq_float_def)
  ultimately show "One_Step_Method.grid.max_stepsize (\<lambda>x. (t x)) j
        \<le> \<bar>r\<bar> * B' / euler_C / (exp (B' * (t2' - (t 0)) + 1) - 1)"
    using max_step_mono_r lipschitz B_nonneg interval_notempty f'_bound_nonneg
    by (auto simp: less_eq_float_def euler_C_def)
qed

lemma max_step1_mono:
  assumes "t 0 \<le> t1"
  assumes "t1 \<le> t2"
  assumes "0 \<le> a"
  assumes "0 \<le> b"
  assumes ms2: "max_step1 t t2 a b c"
  shows "max_step1 t t1 a b c"
proof -
  interpret t2: max_step1 t t2 a b c using ms2 .
  show ?thesis
  proof
    fix j
    assume "t j \<le> t1" hence "t j \<le> t2" using assms by simp
    hence "t2.max_stepsize j \<le> \<bar>c\<bar> * a / b / (exp (a * (t2 - t 0) + 1) - 1)" (is "_ \<le> ?x t2")
      by (rule t2.max_step)
    also have "\<dots> \<le> ?x t1"
      using assms
      by (cases "b = 0") (auto intro!: divide_left_mono mult_mono abs_ge_zero add_increasing
        mult_pos_pos add_strict_increasing2 simp: le_diff_eq less_diff_eq)
    finally show "t2.max_stepsize j \<le> ?x t1" .
  qed
qed

sublocale euler_rounded_on_rectangle \<subseteq> max_step_r1: max_step1 t t1' B' euler_C r
  by (rule max_step1_mono[of t, OF t0_le ordered_bounds f'_bound_nonneg euler_C_nonneg])
    unfold_locales

sublocale euler_rounded_on_rectangle \<subseteq> c: euler_on_rectangle i t t1' b r B f' B'
  using t0_float grid_min by unfold_locales simp

sublocale euler_rounded_on_rectangle \<subseteq>
  consistent_one_step "t 0" t1' solution "euler_increment f" 1 euler_C r B'
  using consistent_nonneg consistent lipschitz_nonneg lipschitz_incr t0_float grid_min
  by unfold_locales simp_all

sublocale euler_rounded_on_rectangle \<subseteq> max_step1 t t1' B' euler_C "r / 2"
  by (rule max_step1_mono[of t, OF t0_le ordered_bounds f'_bound_nonneg euler_C_nonneg])
    unfold_locales

sublocale euler_rounded_on_rectangle \<subseteq>
  one_step:
  rounded_one_step t t1' solution "euler_increment f" 1 euler_C r B' "euler_increment' e g" x0'
proof
  fix h j x assume "t j \<le> t1'"
  have "dist (euler_increment f (h) (t j) (x))
        ((euler_increment' e g h (t j) x)) =
    dist (f (t j, x)) ((eucl_down e (g (t j, x))))"
    by (simp add: euler_increment euler_float_increment)
  also
  have "... \<le>
    dist (f (t j, x)) ((g (t j, x))) +
    dist ((g (t j, x))) ((eucl_down e (g (t j, x))))"
    by (rule dist_triangle)
  also
  from approx_f[OF `t j \<le> t1'`]
  have "dist (f (t j, x)) ((g (t j, x))) \<le>
    euler_C / 2 * stepsize j" .
  also
  from eucl_truncate_down_correct[of "g (t j, x)" e]
  have "dist ((g (t j, x))) ((eucl_down e (g (t j, x)))) \<le> sqrt (DIM('a)) * 2 powr - e" by simp
  also
  have "sqrt (DIM('a)) * 2 powr -e \<le> euler_C / 2 * stepsize j"
    using rounding_error `t j \<le> t1'` .
  finally
  have "dist (euler_increment f (h) (t j) (x)) ((euler_increment' e g h (t j) x)) \<le> euler_C * stepsize j"
    by arith
  thus "dist (euler_increment f h (t j) (x)) ((euler_increment' e g h (t j) x)) \<le> euler_C * stepsize j ^ 1"
    by simp
qed (insert initial_error grid_min solution_t0, simp_all)

context euler_rounded_on_rectangle begin

lemma stability:
  assumes "t j \<le> t1'"
  shows "dist (euler' e g x0' t j) (euler f x0 t j) \<le>
    sqrt DIM('a) * (B + 1) / 2 * (exp (B' * (t1' - t0') + 1) - 1) * max_stepsize j"
proof -
  have "dist ((euler' e g x0' t j)) (euler f x0 t j) \<le>
    sqrt DIM('a) * (B + 1) / 2 * B' / B' * (exp (B' * (t1' - t0') + 1) - 1) * max_stepsize j"
    using assms stability
    unfolding grid_min[symmetric] solution_t0 euler_C_def
    by (auto simp add: euler_def euler'_def t0_float)
  also have "\<dots> \<le> sqrt DIM('a) * (B + 1) / 2 * ((exp (B' * (t1' - t0') + 1) - 1) * max_stepsize j)"
    using f_bound_nonneg f'_bound_nonneg
    by (auto intro!: mult_right_mono mult_nonneg_nonneg max_stepsize_nonneg add_nonneg_nonneg
      simp: le_diff_eq)
  finally show ?thesis by simp
qed

lemma convergence_float:
  assumes "t j \<le> t1'"
  shows "dist (solution (t j)) (euler' e g x0' t j) \<le>
    sqrt DIM('a) * (B + 1) * (exp (B' * (t1' - t0') + 1) - 1) * max_stepsize j"
proof -
  have "dist (solution ((t j))) ((euler' e g x0' t j)) \<le>
    dist (solution ((t j)))
    (euler f x0 t j) +
    dist ((euler' e g x0' t j)) (euler f x0 t j)"
    by (rule dist_triangle2)
  also have "dist (solution ((t j)))
     (euler f x0 t j) \<le>
    sqrt DIM('a) * (B + 1) / 2 * (exp (B' * (t1' - t0') + 1) - 1) * max_stepsize j"
    using assms convergence t0_float by simp
  also have "dist ((euler' e g x0' t j)) (euler f x0 t j) \<le>
    sqrt DIM('a) * (B + 1) / 2 * (exp (B' * (t1' - t0') + 1) - 1) * max_stepsize j"
    using assms stability by simp
  finally
  have "dist (solution ((t j))) ((euler' e g x0' t j))
     \<le> sqrt DIM('a) * (B + 1) / 2 * (exp (B' * (t1' - t0') + 1) - 1) *
       max_stepsize j +
       sqrt DIM('a) * (B + 1) / 2 * (exp (B' * (t1' - t0') + 1) - 1) *
       max_stepsize j" by simp
  thus ?thesis by (simp add: field_simps)
qed

end

end


(*
Authors:

  Dominique Unruh, University of Tartu, unruh@ut.ee
  Jose Manuel Rodriguez Caballero, University of Tartu, jose.manuel.rodriguez.caballero@ut.ee

*)

theory Tensor_Product
  imports
    "Complex_Bounded_Operators.Complex_L2"
    "HOL-Library.Adhoc_Overloading"
    Completion
    Algebraic_Tensor_Product
    Registers.Finite_Tensor_Product
begin
unbundle cblinfun_notation

section \<open>Hilbert tensor product\<close>

text\<open>Hilbert tensor product as defined in @{cite Helemskii} chapter 2, section 8\<close>
typedef (overloaded) ('a::chilbert_space, 'b::chilbert_space) htensor
  = \<open>(UNIV::(('a \<otimes>\<^sub>a 'b) completion) set)\<close>
  ..

setup_lifting type_definition_htensor

(* "h" is for Hilbert *)
type_notation
  htensor  ("(_ \<otimes>\<^sub>h/ _)" [21, 20] 20)

instantiation htensor :: (chilbert_space, chilbert_space) complex_inner
begin
lift_definition cinner_htensor :: \<open>'a \<otimes>\<^sub>h 'b \<Rightarrow> 'a \<otimes>\<^sub>h 'b \<Rightarrow> complex\<close>
  is "\<lambda> x y. (x \<bullet>\<^sub>C y)".

lift_definition scaleC_htensor :: \<open>complex \<Rightarrow> 'a \<otimes>\<^sub>h 'b \<Rightarrow> 'a \<otimes>\<^sub>h 'b\<close>
  is "\<lambda> c x. c *\<^sub>C x".

lift_definition uminus_htensor :: \<open>'a \<otimes>\<^sub>h 'b \<Rightarrow> 'a \<otimes>\<^sub>h 'b\<close>
  is "\<lambda> x. -x".

lift_definition zero_htensor :: \<open>'a \<otimes>\<^sub>h 'b\<close>
  is "0".

lift_definition minus_htensor :: \<open>'a \<otimes>\<^sub>h 'b \<Rightarrow> 'a \<otimes>\<^sub>h 'b \<Rightarrow> 'a \<otimes>\<^sub>h 'b\<close>
  is \<open>\<lambda> x y. x - y\<close>.

lift_definition plus_htensor :: \<open>'a \<otimes>\<^sub>h 'b \<Rightarrow> 'a \<otimes>\<^sub>h 'b \<Rightarrow> 'a \<otimes>\<^sub>h 'b\<close>
  is \<open>\<lambda> x y. x + y\<close>.

lift_definition sgn_htensor :: \<open>'a \<otimes>\<^sub>h 'b \<Rightarrow> 'a \<otimes>\<^sub>h 'b\<close>
  is \<open>\<lambda> x.  x /\<^sub>R (norm x)\<close>.

lift_definition norm_htensor :: \<open>'a \<otimes>\<^sub>h 'b \<Rightarrow> real\<close>
  is \<open>\<lambda> x. norm x\<close>.

lift_definition scaleR_htensor :: \<open>real \<Rightarrow> 'a \<otimes>\<^sub>h 'b \<Rightarrow> 'a \<otimes>\<^sub>h 'b\<close>
  is "\<lambda> c x. c *\<^sub>R x".

lift_definition dist_htensor :: \<open>'a \<otimes>\<^sub>h 'b \<Rightarrow> 'a \<otimes>\<^sub>h 'b \<Rightarrow> real\<close>
  is \<open>\<lambda> x y. dist x y\<close>.

definition uniformity_htensor :: \<open>(('a \<otimes>\<^sub>h 'b) \<times> 'a \<otimes>\<^sub>h 'b) filter\<close> where
  "uniformity = (INF e\<in>{0<..}. principal {(x, y). dist (x::'a \<otimes>\<^sub>h 'b) y < e})"

definition open_htensor :: \<open>('a \<otimes>\<^sub>h 'b) set \<Rightarrow> bool\<close> where
  "open U = (\<forall>x\<in>U. \<forall>\<^sub>F (x', y) in uniformity. (x'::'a \<otimes>\<^sub>h 'b) = x \<longrightarrow> y \<in> U)"
instance
proof
  (* TODO: more readable to fix variable names via "fix" once and for all throught the proof, imho *)
  (* TODO: clean up superfluous type information *)
  show "((*\<^sub>R) r::'a \<otimes>\<^sub>h 'b \<Rightarrow> _) = (*\<^sub>C) (complex_of_real r)"
    for r :: real
    apply transfer
    by (simp add: scaleR_scaleC)

  show "(a::'a \<otimes>\<^sub>h 'b) + b + c = a + (b + c)"
    for a :: "'a \<otimes>\<^sub>h 'b"
      and b :: "'a \<otimes>\<^sub>h 'b"
      and c :: "'a \<otimes>\<^sub>h 'b"
    by (metis (mono_tags, lifting) Rep_htensor_inject ab_semigroup_add_class.add_ac(1) plus_htensor.rep_eq)

  show "(a::'a \<otimes>\<^sub>h 'b) + b = b + a"
    for a :: "'a \<otimes>\<^sub>h 'b"
      and b :: "'a \<otimes>\<^sub>h 'b"
    by (metis (mono_tags, lifting) Rep_htensor_inject Tensor_Product.plus_htensor.rep_eq ordered_field_class.sign_simps(2))

  show "(0::'a \<otimes>\<^sub>h 'b) + a = a"
    for a :: "'a \<otimes>\<^sub>h 'b"
    using Rep_htensor_inject plus_htensor.rep_eq zero_htensor.rep_eq by fastforce

  show "- (a::'a \<otimes>\<^sub>h 'b) + a = 0"
    for a :: "'a \<otimes>\<^sub>h 'b"
    using Rep_htensor_inject plus_htensor.rep_eq uminus_htensor.rep_eq zero_htensor.rep_eq by fastforce

  show "(a::'a \<otimes>\<^sub>h 'b) - b = a + - b"
    for a :: "'a \<otimes>\<^sub>h 'b"
      and b :: "'a \<otimes>\<^sub>h 'b"
    by (metis (mono_tags, lifting) Rep_htensor_inverse Tensor_Product.minus_htensor.rep_eq Tensor_Product.plus_htensor.rep_eq Tensor_Product.uminus_htensor.rep_eq pth_2)

  show "a *\<^sub>C ((x::'a \<otimes>\<^sub>h 'b) + y) = a *\<^sub>C x + a *\<^sub>C y"
    for a :: complex
      and x :: "'a \<otimes>\<^sub>h 'b"
      and y :: "'a \<otimes>\<^sub>h 'b"
    by (metis (mono_tags, lifting) Rep_htensor_inject plus_htensor.rep_eq scaleC_add_right scaleC_htensor.rep_eq)

  show "(a + b) *\<^sub>C (x::'a \<otimes>\<^sub>h 'b) = a *\<^sub>C x + b *\<^sub>C x"
    for a :: complex
      and b :: complex
      and x :: "'a \<otimes>\<^sub>h 'b"
    by (metis (mono_tags, lifting) Rep_htensor_inverse Tensor_Product.plus_htensor.abs_eq Tensor_Product.scaleC_htensor.rep_eq scaleC_add_left)

  show "a *\<^sub>C b *\<^sub>C (x::'a \<otimes>\<^sub>h 'b) = (a * b) *\<^sub>C x"
    for a :: complex
      and b :: complex
      and x :: "'a \<otimes>\<^sub>h 'b"
    using Rep_htensor_inject scaleC_htensor.rep_eq by fastforce

  show "1 *\<^sub>C (x::'a \<otimes>\<^sub>h 'b) = x"
    for x :: "'a \<otimes>\<^sub>h 'b"
    using Rep_htensor_inject scaleC_htensor.rep_eq by fastforce

  show "dist (x::'a \<otimes>\<^sub>h 'b) y = norm (x - y)"
    for x :: "'a \<otimes>\<^sub>h 'b"
      and y :: "'a \<otimes>\<^sub>h 'b"
    by (simp add: dist_htensor.rep_eq dist_norm minus_htensor.rep_eq norm_htensor.rep_eq)

  show "sgn (x::'a \<otimes>\<^sub>h 'b) = inverse (norm x) *\<^sub>R x"
    for x :: "'a \<otimes>\<^sub>h 'b"
    using Rep_htensor_inject norm_htensor.rep_eq scaleR_htensor.rep_eq sgn_htensor.rep_eq
    by fastforce

  show "uniformity = (INF e\<in>{0<..}. principal {(x, y). dist (x::'a \<otimes>\<^sub>h 'b) y < e})"
    by (simp add: Tensor_Product.uniformity_htensor_def)

  show "open U = (\<forall>x\<in>U. \<forall>\<^sub>F (x', y) in uniformity. (x'::'a \<otimes>\<^sub>h 'b) = x \<longrightarrow> y \<in> U)"
    for U :: "('a \<otimes>\<^sub>h 'b) set"
    by (simp add: Tensor_Product.open_htensor_def)

  show "(x::'a \<otimes>\<^sub>h 'b) \<bullet>\<^sub>C y = cnj (y \<bullet>\<^sub>C x)"
    for x :: "'a \<otimes>\<^sub>h 'b"
      and y :: "'a \<otimes>\<^sub>h 'b"
    by (simp add: cinner_htensor.rep_eq)

  show "((x::'a \<otimes>\<^sub>h 'b) + y) \<bullet>\<^sub>C z = (x \<bullet>\<^sub>C z) + (y \<bullet>\<^sub>C z)"
    for x :: "'a \<otimes>\<^sub>h 'b"
      and y :: "'a \<otimes>\<^sub>h 'b"
      and z :: "'a \<otimes>\<^sub>h 'b"
    by (simp add: Tensor_Product.cinner_htensor.rep_eq Tensor_Product.plus_htensor.rep_eq cinner_add_left)

  show "(r *\<^sub>C (x::'a \<otimes>\<^sub>h 'b)) \<bullet>\<^sub>C y = cnj r * (x \<bullet>\<^sub>C y)"
    for r :: complex
      and x :: "'a \<otimes>\<^sub>h 'b"
      and y :: "'a \<otimes>\<^sub>h 'b"
    by (simp add: Tensor_Product.cinner_htensor.rep_eq Tensor_Product.scaleC_htensor.rep_eq)

  show "0 \<le> (x::'a \<otimes>\<^sub>h 'b) \<bullet>\<^sub>C x"
    for x :: "'a \<otimes>\<^sub>h 'b"
    using cinner_ge_zero cinner_htensor.rep_eq by auto

  show "(x::'a \<otimes>\<^sub>h 'b) \<bullet>\<^sub>C x = 0 \<longleftrightarrow> x = 0"
    for x :: "'a \<otimes>\<^sub>h 'b"
    using Rep_htensor_inject Tensor_Product.zero_htensor.rep_eq cinner_htensor.rep_eq by fastforce

  show "norm (x::'a \<otimes>\<^sub>h 'b) = sqrt (cmod (x \<bullet>\<^sub>C x))"
    for x :: "'a \<otimes>\<^sub>h 'b"
    using cinner_htensor.rep_eq norm_eq_sqrt_cinner norm_htensor.rep_eq by auto

qed
end

instantiation htensor :: (chilbert_space, chilbert_space) chilbert_space
begin
instance
proof
  show "convergent X"
    if "Cauchy X"
    for X :: "nat \<Rightarrow> 'a \<otimes>\<^sub>h 'b"
  proof-
    from \<open>Cauchy X\<close>
    have \<open>Cauchy (\<lambda> n. Rep_htensor (X n))\<close>
      unfolding Cauchy_def dist_htensor_def
      by auto
    hence \<open>convergent (\<lambda> n. Rep_htensor (X n))\<close>
      using Cauchy_convergent by auto
    hence \<open>\<exists> l. \<forall> e>0. \<exists> N. \<forall> n\<ge>N. dist (Rep_htensor (X n)) l < e\<close>
      unfolding convergent_def
      using metric_LIMSEQ_D by blast
    then obtain l where \<open>\<forall> e>0. \<exists> N. \<forall> n\<ge>N. dist (Rep_htensor (X n)) l < e\<close>
      by blast
    have \<open>\<exists> L. Rep_htensor L = l\<close>
      by (metis Rep_htensor_inverse dist_eq_0_iff dist_htensor.abs_eq)
    then obtain L where \<open>Rep_htensor L = l\<close> by blast
    have \<open>\<forall> e>0. \<exists> N. \<forall> n\<ge>N. dist (Rep_htensor (X n)) (Rep_htensor L) < e\<close>
      by (simp add: \<open>Rep_htensor L = l\<close> \<open>\<forall>e>0. \<exists>N. \<forall>n\<ge>N. dist (Rep_htensor (X n)) l < e\<close>)
    hence \<open>\<forall> e>0. \<exists> N. \<forall> n\<ge>N. dist (X n) L < e\<close>
      by (simp add: dist_htensor.rep_eq)
    hence \<open>X \<longlonglongrightarrow> L\<close>
      by (simp add: metric_LIMSEQ_I)
    thus ?thesis unfolding convergent_def by blast
  qed
qed
end

lift_definition htensor_op:: \<open>'a::chilbert_space \<Rightarrow> 'b::chilbert_space \<Rightarrow> 'a \<otimes>\<^sub>h 'b\<close>  (infixl "\<otimes>\<^sub>h" 70)
  is \<open>\<lambda> x::'a. \<lambda> y::'b. inclusion_completion (x \<otimes>\<^sub>a y)\<close>.

lemma htensor_distr_right:
  fixes x :: "'a::chilbert_space" and y z :: "'b::chilbert_space"
  shows  \<open>x \<otimes>\<^sub>h (y+z) =  x \<otimes>\<^sub>h y  +  x \<otimes>\<^sub>h z\<close>
  apply transfer
  by (simp add: atensor_distr_right inclusion_completion_add)

lemma htensor_distr_right_sum:
  fixes x :: "'a::chilbert_space" and y :: "'c \<Rightarrow> 'b::chilbert_space"
    and I :: \<open>'c set\<close>
  shows  \<open>x \<otimes>\<^sub>h (\<Sum> i \<in> I. y i) = (\<Sum> i \<in> I. x \<otimes>\<^sub>h (y i))\<close>
  using htensor_distr_right
  by (metis Modules.additive_def additive.sum)

lemma htensor_distr_left:
  fixes y z :: "'a::chilbert_space" and x :: "'b::chilbert_space"
  shows  \<open>(y+z) \<otimes>\<^sub>h x =  y \<otimes>\<^sub>h x  +  z \<otimes>\<^sub>h x\<close>
  apply transfer
  by (simp add: atensor_distr_left inclusion_completion_add)

lemma htensor_distr_left_sum:
  fixes  x :: "'c \<Rightarrow> 'a::chilbert_space" and y :: "'b::chilbert_space"
    and I :: \<open>'c set\<close>
  shows  \<open>(\<Sum> i \<in> I. x i) \<otimes>\<^sub>h y = (\<Sum> i \<in> I. (x i) \<otimes>\<^sub>h y)\<close>
proof-
  define f::\<open>'a \<Rightarrow> 'a \<otimes>\<^sub>h 'b\<close> where \<open>f t = t \<otimes>\<^sub>h y\<close> for t
  have \<open>Modules.additive f\<close>
    unfolding f_def
    using htensor_distr_left
    by (simp add: htensor_distr_left Modules.additive_def)
  show ?thesis
    using additive.sum \<open>Modules.additive f\<close> \<open>f \<equiv> \<lambda>t. t \<otimes>\<^sub>h y\<close> by auto
qed

lemma htensor_mult_right:
  fixes x :: "'a::chilbert_space" and y :: "'b::chilbert_space" and c :: complex
  shows \<open>x \<otimes>\<^sub>h (c *\<^sub>C y) = c *\<^sub>C (x \<otimes>\<^sub>h y)\<close>
  apply transfer
  by (simp add: atensor_mult_right inclusion_completion_scaleC)

lemma htensor_mult_left:
  fixes x :: "'a::chilbert_space" and y :: "'b::chilbert_space" and c :: complex
  shows \<open>(c *\<^sub>C x) \<otimes>\<^sub>h y  = c *\<^sub>C (x \<otimes>\<^sub>h y)\<close>
  apply transfer
  by (simp add: atensor_mult_left inclusion_completion_scaleC)

lemma htensor_product_cartesian_product:
  assumes \<open>finite t\<close> and \<open>finite t'\<close>
  shows \<open>(\<Sum>i\<in>t. r i *\<^sub>C i) \<otimes>\<^sub>h (\<Sum>j\<in>t'. r' j *\<^sub>C j)
 = (\<Sum>(a, b)\<in>t\<times>t'. (r a * r' b) *\<^sub>C (a \<otimes>\<^sub>h b))\<close>
proof-
  have \<open>(\<Sum>i\<in>t. r i *\<^sub>C i) \<otimes>\<^sub>h (\<Sum>j\<in>t'. r' j *\<^sub>C j) = (\<Sum>i\<in>t. (r i *\<^sub>C i) \<otimes>\<^sub>h (\<Sum>j\<in>t'. r' j *\<^sub>C j) )\<close>
    using htensor_distr_left_sum by force
  also have \<open>\<dots> = (\<Sum>i\<in>t. (\<Sum>j\<in>t'. (r i *\<^sub>C i) \<otimes>\<^sub>h (r' j *\<^sub>C j)) )\<close>
    by (metis (mono_tags, lifting) Finite_Cartesian_Product.sum_cong_aux htensor_distr_right_sum)
  also have \<open>\<dots> = (\<Sum>i\<in>t. (\<Sum>j\<in>t'. r i *\<^sub>C ( i \<otimes>\<^sub>h (r' j *\<^sub>C j) ) ) )\<close>
    by (meson htensor_mult_left sum.cong)
  also have \<open>\<dots> = (\<Sum>i\<in>t. (\<Sum>j\<in>t'. r i *\<^sub>C ( r' j *\<^sub>C (i \<otimes>\<^sub>h j) ) ) )\<close>
    by (metis (no_types, lifting) htensor_mult_right sum.cong)
  also have \<open>\<dots> = (\<Sum>i\<in>t. (\<Sum>j\<in>t'. (r i * r' j) *\<^sub>C (i \<otimes>\<^sub>h j) ) )\<close>
    by auto
  also have \<open>\<dots> = (\<Sum>z\<in>t\<times>t'. (r (fst z) * r' (snd z)) *\<^sub>C ((fst z) \<otimes>\<^sub>h (snd z)))\<close>
    using Groups_Big.comm_monoid_add_class.sum.cartesian_product [where A = "t"
        and B = "t'" and g = "\<lambda> i j. (r i * r' j) *\<^sub>C (i \<otimes>\<^sub>h j)"]
    by (metis (no_types, lifting) case_prod_beta' sum.cong)
  finally have \<open>(\<Sum>i\<in>t. r i *\<^sub>C i) \<otimes>\<^sub>h (\<Sum>j\<in>t'. r' j *\<^sub>C j) =
  (\<Sum>z\<in>t \<times> t'. (r (fst z) * r' (snd z)) *\<^sub>C (fst z \<otimes>\<^sub>h snd z))\<close>
    by blast
  thus ?thesis
    by (metis (mono_tags, lifting) case_prod_beta' sum.cong)
qed

(* TODO:
- Develop htensorVec (not sure about the name) htensorOp as you proposed. (In Tensor_Product.thy.)
- Derive all relevant laws with respect to htensorOp. (In Tensor_Product.thy.)
- Define and prove the isomorphism i ('a ell2 \otimes 'b ell2) -> ('a*'b) ell2). (In Tensor_Product_L2.thy.)
- Define tensorVec as "tensorVec a b = i (htensorVec a b)" and "tensorOp A B psi = i (htensorOp a b (inv i))". (In Tensor_Product_L2.thy.)
- Define some suitable transfer rules (we can discuss that in more details when you reach that point).
- Derive properties of tensorVec and tensorOp directly from those in Tensor_Product.thy using the transfer method.

*)

text \<open>Theorem 1, page 189 in @{cite Helemskii}\<close>
  (* TODO: Restructure proofs

 - remove hilbert_tensor_existence'_uniqueness
 - remove htensorOp_existence
 - show htensorOp_existence inside proof of htensorOp_separation
   (we don't need htensorOp_existence then because htensorOp_separation implies existence)
 - show the uniqueness without existence as
   (H satisfies the property) \<Longrightarrow> H=htensorOp

 (Alternatively, if the existence proof is constructive, define htensorOp constructively (without SOME))

*)

(* TODO: define using lift_definition (?) *)
definition htensor_map::
  \<open>(('a::chilbert_space \<otimes>\<^sub>a 'b::chilbert_space) completion
      \<Rightarrow> ('c::chilbert_space \<otimes>\<^sub>a 'd::chilbert_space) completion)
    \<Rightarrow> (('a \<otimes>\<^sub>h 'b) \<Rightarrow> ('c \<otimes>\<^sub>h 'd))\<close> where
  \<open>htensor_map f z = Abs_htensor (f (Rep_htensor z))\<close>

lift_definition htensor_bounded::
  \<open>(('a::chilbert_space \<otimes>\<^sub>a 'b::chilbert_space) completion,
   ('c::chilbert_space \<otimes>\<^sub>a 'd::chilbert_space) completion) cblinfun
\<Rightarrow> (('a \<otimes>\<^sub>h 'b), ('c \<otimes>\<^sub>h 'd)) cblinfun\<close> is htensor_map
proof
  fix f :: "('a \<otimes>\<^sub>a 'b) completion \<Rightarrow> ('c \<otimes>\<^sub>a 'd) completion"
  fix r :: complex and b b1 b2 :: \<open>'a \<otimes>\<^sub>h 'b\<close>
  assume "bounded_clinear f"
  show \<open>htensor_map f (r *\<^sub>C b) = r *\<^sub>C htensor_map f b\<close>
    unfolding htensor_map_def apply (transfer fixing: f)
    using \<open>bounded_clinear f\<close> by (simp add: bounded_clinear.clinear complex_vector.linear_scale)
  show \<open>htensor_map f (b1 + b2) = htensor_map f b1 + htensor_map f b2\<close>
    unfolding htensor_map_def apply (transfer fixing: f)
    using \<open>bounded_clinear f\<close> bounded_clinear_def complex_vector.linear_add by blast
  show "\<exists>K. \<forall>x. norm (htensor_map f (x::'a \<otimes>\<^sub>h 'b)::'c \<otimes>\<^sub>h 'd) \<le> norm x * K"
    if "bounded_clinear (f::('a \<otimes>\<^sub>a 'b) completion \<Rightarrow> ('c \<otimes>\<^sub>a 'd) completion)"
    by (metis (no_types, opaque_lifting) bounded_clinear.bounded htensor_map_def norm_htensor.abs_eq norm_htensor.rep_eq that)
qed

lemma Abs_htensor_continuous:
  fixes a :: \<open>('a::chilbert_space \<otimes>\<^sub>a 'b::chilbert_space) completion\<close>
  shows \<open>isCont Abs_htensor a\<close>
proof-
  have \<open>x \<longlonglongrightarrow> a \<Longrightarrow> (\<lambda> n. Abs_htensor (x n)) \<longlonglongrightarrow> Abs_htensor a\<close>
    for x::\<open>nat \<Rightarrow> ('a::chilbert_space \<otimes>\<^sub>a 'b::chilbert_space) completion\<close>
    using LIMSEQ_def[where X = "x" and L = "a"]
      LIMSEQ_def[where X = "(\<lambda> n. Abs_htensor (x n))" and L = "Abs_htensor a"]
    unfolding dist_htensor_def
    apply auto
    by (metis dist_htensor.abs_eq dist_htensor.rep_eq)
  thus ?thesis
    by (simp add: continuous_at_sequentiallyI)
qed

text\<open>Proposition 2 in @{cite Helemskii}, page 187\<close>
lemma htensor_continuous:
  fixes x::\<open>nat \<Rightarrow> 'a::chilbert_space\<close> and y::\<open>nat \<Rightarrow> 'b::chilbert_space\<close>
  assumes \<open>x \<longlonglongrightarrow> a\<close> and \<open>y \<longlonglongrightarrow> b\<close>
  shows \<open>(\<lambda> n. (x n) \<otimes>\<^sub>h (y n) ) \<longlonglongrightarrow> a \<otimes>\<^sub>h b\<close>
proof-
  have Abs_htensor1: \<open>z \<longlonglongrightarrow> t \<Longrightarrow> (\<lambda> n. Abs_htensor (z n)) \<longlonglongrightarrow> Abs_htensor t\<close>
    for z::\<open>nat \<Rightarrow> ('a \<otimes>\<^sub>a 'b) completion\<close>
      and t::\<open>('a \<otimes>\<^sub>a 'b) completion\<close>
  proof-
    assume \<open>z \<longlonglongrightarrow> t\<close>
    moreover have \<open>\<forall>x. x \<longlonglongrightarrow> t \<longrightarrow> (Abs_htensor \<circ> x) \<longlonglongrightarrow> Abs_htensor t\<close>
      for t::\<open>('a \<otimes>\<^sub>a 'b) completion\<close>
      using Abs_htensor_continuous[where a = "t"] continuous_at_sequentially[where f = "Abs_htensor" and a = "t"]
      by auto
    ultimately have \<open>(Abs_htensor \<circ> z) \<longlonglongrightarrow> Abs_htensor t\<close>
      by auto
    moreover have \<open>Abs_htensor \<circ> z = (\<lambda> n. Abs_htensor (z n))\<close>
      by auto
    ultimately show ?thesis by simp
  qed
  have \<open>(\<lambda>n. x n \<otimes>\<^sub>a y n) \<longlonglongrightarrow> a \<otimes>\<^sub>a b\<close>
    by (simp add: assms(1) assms(2) atensor_continuous)
  moreover have \<open>isCont inclusion_completion (a \<otimes>\<^sub>a b)\<close>
    by (simp add: inclusion_completion_continuous)
  ultimately have \<open>(\<lambda>n. inclusion_completion (x n \<otimes>\<^sub>a y n)) \<longlonglongrightarrow> inclusion_completion (a \<otimes>\<^sub>a b)\<close>
    using Elementary_Topology.continuous_at_sequentially[where f = "inclusion_completion" and a = "a \<otimes>\<^sub>a b"]
    by (simp add: comp_def)
  thus ?thesis
    unfolding htensor_op_def
    apply auto
    using Abs_htensor1
    by auto
qed

lemma htensor_cinner_mult:
  \<open>(x\<^sub>1 \<otimes>\<^sub>h y\<^sub>1) \<bullet>\<^sub>C (x\<^sub>2 \<otimes>\<^sub>h y\<^sub>2) = (x\<^sub>1 \<bullet>\<^sub>C x\<^sub>2) * (y\<^sub>1 \<bullet>\<^sub>C y\<^sub>2)\<close>
  apply transfer
  by (simp add: atensor_cinner_mult inclusion_completion_cinner)

lemma htensor_norm_mult:
  \<open>norm (x \<otimes>\<^sub>h y) = norm x * norm y\<close>
proof -
  have "norm x * norm y = sqrt (cmod (x \<bullet>\<^sub>C x)) * sqrt (cmod (y \<bullet>\<^sub>C y))"
    by (metis norm_eq_sqrt_cinner)
  thus ?thesis
    by (metis htensor_cinner_mult norm_eq_sqrt_cinner norm_mult real_sqrt_mult)
qed

(* Ask to Dominique: how to prove this *)
text\<open>Hilbert tensor product of bounded operators\<close>
lift_definition htensorOp :: \<open>('a::chilbert_space, 'b::chilbert_space) cblinfun
 \<Rightarrow> ('c::chilbert_space, 'd::chilbert_space) cblinfun \<Rightarrow> (('a \<otimes>\<^sub>h 'c), ('b \<otimes>\<^sub>h 'd)) cblinfun\<close>   (infixl "\<^sub>H\<otimes>" 70)
  is \<open>\<lambda> f::('a, 'b) cblinfun. \<lambda> g::('c, 'd) cblinfun. \<lambda> z::('a \<otimes>\<^sub>a 'c) completion. (completion_map (f \<^sub>A\<otimes> g)) *\<^sub>V z\<close>
  sorry

section \<open>Tensor product ell2\<close>

unbundle blinfun_notation

(* Widening type to allow infinite tensor products *)
setup \<open>Sign.add_const_constraint (\<^const_name>\<open>tensor_op\<close>, SOME \<^typ>\<open>'a ell2 \<Rightarrow>\<^sub>C\<^sub>L 'b ell2 \<Rightarrow> 'c ell2 \<Rightarrow>\<^sub>C\<^sub>L 'd ell2 \<Rightarrow> ('a \<times> 'c) ell2 \<Rightarrow>\<^sub>C\<^sub>L ('b \<times> 'd) ell2\<close>)\<close>
abbreviation (input) "tensorOp == tensor_op"

(* consts "tensorOp" :: "('a ell2,'b ell2) cblinfun \<Rightarrow> ('c ell2,'d ell2) cblinfun \<Rightarrow> (('a*'c) ell2,('b*'d) ell2) cblinfun" *)

type_synonym ('a, 'b) l2bounded = "('a ell2,'b ell2) cblinfun"

setup \<open>Sign.add_const_constraint (\<^const_name>\<open>tensor_ell2\<close>, SOME \<^typ>\<open>'a ell2 \<Rightarrow> 'b ell2 \<Rightarrow> ('a \<times> 'b) ell2\<close>)\<close>
abbreviation (input) "tensorVec == tensor_ell2"

(* lift_definition "tensorVec" :: "'a ell2 \<Rightarrow> 'c ell2 \<Rightarrow> ('a*'c) ell2" is
  "\<lambda>\<psi> \<phi> (x,y). \<psi> x * \<phi> y"
  sorry *)

definition tensorSpace :: "'a ell2 ccsubspace \<Rightarrow> 'b ell2 ccsubspace \<Rightarrow> ('a*'b) ell2 ccsubspace" (infixr "\<otimes>\<^sub>S" 70) where
  "tensorSpace A B = ccspan {tensorVec \<psi> \<phi>| \<psi> \<phi>. \<psi> \<in> space_as_set A \<and> \<phi> \<in> space_as_set B}"

consts tensor :: "'a \<Rightarrow> 'b \<Rightarrow> 'c" (infixr "\<otimes>" 71)
adhoc_overloading tensor "\<lambda>x. tensorOp x" "\<lambda>x. tensorSpace x" "\<lambda>x. tensorVec x"

lemma id_tensor_id[simp]: "id_cblinfun \<otimes> id_cblinfun = id_cblinfun"
  sorry

definition "comm_op" :: "(('a*'b) ell2, ('b*'a) ell2) cblinfun" where
  "comm_op = classical_operator (\<lambda>(a,b). Some (b,a))"

lemma adj_comm_op[simp]: "adj comm_op = comm_op"
  sorry

lemma
  comm_op_swap[simp]: "comm_op o\<^sub>C\<^sub>L (A\<otimes>B) o\<^sub>C\<^sub>L comm_op = B\<otimes>A"
  for A::"('a ell2,'b ell2) cblinfun" and B::"('c ell2,'d ell2) cblinfun"
  sorry

lemma comm_op_times_comm_op[simp]: "comm_op  o\<^sub>C\<^sub>L comm_op = id_cblinfun"
proof -
  have "comm_op  o\<^sub>C\<^sub>L (id_cblinfun \<otimes> id_cblinfun)  o\<^sub>C\<^sub>L comm_op = id_cblinfun \<otimes> id_cblinfun"
    by (simp del: id_tensor_id)
  thus ?thesis by simp
qed

lemma unitary_comm_op[simp]: "unitary comm_op"
  unfolding unitary_def sorry

definition "assoc_op" :: "(('a*('b*'c)) ell2, (('a*'b)*'c) ell2) cblinfun" where
  "assoc_op = classical_operator (\<lambda>(a,(b,c)). Some ((a,b),c))"

lemma unitary_assoc_op[simp]: "unitary assoc_op"
  sorry

lemma tensor_scalar_mult1[simp]: "(a *\<^sub>C A) \<otimes> B = a *\<^sub>C (A \<otimes> B)" for a::complex and A::"('a,'b)l2bounded" and B::"('c,'d)l2bounded"
  sorry
lemma tensor_scalar_mult1_ell2[simp]: "(a *\<^sub>C A) \<otimes> B = a *\<^sub>C (A \<otimes> B)" for a::complex and A::"_ ell2" and B::"_ ell2"
  sorry
lemma tensor_scalar_mult2[simp]: "A \<otimes> (a *\<^sub>C B) = a *\<^sub>C (A \<otimes> B)" for a::complex and A::"('a,'b)l2bounded" and B::"('c,'d)l2bounded"
  sorry
lemma tensor_scalar_mult2_ell2[simp]: "A \<otimes> (a *\<^sub>C B) = a *\<^sub>C (A \<otimes> B)" for a::complex and A::"_ ell2" and B::"_ ell2"
  sorry
lemma tensor_plus: "(A+B) \<otimes> C = A \<otimes> C + B \<otimes> C" for A B C :: "(_,_) cblinfun"
  sorry
lemma tensor_plus_ell2: "(A+B) \<otimes> C = A \<otimes> C + B \<otimes> C" for A B C :: "_ ell2"
  sorry
lemma tensor_norm_ell2: "norm (\<psi> \<otimes> \<phi>) = norm \<psi> * norm \<phi>" for \<psi> \<phi> :: "_ ell2"
  sorry

lemma tensor_times[simp]: "(U1 \<otimes> U2) o\<^sub>C\<^sub>L (V1 \<otimes> V2) = (U1 o\<^sub>C\<^sub>L V1) \<otimes> (U2 o\<^sub>C\<^sub>L V2)"
  for V1 :: "('a1,'b1) l2bounded" and U1 :: "('b1,'c1) l2bounded"
    and V2 :: "('a2,'b2) l2bounded" and U2 :: "('b2,'c2) l2bounded"
  sorry

lift_definition addState :: "'a ell2 \<Rightarrow> ('b ell2,('b*'a) ell2) cblinfun" is
  \<open>\<lambda>\<psi> \<phi>. tensorVec \<phi> \<psi>\<close>
  apply (rule_tac K="norm ell2" in bounded_clinear_intro)
  by (auto simp: tensor_norm_ell2 tensor_plus_ell2)

(* TODO: this is simply the adj of addState (1::unit ell2), and addState y is best defined as x \<rightarrow> x \<otimes> y (lifted).
   Do we even use remove_qvar_unit_op then? *)
consts remove_qvar_unit_op :: "(('a*unit) ell2,'a ell2) cblinfun"

(* definition addState :: "'a ell2 \<Rightarrow> ('b,'b*'a) l2bounded" where
  "addState \<psi> = id_cblinfun \<otimes> (ell2_to_bounded \<psi>) \<cdot> remove_qvar_unit_op*" *)

lemma addState_times_scalar[simp]: "addState (a *\<^sub>C \<psi>) = a *\<^sub>C addState \<psi>"
  for a::complex and \<psi>::"'a ell2"
  sorry

lemma tensor_adjoint[simp]: "adj (U\<otimes>V) = (adj U) \<otimes> (adj V)"
  for U :: "('a,'b) l2bounded" and V :: "('c,'d) l2bounded"
  sorry

lemma tensor_unitary[simp]:
  assumes "unitary U" and "unitary V"
  shows "unitary (U\<otimes>V)"
  using assms unfolding unitary_def by simp

lemma tensor_isometry[simp]:
  assumes "isometry U" and "isometry V"
  shows "isometry (U\<otimes>V)"
  using assms unfolding isometry_def by simp

unbundle no_cblinfun_notation

end


header "Base"

theory Base
imports PermutationLemmas
begin

subsection "Integrate with Isabelle libraries?"

    --  "Misc"

  -- "FIXME added by tjr, forms basis of a lot of proofs of existence of inf sets"
  -- "something like this should be in FiniteSet, asserting nats are not finite"
lemma natset_finite_max: assumes a: "finite A"
  shows "Suc (Max A) \<notin> A"
proof (cases "A = {}")
  case True
  thus ?thesis by auto
next
  case False
  with a have "Max A \<in> A \<and> (\<forall>s \<in> A. s \<le> Max A)" by simp
  thus ?thesis by auto
qed

    -- "not used"
lemma not_finite_univ: "~ finite (UNIV::nat set)"
  apply rule
  apply(drule_tac natset_finite_max)
  by force

  -- "FIXME should be in main lib"
lemma LeastI_ex: "(\<exists> x. P (x::'a::wellorder)) \<Longrightarrow> P (LEAST x. P x)"
  by(blast intro: LeastI)

subsection "Summation"

primrec summation :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat"
where
  "summation f 0 = f 0"
| "summation f (Suc n) = f (Suc n) + summation f n"

subsection "Termination Measure"

primrec exp :: "[nat,nat] \<Rightarrow> nat"
where
  "exp x 0       = 1"
| "exp x (Suc m) = x * exp x m"

primrec sumList     :: "nat list \<Rightarrow> nat"
where
  "sumList []     = 0"
| "sumList (x#xs) = x + sumList xs"

subsection "Functions"

definition
  preImage :: "('a \<Rightarrow> 'b) \<Rightarrow> 'b set \<Rightarrow> 'a set" where
  "preImage f A = { x . f x \<in> A}"

definition
  pre :: "('a \<Rightarrow> 'b) => 'b \<Rightarrow> 'a set" where
  "pre f a = { x . f x = a}"

definition
  equalOn :: "['a set,'a => 'b,'a => 'b] => bool" where
  "equalOn A f g = (!x:A. f x = g x)"

lemma preImage_insert: "preImage f (insert a A) = pre f a Un preImage f A"
  by(auto simp add: preImage_def pre_def)

lemma preImageI: "f x : A ==> x : preImage f A"
  by(simp add: preImage_def)

lemma preImageE: "x : preImage f A ==> f x : A"
  by(simp add: preImage_def)

lemma equalOn_Un:  "equalOn (A \<union> B) f g = (equalOn A f g \<and> equalOn B f g)"
  by(auto simp add: equalOn_def)

lemma equalOnD: "equalOn A f g \<Longrightarrow> (\<forall> x \<in> A . f x = g x)"
  by(simp add: equalOn_def)

lemma equalOnI:"(\<forall> x \<in> A . f x = g x) \<Longrightarrow> equalOn A f g"
  by(simp add: equalOn_def)

lemma equalOn_UnD: "equalOn (A Un B) f g ==> equalOn A f g & equalOn B f g"
  by(auto simp: equalOn_def)

    -- "FIXME move following elsewhere?"
lemma inj_inv_singleton[simp]: "\<lbrakk> inj f; f z = y \<rbrakk> \<Longrightarrow> {x. f x = y} = {z}"
  apply rule
  apply(auto simp: inj_on_def) done

lemma finite_pre[simp]: "inj f \<Longrightarrow> finite (pre f x)"
  apply(simp add: pre_def)
  apply (cases "\<exists> y. f y = x", auto) done

lemma finite_preImage[simp]: "\<lbrakk> finite A; inj f \<rbrakk> \<Longrightarrow> finite (preImage f A)"
  apply(induct A rule: finite_induct)
  apply(simp add: preImage_def)
  apply(simp add: preImage_insert) done

end


section\<open>List Product Helpers\<close>
theory List_Product_More
imports Main
begin

(*TODO: this definition could also go to Main*)
lemma List_product_concat_map: "List.product xs ys = concat (map (\<lambda>x. map (\<lambda>y. (x,y)) ys) xs)"
  by(induction xs) (simp)+

definition all_pairs :: "'a list \<Rightarrow> ('a \<times> 'a) list" where
  "all_pairs xs \<equiv> concat (map (\<lambda>x. map (\<lambda>y. (x,y)) xs) xs)"

lemma all_pairs_list_product: "all_pairs xs = List.product xs xs"
  by(simp add: all_pairs_def List_product_concat_map)

lemma all_pairs: "\<forall> (x,y) \<in> (set xs \<times> set xs). (x,y) \<in> set (all_pairs xs)"
  by(simp add: all_pairs_list_product)

lemma all_pairs_set: "set (all_pairs xs) = set xs \<times> set xs"
  by(simp add: all_pairs_list_product)

end


(*  Title:       Countable Ordinals

    Author:      Brian Huffman, 2005
    Maintainer:  Brian Huffman <brianh at cse.ogi.edu>
*)

section \<open>Recursive Definitions\<close>

theory OrdinalRec
imports OrdinalCont
begin

definition
  oPrec :: "ordinal \<Rightarrow> ordinal" where
  "oPrec x = (THE p. x = oSuc p)"

lemma oPrec_oSuc [simp]: "oPrec (oSuc x) = x"
by (unfold oPrec_def, rule the_equality, simp_all)

lemma oPrec_less: "\<exists>p. x = oSuc p \<Longrightarrow> oPrec x < x"
by clarsimp

definition
  ordinal_rec0 ::
    "['a, ordinal \<Rightarrow> 'a \<Rightarrow> 'a, (nat \<Rightarrow> 'a) \<Rightarrow> 'a, ordinal] \<Rightarrow> 'a" where
  "ordinal_rec0 z s l \<equiv> wfrec {(x,y). x < y} (\<lambda>F x.
    if x = 0 then z else
    if (\<exists>p. x = oSuc p) then s (oPrec x) (F (oPrec x)) else
    (THE y. \<forall>f. (\<forall>n. f n < oLimit f) \<and> oLimit f = x
            \<longrightarrow> l (\<lambda>n. F (f n)) = y))"

lemma ordinal_rec0_0:
"ordinal_rec0 z s l 0 = z"
 apply (rule trans[OF def_wfrec[OF ordinal_rec0_def wf]])
 apply simp
done

lemma ordinal_rec0_oSuc:
"ordinal_rec0 z s l (oSuc x) = s x (ordinal_rec0 z s l x)"
 apply (rule trans[OF def_wfrec[OF ordinal_rec0_def wf]])
 apply (simp add: cut_apply)
done

lemma limit_ordinal_not_0: "limit_ordinal x \<Longrightarrow> x \<noteq> 0"
by (clarsimp)

lemma limit_ordinal_not_oSuc: "limit_ordinal x \<Longrightarrow> x \<noteq> oSuc p"
by (clarsimp)

lemma ordinal_rec0_limit_ordinal:
"limit_ordinal x \<Longrightarrow> ordinal_rec0 z s l x =
 (THE y. \<forall>f. (\<forall>n. f n < oLimit f) \<and> oLimit f = x \<longrightarrow>
   l (\<lambda>n. ordinal_rec0 z s l (f n)) = y)"
 apply (rule trans[OF def_wfrec[OF ordinal_rec0_def wf]])
 apply (simp add: limit_ordinal_not_oSuc limit_ordinal_not_0)
 apply (rule_tac f=The in arg_cong, rule ext)
 apply (rule_tac f=All in arg_cong, rule ext)
 apply safe
  apply (simp add: cut_apply)
 apply (simp add: cut_apply)
done

subsection \<open>Partial orders\<close>

locale porder =
  fixes le  :: "'a \<Rightarrow> 'a \<Rightarrow> bool" (infixl "<<" 55)
assumes po_refl:    "\<And>x. x << x"
    and po_trans:   "\<And>x y z. \<lbrakk>x << y; y << z\<rbrakk> \<Longrightarrow> x << z"
    and po_antisym: "\<And>x y. \<lbrakk>x << y; y << x\<rbrakk> \<Longrightarrow> x = y"

lemma porder_order: "porder ((\<le>) :: 'a::order \<Rightarrow> 'a \<Rightarrow> bool)"
 apply (rule porder.intro)
   apply (rule order_refl)
  apply (rule order_trans, assumption+)
 apply (rule order_antisym, assumption+)
done

lemma (in porder) flip: "porder (\<lambda>x y. y << x)"
 apply (rule porder.intro)
   apply (rule po_refl)
  apply (rule po_trans, assumption+)
 apply (rule po_antisym, assumption+)
done

locale omega_complete = porder +
fixes lub :: "(nat \<Rightarrow> 'a) \<Rightarrow> 'a"
assumes is_ub_lub: "\<And>f n. f n << lub f"
assumes is_lub_lub: "\<And>f x. \<forall>n. f n << x \<Longrightarrow> lub f << x"

lemma (in omega_complete) lub_cong_lemma:
"\<lbrakk>\<forall>n. f n < oLimit f; \<forall>m. g m < oLimit g; oLimit f \<le> oLimit g;
 \<forall>y<oLimit g. \<forall>x\<le>y. F x << F y\<rbrakk>
 \<Longrightarrow> lub (\<lambda>n. F (f n)) << lub (\<lambda>n. F (g n))"
 apply (rule is_lub_lub[rule_format])
 apply (subgoal_tac "f n < oLimit g")
  apply (drule less_oLimitD, clarify, rename_tac m)
  apply (drule_tac x="g m" in spec, drule mp)
   apply (erule spec)
  apply (drule_tac x="f n" in spec, drule mp)
   apply (erule order_less_imp_le)
  apply (erule po_trans)
  apply (rule is_ub_lub)
 apply (rule order_less_le_trans)
  apply (erule spec)
 apply assumption
done

lemma (in omega_complete) lub_cong:
"\<lbrakk>\<forall>n. f n < oLimit f; \<forall>m. g m < oLimit g; oLimit f = oLimit g;
 \<forall>y<oLimit g. \<forall>x\<le>y. F x << F y\<rbrakk>
 \<Longrightarrow> lub (\<lambda>n. F (f n)) = lub (\<lambda>n. F (g n))"
 apply (rule po_antisym)
  apply (rule lub_cong_lemma, assumption+)
   apply (simp add: po_refl)
  apply assumption
 apply (rule lub_cong_lemma, assumption+)
  apply (simp add: po_refl)
 apply (drule sym, simp)
done

lemma (in omega_complete) ordinal_rec0_mono_lemma:
assumes s: "\<forall>p x. x << s p x"
shows "\<forall>y\<le>w. \<forall>x\<le>y. ordinal_rec0 z s lub x << ordinal_rec0 z s lub y"
 apply (rule_tac a=w in oLimit_induct)
   apply (simp add: po_refl)
  apply clarify
  apply (erule le_oSucE, simp, clarsimp)
  apply (erule le_oSucE)
   apply (drule spec, drule mp, rule order_refl)
   apply (drule spec, drule mp, assumption)
   apply (erule po_trans)
   apply (simp add: ordinal_rec0_oSuc s)
  apply (simp add: po_refl)
 apply clarify
 apply (erule le_oLimitE)
  apply simp
 apply clarsimp
 apply (subgoal_tac "ordinal_rec0 z s lub (oLimit f) =
                     lub (\<lambda>n. ordinal_rec0 z s lub (f n))")
  apply (erule le_oLimitE)
   apply (drule_tac x=n in spec)
   apply (drule spec, drule mp, rule order_refl)
   apply (drule spec, drule mp, assumption)
   apply (erule po_trans)
   apply (simp, rule is_ub_lub)
  apply (simp add: po_refl)
 apply (simp only: ordinal_rec0_limit_ordinal strict_mono_limit_ordinal)
 apply (rule the_equality, clarify)
  apply (rule lub_cong, assumption)
    apply (simp add: strict_mono_less_oLimit)
   apply assumption
  apply clarify
  apply (drule less_oLimitD, clarify)
  apply (drule order_less_imp_le)
  apply simp
 apply (drule_tac x=f in spec, simp add: strict_mono_less_oLimit)
done

lemma (in omega_complete) ordinal_rec0_mono:
assumes s: "\<forall>p x. x << s p x"
shows "x \<le> y \<Longrightarrow> ordinal_rec0 z s lub x << ordinal_rec0 z s lub y"
 apply (rule ordinal_rec0_mono_lemma[OF s, rule_format])
  apply (rule order_refl)
 apply assumption
done

lemma (in omega_complete) ordinal_rec0_oLimit:
assumes s: "\<forall>p x. x << s p x"
shows "ordinal_rec0 z s lub (oLimit f) =
         lub (\<lambda>n. ordinal_rec0 z s lub (f n))"
 apply (case_tac "\<forall>n. f n < oLimit f")
  apply (simp add: ordinal_rec0_limit_ordinal limit_ordinal_oLimitI)
  apply (rule the_equality, clarify)
   apply (rule lub_cong, assumption+)
   apply clarify
   apply (erule ordinal_rec0_mono[OF s])
  apply (drule_tac x=f in spec, simp)
 apply (simp add: linorder_not_less, clarify)
 apply (rule po_antisym)
  apply (erule po_trans[OF ordinal_rec0_mono[OF s]])
  apply (rule is_ub_lub)
 apply (rule is_lub_lub[rule_format])
 apply (rule ordinal_rec0_mono[OF s le_oLimit])
done

subsection \<open>Recursive definitions for @{typ "ordinal => ordinal"}\<close>

definition
  ordinal_rec ::
    "[ordinal, ordinal \<Rightarrow> ordinal \<Rightarrow> ordinal, ordinal] \<Rightarrow> ordinal" where
  "ordinal_rec z s = ordinal_rec0 z s oLimit"

lemma omega_complete_oLimit: "omega_complete (\<le>) oLimit"
 apply (rule omega_complete.intro)
  apply (rule porder_order)
 apply (rule omega_complete_axioms.intro)
  apply (rule le_oLimit)
 apply (erule oLimit_leI)
done

lemma ordinal_rec_0 [simp]: "ordinal_rec z s 0 = z"
by (unfold ordinal_rec_def, rule ordinal_rec0_0)

lemma ordinal_rec_oSuc [simp]:
"ordinal_rec z s (oSuc x) = s x (ordinal_rec z s x)"
by (unfold ordinal_rec_def, rule ordinal_rec0_oSuc)

lemma ordinal_rec_oLimit:
assumes s: "\<forall>p x. x \<le> s p x"
shows "ordinal_rec z s (oLimit f) = oLimit (\<lambda>n. ordinal_rec z s (f n))"
 apply (unfold ordinal_rec_def)
 apply (rule omega_complete.ordinal_rec0_oLimit)
  apply (rule omega_complete_oLimit)
 apply (rule s)
done

lemma continuous_ordinal_rec:
assumes s: "\<forall>p x. x \<le> s p x"
shows "continuous (ordinal_rec z s)"
 apply (rule continuousI)
  apply (rule ordinal_rec_oLimit[OF s])
 apply (simp add: s)
done

lemma mono_ordinal_rec:
assumes s: "\<forall>p x. x \<le> s p x"
shows "mono (ordinal_rec z s)"
 apply (rule continuous.mono)
 apply (rule continuous_ordinal_rec[OF s])
done

lemma normal_ordinal_rec:
assumes s: "\<forall>p x. x < s p x"
shows "normal (ordinal_rec z s)"
 apply (rule normalI)
  apply (rule ordinal_rec_oLimit)
  apply (simp add: s order_less_imp_le)
 apply (simp add: s)
done

end


(*
Author: Alexander Katovsky
*)

section "Universe"

theory Universe
imports "~~/src/HOL/ZF/MainZF"
begin

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

end


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

datatype ('a, 'b) pair = pair2 "'a" "'b"

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

datatype Nat = Z | S "Nat"

fun zip :: "'a list => 'b list => (('a, 'b) pair) list" where
  "zip (nil2) z = nil2"
| "zip (cons2 z2 x2) (nil2) = nil2"
| "zip (cons2 z2 x2) (cons2 x3 x4) =
     cons2 (pair2 z2 x3) (zip x2 x4)"

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

fun take :: "Nat => 'a list => 'a list" where
  "take (Z) z = nil2"
| "take (S z2) (nil2) = nil2"
| "take (S z2) (cons2 x2 x3) = cons2 x2 (take z2 x3)"

fun len :: "'a list => Nat" where
  "len (nil2) = Z"
| "len (cons2 z xs) = S (len xs)"

fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) z = z"
| "drop (S z2) (nil2) = nil2"
| "drop (S z2) (cons2 x2 x3) = drop z2 x3"

theorem property0 :
  "((zip xs (x ys zs)) =
      (x (zip (take (len ys) xs) ys) (zip (drop (len ys) xs) zs)))"
  oops

end


theory Missing_Sums
  imports  Linear_Inequalities.Integer_Hull
    Jordan_Normal_Form.Missing_VectorSpace
begin

context gram_schmidt
begin

lemma nonneg_each_smaller_than_sum:
  fixes c :: "'b \<Rightarrow> 'a :: trivial_conjugatable_linordered_field"
  assumes "finite S"
  assumes "\<forall>i \<in> S. c i \<ge> 0"
  shows "\<forall>i \<in> S. c i \<le> sum c S"
  using member_le_sum[of _ S c]  assms by auto

lemma nonneg_sum_range_each_le:
  fixes f :: "nat \<Rightarrow> 'a"
  assumes "\<forall>i < m. f i \<ge> 0"
  shows "\<forall>i < m. f i \<le> sum f {0..<m}"
  using nonneg_each_smaller_than_sum[of "{0..<m}" f]
  by (meson assms atLeastLessThan_iff finite_atLeastLessThan zero_le)

lemma sum_range_divided_at_zero:
  fixes f :: "nat \<Rightarrow> 'a :: trivial_conjugatable_linordered_field"
  shows "f 0 + sum f {1..<k +1} = sum f {0..<k+1}"
  by (auto simp: sum.atLeast_Suc_lessThan)

lemma sumlist_map_carr:
  assumes "f : set A \<rightarrow> carrier_vec n"
  shows "sumlist (map f A) \<in> carrier_vec n"
proof -
  have "set (map f A) \<subseteq> carrier_vec  n"
    using  Pi_mem
    using assms by auto
  then show ?thesis
    using M.sumlist_carrier by blast
qed

lemma sumlist_map_mult:
  assumes "f : set xs \<rightarrow> carrier_vec n"
  assumes "k \<noteq> 0"
  shows "sumlist (map f xs) =  k \<cdot>\<^sub>v sumlist (map (\<lambda>i. (1/k)\<cdot>\<^sub>v(f i)) xs)"
  using assms(1-2)
proof(induct xs)
  case (Cons a xs)
  have f_carr: "f \<in> set xs \<rightarrow> carrier_vec n"
    using Cons.prems(1) by auto
  have " k \<cdot>\<^sub>v ((\<lambda>i. 1 / k \<cdot>\<^sub>v f i) a + sumlist (map (\<lambda>i. 1 / k \<cdot>\<^sub>v f i) xs)) =
     k \<cdot>\<^sub>v ((\<lambda>i. 1 / k \<cdot>\<^sub>v f i) a) + k \<cdot>\<^sub>v (sumlist (map (\<lambda>i. 1 / k \<cdot>\<^sub>v f i) xs))"
    apply(rule smult_add_distrib_vec[of _ n])
     apply(auto)
    using Cons.prems(1)
     apply(auto simp: Pi_mem)
    apply (rule sumlist_map_carr)
    using f_carr by blast
  then show ?case
    by (simp add: Cons.hyps assms(2) f_carr smult_smult_assoc)
qed simp

lemma lincomb_in_integer_set:
  assumes "set xs \<subseteq> carrier_vec n"
  assumes "set xs \<subseteq> P \<inter> \<int>\<^sub>v"
  assumes "P = integer_hull P"
  assumes "sum c {0..<length xs} = 1"
  assumes "(\<forall>i<length xs. 0 \<le> c i) "
  shows "lincomb_list c xs \<in> P"
proof -
  have "convex_lincomb_list c xs (lincomb_list c xs)"
    unfolding convex_lincomb_list_def nonneg_lincomb_list_def
    using assms(5) assms(4) by blast
  have "convex_hull (set xs) = convex_hull_list xs"
    using assms(1) finite_convex_hull_iff_convex_hull_list by auto
  then have "lincomb_list c xs \<in> convex_hull (set xs)"
    unfolding convex_hull_list_def
    using \<open>convex_lincomb_list c xs (lincomb_list c xs)\<close> by blast
  have "convex_hull (set xs) \<subseteq> convex_hull (P \<inter> \<int>\<^sub>v)"
    using assms(2) convex_hull_mono by presburger
  then show "lincomb_list c xs \<in> P"
    using \<open>lincomb_list c xs \<in> convex_hull (set xs)\<close> assms(3) integer_hull_def by blast
qed

lemma sumlist_swap_upd_same:
  assumes "set xs \<subseteq> carrier_vec n"
  assumes "i < length xs"
  assumes "j < length xs"
  shows "sumlist (xs[i:= xs ! j, j:= xs ! i]) = sumlist xs"
  by (auto simp: sumlist_as_summset assms perm_swap)

lemma sumlist_swap_upd_same':
  assumes "set xs \<subseteq> carrier_vec n"
  assumes "i < length xs"
  assumes "j < length xs"
  shows " sumlist xs = sumlist (xs[i:= xs ! j, j:= xs ! i])"
  by (auto simp: sumlist_as_summset assms perm_swap)

lemma add_zero_to_range_list:
  assumes "m > 0"
  shows "0 # [1..< m] = [0..<m]"
  using upt_eq_Cons_conv[of 0 m 0 "[1..< m]"]
  by (auto simp: assms)

lemma map_swap_fun_same:
  fixes xs :: "'a vec list"
  assumes "i < length xs"
  assumes "j < length xs"
  shows "(map (f(i:=f j, j := f i))[0..<length (xs[i := xs ! j, j := xs ! i])]) =
      (map f [0..<length xs])[i := (map f [0..<length xs]) ! j, j := (map f [0..<length xs]) ! i]"
  by (simp add: assms  map_nth_eq_conv)

lemma swap_fun_nonneg:
  assumes "i < length xs"
  assumes "j < length xs"
  assumes "\<forall>ia < length xs. 0 \<le> f ia"
  shows "\<forall>ia < length xs. 0 \<le> (f(i := f j, j := f i)) ia"
  using assms by auto

lemma swap_zero_fun_nonneg:
  assumes "j < length xs"
  assumes "\<forall>ia < length xs. 0 \<le> f ia"
  shows "\<forall>ia < length xs. 0 \<le> (f(0 := f j, j := f 0)) ia"
  using assms swap_fun_nonneg
  by (metis bot_nat_0.not_eq_extremum less_nat_zero_code)

lemma sum_of_swap_fun_eq:
  assumes "finite A"
  assumes "i \<in> A"
  assumes "j \<in> A"
  shows "sum (f(i := f j, j := f i)) A = sum f A"
proof -
  let ?g = "(f(i := f j, j := f i))"
  have "{i, j} \<subseteq> A"
    using assms(2) assms(3) by blast
  have sum_union_f: "sum f A = sum f (A - {i, j}) + sum f {i, j}"
    by (intro sum.subset_diff[of "{i, j}" A f] assms(1) `{i, j} \<subseteq> A` )
  have sum_union_g: "sum ?g A = sum ?g (A - {i, j}) + sum ?g {i, j}"
    by (intro sum.subset_diff[of "{i, j}" A ?g] assms(1) `{i, j} \<subseteq> A` )
  show "sum (f(i := f j, j := f i)) A = sum f A"
    apply(simp only:sum_union_f sum_union_g)
    by (cases "i = j"; auto simp: add.commute)
qed

lemma zero_vec_is_int:
  shows "0\<^sub>v n \<in>  \<int>\<^sub>v"
  unfolding Ints_vec_def zero_vec_def
  by fastforce

lemma sum_int_is_int:
  assumes "a \<in> carrier_vec n"
  assumes "b \<in> carrier_vec n"
  assumes "a \<in> \<int>\<^sub>v"
  assumes "b \<in> \<int>\<^sub>v"
  shows "a + b \<in> \<int>\<^sub>v"
  using assms unfolding Ints_vec_def by force

lemma diff_int_is_int:
  assumes "a \<in> carrier_vec n"
  assumes "b \<in> carrier_vec n"
  assumes "a \<in> \<int>\<^sub>v"
  assumes "b \<in> \<int>\<^sub>v"
  shows "a - b \<in> \<int>\<^sub>v"
  using assms unfolding Ints_vec_def by force

lemma sumlist_map_append:
  assumes "f : {0..<Suc m} \<rightarrow> carrier_vec n"
  shows "sumlist (map f [0..<Suc m]) = sumlist (map f [0..<m]) + f m"
  using sumlist_snoc[of "(map f [0..<m])" "f m"] assms
  by force

lemma sumlist_of_ints_is_int:
  assumes "f : {0..<m} \<rightarrow> carrier_vec n"
  assumes "\<forall>j < m. f  j \<in> \<int>\<^sub>v"
  shows "sumlist (map f [0..<m]) \<in> \<int>\<^sub>v"
  using assms
proof(induct m)
  case (Suc m)
  have f_carr:"f \<in> {0..<m} \<rightarrow> carrier_vec n"
    using Suc.prems(1) by auto
  have sum_carr:"sumlist (map f [0..<m]) \<in> carrier_vec n"
    by  (auto simp: sumlist_map_carr f_carr)
  show ?case
    apply (simp only: sumlist_map_append[of f m] Suc.prems(1))
    apply(intro sum_int_is_int)
    using sum_carr  apply blast
    using Suc.prems(1) apply auto
    using Suc.hyps f_carr  Suc.prems(2) less_Suc_eq apply presburger
    by (simp add: Suc.prems(2))
qed (simp add: zero_vec_is_int)

lemma sum_mono_nonneg:
  fixes f :: "'b \<Rightarrow> 'a"
  assumes "finite S"
  assumes "\<forall>i \<in> S. f i \<ge> 0"
  assumes "F \<subseteq> S"
  shows "sum f F \<le> sum f S"
  using sum_mono2[of S F f] assms DiffD1
  by blast

lemma sum_eq_one_elem_other_zero:
  fixes f :: "'b \<Rightarrow> 'a"
  assumes "finite S"
  assumes "\<forall>i \<in> S. f i \<ge> 0"
  assumes "i \<in> S"
  assumes "f i = sum f S"
  assumes "j \<in> S \<and> j \<noteq> i"
  shows "f j = 0"
proof(rule ccontr)
  assume "f j \<noteq> 0"
  then have "f j > 0"
    using assms(2) assms(5) dual_order.order_iff_strict by blast
  have "sum f {i, j} \<le> sum f S" using sum_mono_nonneg[of S f "{i, j}"]
    using assms(1) assms(2) assms(3) assms(5) by fastforce
  then show False using assms `f j > 0`
    by force
qed

lemma int_mult_int_vec:
  assumes "a \<in> \<int>\<^sub>v"
  assumes "k \<in> \<int>"
  shows "k \<cdot>\<^sub>v a \<in> \<int>\<^sub>v"
  using assms(1) assms(2) indexed_Ints_vec_UNIV smult_indexed_Ints_vec by blast

lemma convex_lincom_int:
  assumes "convex_lincomb_list c L x"
  assumes "set L \<subseteq> \<int>\<^sub>v"
  assumes "set L \<subseteq> carrier_vec n"
  assumes "\<forall>i < length L. c i \<in> \<int>"
  shows "x \<in> \<int>\<^sub>v"
proof -
  have "\<forall>j < length L. (\<lambda>i. c i \<cdot>\<^sub>v L ! i)  j \<in> \<int>\<^sub>v"
    using assms(2) assms(4) nth_mem int_mult_int_vec by blast
  then have "sumlist (map (\<lambda>i. c i \<cdot>\<^sub>v L ! i) [0..<length L]) \<in>  \<int>\<^sub>v"
    using sumlist_of_ints_is_int[of "(\<lambda>i. c i \<cdot>\<^sub>v L ! i)" "length L"] assms(3) by fastforce
  then show "x \<in> \<int>\<^sub>v"
    using assms(1)
    unfolding convex_lincomb_list_def lincomb_list_def nonneg_lincomb_list_def
    by blast
qed

lemma convex_lincomb_less_1_coeff:
  assumes "convex_lincomb_list c L x"
  assumes "x \<notin> \<int>\<^sub>v"
  assumes "set L \<subseteq> \<int>\<^sub>v"
  assumes "set L \<subseteq> carrier_vec n"
  assumes "i < length L"
  shows "c i < 1"
proof -
  have fin:"finite (set L)"
    by simp
  have nonneg_sum_1: "(\<forall> i < length L. c i \<ge> 0) \<and> sum c {0..<length L} = 1"
    using assms(1) convex_lincomb_list_def nonneg_lincomb_list_def by blast
  show "c i < 1"
  proof(rule ccontr)
    assume " \<not> c i < 1"
    then have "c i = 1"
      using  nonneg_sum_range_each_le[of "length L" c]
        assms(5) nonneg_sum_1 order_le_imp_less_or_eq
      by metis
    have "\<forall>j < length L. i \<noteq> j \<longrightarrow> c j = 0"
      using sum_eq_one_elem_other_zero[of "{0..<length L}" c i]
      by (auto simp: \<open>c i = 1\<close> assms(5) nonneg_sum_1)
    then have "x \<in> \<int>\<^sub>v" using convex_lincom_int[of c L x]
      by (metis Ints_0 Ints_1 \<open>c i = 1\<close> assms(1) assms(3) assms(4))
    then show False
      by (simp add: assms(2))
  qed
qed

lemma map_shift_by_one:
  "(map (\<lambda>i. f i \<cdot>\<^sub>v (a # ax) ! i) [1..<length (a # ax)]) =
    (map (\<lambda> i. (f (i+1)) \<cdot>\<^sub>v ax ! i) [0..<length ax])"
proof -
  have append_shift:"\<forall> i < length ax. ([Suc 0..<length ax] @ [length ax]) ! i = i + 1"
    using nth_upt[of 1 _ "length ax + 1"] by auto
  have "(map (\<lambda> i. (f (i+1) \<cdot>\<^sub>v (a # ax) ! (i+1))) [0..<length ax]) =
    (map (\<lambda> i. (f i \<cdot>\<^sub>v (a # ax) ! i)) [1..<length ax + 1])"
    apply (auto simp: map_eq_conv' append_shift)
    by (metis Suc_leI length_greater_0_conv)
  then show ?thesis
    by auto
qed

lemma length_upt_same:
  shows "length (xs[0 := xs ! i, i := xs ! 0]) = length xs"
  by auto

lemma lincomb_map_set_carrier:
  assumes "set Wsl \<subseteq> carrier_vec n"
  shows "set (map (\<lambda>ia. c ia \<cdot>\<^sub>v Wsl ! ia) [0..<length Wsl]) \<subseteq> carrier_vec n"
proof
  fix z
  assume "z \<in> set (map (\<lambda>ia. c ia \<cdot>\<^sub>v Wsl ! ia) [0..<length Wsl])"
  then obtain j where "j <length Wsl \<and> z = c j \<cdot>\<^sub>v Wsl ! j"
    by auto
  then show "z \<in> carrier_vec n"
    using assms(1) nth_mem
    using smult_carrier_vec by blast
qed

lemma sumlist_upt_same:
  assumes "set Wsl \<subseteq> carrier_vec n"
  assumes "i < length Wsl"
  shows "(M.sumlist (map (\<lambda>ia. (c(0 := c i, i := c 0)) ia \<cdot>\<^sub>v Wsl[0 := Wsl ! i, i := Wsl ! 0] ! ia)
         [0..<length (Wsl[0 := Wsl ! i, i := Wsl ! 0])])) =
          (M.sumlist (map (\<lambda>ia. c ia \<cdot>\<^sub>v Wsl ! ia) [0..<length Wsl]))"
proof -
  have 0: "0 < length Wsl"
    using assms(2) by linarith
  have 1: "(\<lambda>ia. c ia \<cdot>\<^sub>v Wsl ! ia)(0 := c i \<cdot>\<^sub>v Wsl ! i, i := c 0 \<cdot>\<^sub>v Wsl ! 0) =
            (\<lambda>ia. (c(0 := c i, i := c 0)) ia \<cdot>\<^sub>v Wsl[0 := Wsl ! i, i := Wsl ! 0] ! ia)"
    using \<open>i < length Wsl\<close>  nth_mem 0 length_pos_if_in_set  by fastforce
  show ?thesis
    apply (insert sumlist_swap_upd_same[of "(map (\<lambda>ia. c ia \<cdot>\<^sub>v Wsl ! ia) [0..<length Wsl])" 0 i])
    apply (insert map_swap_fun_same[of 0 Wsl i "(\<lambda>ia. c ia \<cdot>\<^sub>v Wsl ! ia)"] )
    apply (simp only: assms lincomb_map_set_carrier[of Wsl c] 1 0 length_map less_nat_zero_code)
    using assms(2) by fastforce
qed

lemma convex_lincomb_list_swap:
  assumes "convex_lincomb_list c Wsl x"
  assumes "set Wsl \<subseteq> carrier_vec n"
  assumes "i < length Wsl"
  shows "convex_lincomb_list (c(0 := c i, i := c 0)) (Wsl[0 := Wsl ! i, i := Wsl ! 0]) x"
proof -
  have cll:"(lincomb_list c Wsl = x \<and> (\<forall>i<length Wsl. 0 \<le> c i)) \<and> sum c {0..<length Wsl} = 1"
    using assms unfolding convex_lincomb_list_def nonneg_lincomb_list_def by auto
  have x_sumlist: "sumlist (map (\<lambda>ia. c ia \<cdot>\<^sub>v Wsl ! ia) [0..<length Wsl]) = x"
    using cll unfolding lincomb_list_def by auto
  show ?thesis
    unfolding convex_lincomb_list_def  nonneg_lincomb_list_def lincomb_list_def
    apply(simp only: length_upt_same)
    apply(intro conjI)
    using sumlist_upt_same[of Wsl i c] apply (simp add: x_sumlist assms(2) assms(3))
    using swap_zero_fun_nonneg[of i Wsl c] assms(3) cll  apply presburger
    using sum_of_swap_fun_eq[of "{0..<length Wsl}" 0 i c]
    by (metis assms(3) atLeastLessThan_iff cll linorder_le_less_linear
        not_less_zero sum.infinite zero_less_iff_neq_zero)
qed

lemma convex_lincomb_in_convex_hull_list:
  assumes "set L \<subseteq> carrier_vec n"
  assumes "convex_lincomb c' (set L) x"
  shows "x \<in> convex_hull_list L"
proof -
  have "convex_hull_list L = convex_hull (set L)"
    by (simp add: assms(1) finite_convex_hull_iff_convex_hull_list)
  then show "x \<in> convex_hull_list L"
    using assms(2) convex_hull_def
    by blast
qed

lemma obt_convect_lincomb_list:
  assumes "set L \<subseteq> carrier_vec n"
  assumes "convex_lincomb c' (set L) x"
  obtains c where "convex_lincomb_list c L x"
  using gram_schmidt.convex_hull_list_def
  using that convex_lincomb_in_convex_hull_list assms
  by blast

lemma sum_except_one:
  fixes f :: "nat \<Rightarrow> 'a"
  assumes "sum f {0..<length (a#ax)} = 1"
  assumes "f 0 \<noteq> 1"
  shows "(\<Sum>i = 0..<length ax. f (i + 1) / (1 - f 0)) = 1"
proof -
  let ?g = "(\<lambda>i. f (i + 1) / (1 - f 0))"
  have "length (a # ax) = 1 + length ax"
    by simp
  then have 0:"sum (\<lambda>i. f (i + 1)) {0..<length ax} = sum (\<lambda>i. f i) {1..<length (a # ax)}"
    by (metis Nat.add_0_right  add.commute sum.shift_bounds_nat_ivl)
  then have "(1/(1 - f 0)) * sum (\<lambda>i. f (i + 1)) {0..<length ax} =
              (1/(1 - f 0)) * sum (\<lambda>i. f i) {1..<length (a # ax)}" by simp
  have 1:"sum ?g {0..<length ax} = (1/(1 - f 0)) * sum (\<lambda>i. f (i + 1)) {0..<length ax}"
    using mult_hom.hom_sum[of "(1/(1 - f 0))" "(\<lambda>i. f (i + 1))" "{0..<length ax}"]
    by simp
  then have "f 0 + sum f {1..<length (a#ax)} = sum f {0..<length (a#ax)}"
    by (metis \<open>length (a # ax) = 1 + length ax\<close> add.commute sum_range_divided_at_zero)
  then have "f 0 + sum f {1..<length (a#ax)} = 1"
    by (metis  \<open>sum f {0..<length (a#ax)} = 1\<close>)
  then have 2:"sum (\<lambda>i. f (i + 1)) {0..<length ax} = 1 - f 0"
    using 0 by linarith
  then have "(1/(1 - f 0)) * (1 - f 0) =  1" using `f 0 \<noteq> 1`
    by (metis nonzero_eq_divide_eq r_right_minus_eq)
  then show ?thesis
    using 1 2 by presburger
qed

lemma sumlist_distr_zero:
  assumes "m > 0"
  shows "sumlist (map f [0..<m]) = f 0 + sumlist (map f [1..<m])"
  by (metis M.sumlist_Cons add_zero_to_range_list assms list.simps(9))

lemma sumlist_as_lincomb_two_elems:
  assumes "c 0 \<noteq> 1"
  assumes "set (a#ax) \<subseteq> carrier_vec n"
  shows " sumlist (map (\<lambda>i. c i \<cdot>\<^sub>v (a # ax) ! i) [0..<length (a#ax)]) =
    c 0 \<cdot>\<^sub>v a + (1 - c 0) \<cdot>\<^sub>v sumlist ( map (\<lambda>i. (c (i + 1) / (1 - c 0)) \<cdot>\<^sub>v ax ! i) [0..<length ax])"
proof -
  let ?f = "(\<lambda>i. c i \<cdot>\<^sub>v (a # ax) ! i)"
  have "?f \<in> set [1..<length (a # ax)] \<rightarrow> carrier_vec n"
    using lincomb_map_set_carrier[of "a#ax" c] assms set_upt smult_closed subsetD by fastforce
  then have " M.sumlist (map ?f [1..<length (a # ax)]) =
    (1 - c 0) \<cdot>\<^sub>v M.sumlist (map (\<lambda>i. 1 / (1 - c 0) \<cdot>\<^sub>v ?f i) [1..<length (a # ax)])"
    using sumlist_map_mult[of ?f " [1..<length (a # ax)]" "(1 - c 0)"] `c 0 \<noteq> 1`
    by linarith
  moreover have "(\<lambda>i. 1 / (1 - c 0) \<cdot>\<^sub>v ?f i) =  (\<lambda>i. (c i / (1 - c 0)) \<cdot>\<^sub>v (a # ax) ! i)"
    using `c 0 \<noteq> 1`
    by fastforce
  moreover have "sumlist ( map ?f [1..<length (a # ax)]) =
    (1 - c 0) \<cdot>\<^sub>v sumlist ( map (\<lambda>i. (c i / (1 - c 0)) \<cdot>\<^sub>v (a # ax) ! i) [1..<length (a # ax)])"
    using `c 0 \<noteq> 1`
    using calculation(1) calculation(2) by presburger
  moreover have "sumlist ( map (\<lambda>i. (c i / (1 - c 0)) \<cdot>\<^sub>v (a # ax) ! i) [1..<length (a # ax)]) =
      sumlist ( map (\<lambda>i. (c (i + 1) / (1 - c 0)) \<cdot>\<^sub>v ax ! i) [0..<length ax])"
    using map_shift_by_one[of "\<lambda>i. (c i / (1 - c 0))" a ax]
    by argo
  ultimately show ?thesis
    using  sumlist_distr_zero[of "length (a#ax)" ?f]
    by simp
qed

lemma elem_int_hull_lincomb_list:
  fixes x :: "'a :: trivial_conjugatable_linordered_field vec"
  assumes "P \<subseteq> carrier_vec n"
  assumes "P = integer_hull P"
  assumes"x \<in> P"
  assumes "x \<notin> \<int>\<^sub>v"
  obtains Wsl c where "convex_lincomb_list c Wsl x \<and> c 0 \<noteq> 0 \<and> (set Wsl) \<subseteq> P \<inter> \<int>\<^sub>v \<and> Wsl \<noteq> []"
proof -
obtain Ws c' where Ws_c':"finite Ws" "Ws \<subseteq> P \<inter> \<int>\<^sub>v" "convex_lincomb c' Ws x"
  using assms(2) unfolding integer_hull_def
        by (smt (verit, ccfv_SIG) IntD1 \<open>x \<in> P\<close> gram_schmidt.convex_hull_def mem_Collect_eq)
  have Ws_subs: "Ws \<subseteq> carrier_vec n"
    by (meson Int_subset_iff Ws_c'(2) assms(1) dual_order.trans)
  have "x \<in> convex_hull Ws"
    using Ws_c' convex_hull_def by blast
  obtain Wsl where Wsl:"set Wsl =  Ws "
    by (meson Ws_c'(1) finite_list)
  then obtain c where c: "convex_lincomb_list c Wsl x"
    using Ws_subs Ws_c' obt_convect_lincomb_list by blast
  then obtain i where i: "i < length Wsl \<and> c i \<noteq> 0"
    by (metis Ints_0 Ws_c'(2) Ws_subs Wsl assms(4) convex_lincom_int inf.boundedE)
  have Ws_swap: "Ws = set (Wsl[0:= Wsl ! i, i:=Wsl ! 0])"
    by (metis i Wsl length_pos_if_in_set nth_mem set_swap)
 have "Ws \<noteq> {}"
    using \<open>x \<in> convex_hull Ws\<close> convex_hull_empty(2) by blast
 then have "Wsl \<noteq> []"
    using \<open>Ws \<noteq> {}\<close> Wsl by fastforce
  then show ?thesis
    using convex_lincomb_list_swap[of c Wsl x i] Ws_c'
    by (metis Ws_swap Ws_subs Wsl c fun_upd_other fun_upd_same i list_update_nonempty that)
qed

lemma elem_of_P_is_lin_comb:
  fixes x :: "'a :: trivial_conjugatable_linordered_field vec"
  assumes "P \<subseteq> carrier_vec n"
  assumes "P = integer_hull P"
  assumes"x \<in> P"
  assumes "x \<notin> \<int>\<^sub>v"
  obtains y z l where "y \<in> P \<inter> \<int>\<^sub>v" "z \<in> P" "x = l \<cdot>\<^sub>v y + (1 - l) \<cdot>\<^sub>v z" "l > 0 \<and> l < 1"
proof -
  obtain Wsl c where Wc: "convex_lincomb_list c Wsl x \<and> c 0 \<noteq> 0 \<and> (set Wsl) \<subseteq> P \<inter> \<int>\<^sub>v \<and> Wsl \<noteq> []"
    using elem_int_hull_lincomb_list
    by (metis assms)
  then have lin_comb_x:
    "lincomb_list c Wsl = x \<and> (\<forall> i < length Wsl. c i \<ge> 0) \<and> sum c {0..<length Wsl} = 1"
    using convex_lincomb_list_def nonneg_lincomb_list_def Wc by blast
  have "sum c {0..<length Wsl} = 1"
    using lin_comb_x by blast
  obtain a ax where "Wsl = a # ax"
    by (meson Wc neq_Nil_conv)
  then have " \<forall>i<length Wsl. c i < 1"
    using convex_lincomb_less_1_coeff[of c Wsl x] using Wc assms(1)
    using assms(4) by blast
  then have "c 0 \<noteq> 1"
    by (metis Wc length_greater_0_conv less_numeral_extra(4))
  let ?f = "(\<lambda>i. c (i + 1) / (1 - c 0))"
  have "sum ?f {0..<length ax} = 1" using sum_except_one
    by (metis \<open>Wsl = a # ax\<close> \<open>c 0 \<noteq> 1\<close> \<open>sum c {0..<length Wsl} = 1\<close>)
  have "set ax \<subseteq> set Wsl"
    using \<open>Wsl = a # ax\<close> by auto
  then have "set ax \<subseteq> carrier_vec n" using assms(1) Wc
    by blast
  have " set ax \<subseteq> P \<inter> \<int>\<^sub>v"
    using Wc \<open>set ax \<subseteq> set Wsl\<close>   by blast
  have "(\<forall> i < length Wsl. c i \<ge> 0)"
    using lin_comb_x by presburger
  have "(1 - c 0) > 0" using nonneg_sum_range_each_le[of "length Wsl" c]
    by (meson Wc \<open>\<forall>i<length Wsl. c i < 1\<close> diff_gt_0_iff_gt gr_zeroI length_0_conv)
  then have " \<forall>i<length ax. 0 \<le> ?f i"
    by (simp add: \<open>Wsl = a # ax\<close> \<open>\<forall>i<length Wsl. 0 \<le> c i\<close>)
  have 1:"sumlist (map (\<lambda>i. ?f i \<cdot>\<^sub>v ax ! i) [0..<length ax]) \<in> P"
    using lincomb_in_integer_set[of ax P ?f] `sum ?f {0..<length ax} = 1`
    using \<open>\<forall>i<length ax. 0 \<le> ?f i\<close> \<open>set ax \<subseteq> P \<inter> \<int>\<^sub>v\<close> \<open>set ax \<subseteq> carrier_vec n\<close> assms(2)
    unfolding lincomb_list_def
    by blast
  have 2:"x = c 0 \<cdot>\<^sub>v a + (1 - c 0) \<cdot>\<^sub>v sumlist ( map (\<lambda>i. ?f i \<cdot>\<^sub>v ax ! i) [0..<length ax])"
    using sumlist_as_lincomb_two_elems[of c a ax]  \<open>Wsl = a # ax\<close> \<open>c 0 \<noteq> 1\<close>
      lin_comb_x assms(1) Wc by (auto simp: lincomb_list_def)
  have 3:"a \<in> P \<inter> \<int>\<^sub>v"
    using \<open>Wsl = a # ax\<close> Wc  by force
  have 4:"c 0 > 0"
    by (metis Wc \<open>\<forall>i<length Wsl. 0 \<le> c i\<close> length_greater_0_conv order_le_imp_less_or_eq)
  have 5:"c 0 \<le> 1" using member_le_sum[of 0 "{0..<length Wsl}" c]
    using \<open>Wsl = a # ax\<close> lin_comb_x by force
  then show ?thesis using 1 2 3 4 5
    using that
    using \<open>c 0 \<noteq> 1\<close> by force
qed

lemma lincomb_then_lincomb_list:
  assumes "set L \<subseteq> carrier_vec n"
  assumes "x = lincomb c' (set L)"
  obtains c where "x = lincomb_list c L"
  using assms(1) assms(2) lincomb_as_lincomb_list by blast

end
end