(*
Author:  Florian Messner <florian.g.messner@uibk.ac.at>
Author:  Julian Parsert <julian.parsert@gmail.com>
Author:  Jonas Schöpf <jonas.schoepf@uibk.ac.at>
Author:  Christian Sternagel <c.sternagel@gmail.com>
License: LGPL
*)

section \<open>Homogeneous Linear Diophantine Equations\<close>

theory Linear_Diophantine_Equations
  imports List_Vector
begin

(*TODO: move*)
lemma lcm_div_le:
  fixes a :: nat
  shows "lcm a b div b \<le> a"
  by (metis div_by_0 div_le_dividend div_le_mono div_mult_self_is_m lcm_nat_def neq0_conv)

(*TODO: move*)
lemma lcm_div_le':
  fixes a :: nat
  shows "lcm a b div a \<le> b"
  by (metis lcm.commute lcm_div_le)

(*TODO: move*)
lemma lcm_div_gt_0:
  fixes a :: nat
  assumes "a > 0" and "b > 0"
  shows "lcm a b div a > 0"
proof -
  have "lcm a b = (a * b) div (gcd a b)"
    using lcm_nat_def by blast
  moreover have "\<dots> > 0"
    using  assms
    by (metis assms calculation lcm_pos_nat)
  ultimately show ?thesis
    using assms
    by (metis div_by_0 div_mult2_eq div_positive gcd_le2_nat nat_mult_div_cancel_disj neq0_conv
              semiring_normalization_rules(7))
qed

(*TODO: move*)
lemma sum_list_list_update_Suc:
  assumes "i < length u"
  shows "sum_list (u[i := Suc (u ! i)]) = Suc (sum_list u)"
  using assms
proof (induct u arbitrary: i)
  case (Cons x xs)
  then show ?case by (simp_all split: nat.splits)
qed (simp)

(*TODO: move*)
lemma lessThan_conv:
  assumes "card A = n" and "\<forall>x\<in>A. x < n"
  shows "A = {..<n}"
  using assms by (simp add: card_subset_eq subsetI)

text \<open>
  Given a non-empty list \<open>xs\<close> of \<open>n\<close> natural numbers,
  either there is a value in \<open>xs\<close> that is \<open>0\<close> modulo \<open>n\<close>,
  or there are two values whose moduli coincide.
\<close>
lemma list_mod_cases:
  assumes "length xs = n" and "n > 0"
  shows "(\<exists>x\<in>set xs. x mod n = 0) \<or>
    (\<exists>i<length xs. \<exists>j<length xs. i \<noteq> j \<and> (xs ! i) mod n = (xs ! j) mod n)"
proof -
  let ?f = "\<lambda>x. x mod n" and ?X = "set xs"
  have *: "\<forall>x \<in> ?f ` ?X. x < n" using \<open>n > 0\<close> by auto
  consider (eq) "card (?f ` ?X) = card ?X" | (less) "card (?f ` ?X) < card ?X"
    using antisym_conv2 and card_image_le by blast
  then show ?thesis
  proof (cases)
    case eq
    show ?thesis
    proof (cases "distinct xs")
      assume "distinct xs"
      with eq have "card (?f ` ?X) = n"
        using \<open>distinct xs\<close> by (simp add: assms card_distinct distinct_card)
      from lessThan_conv [OF this *] and \<open>n > 0\<close>
      have "\<exists>x\<in>set xs. x mod n = 0" by (metis imageE lessThan_iff)
      then show ?thesis ..
    next
      assume "\<not> distinct xs"
      then show ?thesis by (auto) (metis distinct_conv_nth)
    qed
  next
    case less
    from pigeonhole [OF this]
    show ?thesis by (auto simp: inj_on_def iff: in_set_conv_nth)
  qed
qed

text \<open>
  Homogeneous linear Diophantine equations:
  \<open>a\<^sub>1x\<^sub>1 + \<cdots> + a\<^sub>mx\<^sub>m = b\<^sub>1y\<^sub>1 + \<cdots> + b\<^sub>ny\<^sub>n\<close>
\<close>
locale hlde_ops =
  fixes a b :: "nat list"
begin

abbreviation "m \<equiv> length a"
abbreviation "n \<equiv> length b"

\<comment> \<open>The set of all solutions.\<close>
definition Solutions :: "(nat list \<times> nat list) set"
  where
    "Solutions = {(x, y). a \<bullet> x = b \<bullet> y \<and> length x = m \<and> length y = n}"

lemma in_Solutions_iff:
  "(x, y) \<in> Solutions \<longleftrightarrow> length x = m \<and> length y = n \<and> a \<bullet> x = b \<bullet> y"
  by (auto simp: Solutions_def)

\<comment> \<open>The set of pointwise minimal solutions.\<close>
definition Minimal_Solutions :: "(nat list \<times> nat list) set"
  where
    "Minimal_Solutions = {(x, y) \<in> Solutions. nonzero x \<and>
      \<not> (\<exists>(u, v) \<in> Solutions. nonzero u \<and> u @ v <\<^sub>v x @ y)}"

definition dij :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where
    "dij i j = lcm (a ! i) (b ! j) div (a ! i)"

definition eij :: "nat \<Rightarrow> nat \<Rightarrow> nat"
  where
    "eij i j = lcm (a ! i) (b ! j) div (b ! j)"

definition sij :: "nat \<Rightarrow> nat \<Rightarrow> (nat list \<times> nat list)"
  where
    "sij i j = ((zeroes m)[i := dij i j], (zeroes n)[j := eij i j])"

subsection \<open>Further Constraints on Minimal Solutions\<close>

definition Ej :: "nat \<Rightarrow> nat list \<Rightarrow> nat set"
  where
    "Ej j x = { eij i j - 1 | i. i < length x \<and> x ! i \<ge> dij i j }"

definition Di :: "nat \<Rightarrow> nat list \<Rightarrow> nat set"
  where
    "Di i y = { dij i j - 1 | j. j < length y \<and> y ! j \<ge> eij i j }"

definition Di' :: "nat \<Rightarrow> nat list \<Rightarrow> nat set"
  where
    "Di' i y = { dij i (j + length b - length y) - 1 | j. j < length y \<and> y ! j \<ge> eij i (j + length b - length y) }"

lemma Ej_take_subset:
  "Ej j (take k x) \<subseteq> Ej j x"
  by (auto simp: Ej_def)

lemma Di_take_subset:
  "Di i (take l y) \<subseteq> Di i y"
  by (auto simp: Di_def)

lemma Di'_drop_subset:
  "Di' i (drop l y) \<subseteq> Di' i y"
  by (auto simp: Di'_def) (metis add.assoc add.commute less_diff_conv)

lemma finite_Ej:
  "finite (Ej j x)"
  by (rule finite_subset [of _ "(\<lambda>i. eij i j - 1) ` {0 ..< length x}"]) (auto simp: Ej_def)

lemma finite_Di:
  "finite (Di i y)"
  by (rule finite_subset [of _ "(\<lambda>j. dij i j - 1) ` {0 ..< length y}"]) (auto simp: Di_def)

lemma finite_Di':
  "finite (Di' i y)"
  by (rule finite_subset [of _ "(\<lambda>j. dij i (j + length b - length y) - 1) ` {0 ..< length y}"])
    (auto simp: Di'_def)

definition max_y :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
  where
    "max_y x j = (if j < n \<and> Ej j x \<noteq> {} then Min (Ej j x) else Max (set a))"

definition max_x :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
  where
    "max_x y i = (if i < m \<and> Di i y \<noteq> {} then Min (Di i y) else Max (set b))"

definition max_x' :: "nat list \<Rightarrow> nat \<Rightarrow> nat"
  where
    "max_x' y i = (if i < m \<and> Di' i y \<noteq> {} then Min (Di' i y) else Max (set b))"

lemma Min_Ej_le:
  assumes "j < n"
    and "e \<in> Ej j x"
    and "length x \<le> m"
  shows "Min (Ej j x) \<le> Max (set a)" (is "?m \<le> _")
proof -
  have "?m \<in> Ej j x"
    using assms and finite_Ej and Min_in by blast
  then obtain i where
    i: "?m = eij i j - 1" "i < length x" "x ! i \<ge> dij i j"
    by (auto simp: Ej_def)
  have "lcm (a ! i) (b ! j) div b ! j \<le> a ! i" by (rule lcm_div_le)
  then show ?thesis
    using i and assms
    by (auto simp: eij_def)
      (meson List.finite_set Max_ge diff_le_self le_trans less_le_trans nth_mem)
qed

lemma Min_Di_le:
  assumes "i < m"
    and "e \<in> Di i y"
    and "length y \<le> n"
  shows "Min (Di i y) \<le> Max (set b)" (is "?m \<le> _")
proof -
  have "?m \<in> Di i y"
    using assms and finite_Di and Min_in by blast
  then obtain j where
    j: "?m = dij i j - 1" "j < length y" "y ! j \<ge> eij i j"
    by (auto simp: Di_def)
  have "lcm (a ! i) (b ! j) div a ! i \<le> b ! j" by (rule lcm_div_le')
  then show ?thesis
    using j and assms
    by (auto simp: dij_def)
      (meson List.finite_set Max_ge diff_le_self le_trans less_le_trans nth_mem)
qed

lemma Min_Di'_le:
  assumes "i < m"
    and "e \<in> Di' i y"
    and "length y \<le> n"
  shows "Min (Di' i y) \<le> Max (set b)" (is "?m \<le> _")
proof -
  have "?m \<in> Di' i y"
    using assms and finite_Di' and Min_in by blast
  then obtain j where
    j: "?m = dij i (j + length b - length y) - 1" "j < length y" "y ! j \<ge> eij i (j + length b - length y)"
    by (auto simp: Di'_def)
  then have "j + length b - length y < length b" using assms by auto
  moreover
  have "lcm (a ! i) (b ! (j + length b - length y)) div a ! i \<le> b ! (j + length b - length y)" by (rule lcm_div_le')
  ultimately show ?thesis
    using j and assms
    by (auto simp: dij_def)
      (meson List.finite_set Max_ge diff_le_self le_trans less_le_trans nth_mem)
qed

lemma max_y_le_take:
  assumes "length x \<le> m"
  shows "max_y x j \<le> max_y (take k x) j"
  using assms and Min_Ej_le and Ej_take_subset and Min.subset_imp [OF _ _ finite_Ej]
  by (auto simp: max_y_def) blast

lemma max_x_le_take:
  assumes "length y \<le> n"
  shows "max_x y i \<le> max_x (take l y) i"
  using assms and Min_Di_le and Di_take_subset and Min.subset_imp [OF _ _ finite_Di]
  by (auto simp: max_x_def) blast

lemma max_x'_le_drop:
  assumes "length y \<le> n"
  shows "max_x' y i \<le> max_x' (drop l y) i"
  using assms and Min_Di'_le and Di'_drop_subset and Min.subset_imp [OF _ _ finite_Di']
  by (auto simp: max_x'_def) blast

end

abbreviation "Solutions \<equiv> hlde_ops.Solutions"
abbreviation "Minimal_Solutions \<equiv> hlde_ops.Minimal_Solutions"

abbreviation "dij \<equiv> hlde_ops.dij"
abbreviation "eij \<equiv> hlde_ops.eij"
abbreviation "sij \<equiv> hlde_ops.sij"

declare hlde_ops.dij_def [code]
declare hlde_ops.eij_def [code]
declare hlde_ops.sij_def [code]

lemma Solutions_sym: "(x, y) \<in> Solutions a b \<longleftrightarrow> (y, x) \<in> Solutions b a"
  by (auto simp: hlde_ops.in_Solutions_iff)

lemma Minimal_Solutions_imp_Solutions: "(x, y) \<in> Minimal_Solutions a b \<Longrightarrow> (x, y) \<in> Solutions a b"
  by (auto simp: hlde_ops.Minimal_Solutions_def)

lemma Minimal_SolutionsI:
  assumes "(x, y) \<in> Solutions a b"
    and "nonzero x"
    and "\<not> (\<exists>(u, v) \<in> Solutions a b. nonzero u \<and> u @ v <\<^sub>v x @ y)"
  shows "(x, y) \<in> Minimal_Solutions a b"
  using assms by (auto simp: hlde_ops.Minimal_Solutions_def)

lemma minimize_nonzero_solution:
  assumes "(x, y) \<in> Solutions a b" and "nonzero x"
  obtains u and v where "u @ v \<le>\<^sub>v x @ y" and "(u, v) \<in> Minimal_Solutions a b"
  using assms
proof (induct "x @ y" arbitrary: x y thesis rule: wf_induct [OF wf_less])
  case 1
  then show ?case
  proof (cases "(x, y) \<in> Minimal_Solutions a b")
    case False
    then obtain u and v where "nonzero u" and "(u, v) \<in> Solutions a b" and uv: "u @ v <\<^sub>v x @ y"
      using 1(3,4) by (auto simp: hlde_ops.Minimal_Solutions_def)
    with 1(1) [rule_format, of "u @ v" u v] obtain u' and v' where uv': "u' @ v' \<le>\<^sub>v u @ v"
      and "(u', v') \<in> Minimal_Solutions a b" by blast
    moreover have "u' @ v' \<le>\<^sub>v x @ y" using uv and uv' by auto
    ultimately show ?thesis by (intro 1(2))
  qed blast
qed

lemma Minimal_SolutionsI':
  assumes "(x, y) \<in> Solutions a b"
    and "nonzero x"
    and "\<not> (\<exists>(u, v) \<in> Minimal_Solutions a b. u @ v <\<^sub>v x @ y)"
  shows "(x, y) \<in> Minimal_Solutions a b"
proof (rule Minimal_SolutionsI [OF assms(1,2)])
  show "\<not> (\<exists>(u, v) \<in> Solutions a b. nonzero u \<and> u @ v <\<^sub>v x @ y)"
  proof
    assume "\<exists>(u, v) \<in> Solutions a b. nonzero u \<and> u @ v <\<^sub>v x @ y"
    then obtain u and v where "(u, v) \<in> Solutions a b" and "nonzero u"
      and uv: "u @ v <\<^sub>v x @ y" by blast
    then obtain u' and v' where "(u', v') \<in> Minimal_Solutions a b"
      and uv': "u' @ v' \<le>\<^sub>v u @ v" by (blast elim: minimize_nonzero_solution)
    moreover have "u' @ v' <\<^sub>v x @ y" using uv and uv' by auto
    ultimately show False using assms by blast
  qed
qed

lemma Minimal_Solutions_length:
  "(x, y) \<in> Minimal_Solutions a b \<Longrightarrow> length x = length a \<and> length y = length b"
  by (auto simp: hlde_ops.Minimal_Solutions_def hlde_ops.in_Solutions_iff)

lemma Minimal_Solutions_gt0:
  "(x, y) \<in> Minimal_Solutions a b \<Longrightarrow> zeroes (length x) <\<^sub>v x"
  using zero_less by (auto simp: hlde_ops.Minimal_Solutions_def)

lemma Minimal_Solutions_sym:
  assumes "0 \<notin> set a" and "0 \<notin> set b"
  shows "(xs, ys) \<in> Minimal_Solutions a b \<longrightarrow> (ys, xs) \<in> Minimal_Solutions b a"
  using assms
  by (auto simp: hlde_ops.Minimal_Solutions_def hlde_ops.Solutions_def
           dest: dotprod_eq_nonzero_iff dest!: less_append_swap [of _ _ ys xs])

locale hlde = hlde_ops +
  assumes no0: "0 \<notin> set a" "0 \<notin> set b"
begin

lemma nonzero_Solutions_iff:
  assumes "(x, y) \<in> Solutions"
  shows "nonzero x \<longleftrightarrow> nonzero y"
  using assms and no0 by (auto simp: in_Solutions_iff dest: dotprod_eq_nonzero_iff)

lemma Minimal_Solutions_min:
  assumes "(x, y) \<in> Minimal_Solutions"
    and "u @ v <\<^sub>v x @ y"
    and "a \<bullet> u = b \<bullet> v"
    and [simp]: "length u = m"
    and non0: "nonzero (u @ v)"
  shows False
proof -
  have [simp]: "length v = n" using assms by (force dest: less_appendD Minimal_Solutions_length)
  have "(u, v) \<in> Solutions" using \<open>a \<bullet> u = b \<bullet> v\<close> by (simp add: in_Solutions_iff)
  moreover from nonzero_Solutions_iff [OF this] have "nonzero u" using non0 by auto
  ultimately show False using assms by (auto simp: hlde_ops.Minimal_Solutions_def)
qed

lemma Solutions_snd_not_0:
  assumes "(x, y) \<in> Solutions"
    and "nonzero x"
  shows "nonzero y"
  using assms by (metis nonzero_Solutions_iff)

end

subsection \<open>Pointwise Restricting Solutions\<close>

text \<open>
  Constructing the list of \<open>u\<close> vectors from Huet's proof @{cite "Huet1978"}, satisfying
  \<^item> \<open>\<forall>i<length u. u ! i \<le> y ! i\<close> and
  \<^item> \<open>0 < sum_list u \<le> a\<^sub>k\<close>.
\<close>

text \<open>
  Given \<open>y\<close>, increment a "previous" \<open>u\<close> vector at first position
  starting from \<open>i\<close> where \<open>u\<close> is strictly smaller than \<open>y\<close>. If this
  is not possible, return \<open>u\<close> unchanged.
\<close>
function inc :: "nat list \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> nat list"
  where
    "inc y i u =
      (if i < length y then
        if u ! i < y ! i then u[i := u ! i + 1]
        else inc y (Suc i) u
      else u)"
  by (pat_completeness) auto
termination inc
  by (relation "measure (\<lambda>(y, i, u). max (length y) (length u) - i)") auto
(*inc.simps may cause simplification to loop*)
declare inc.simps [simp del]

text \<open>
  Starting from the 0-vector produce \<open>u\<close>s by iteratively
  incrementing with respect to \<open>y\<close>.
\<close>
definition huets_us :: "nat list \<Rightarrow> nat \<Rightarrow> nat list" ("\<^bold>u" 1000)
  where
    "\<^bold>u y i = ((inc y 0) ^^ Suc i) (zeroes (length y))"

lemma huets_us_simps [simp]:
  "\<^bold>u y 0 = inc y 0 (zeroes (length y))"
  "\<^bold>u y (Suc i) = inc y 0 (\<^bold>u y i)"
  by (auto simp: huets_us_def)

lemma length_inc [simp]: "length (inc y i u) = length u"
  by (induct y i u rule: inc.induct) (simp add: inc.simps)

lemma length_us [simp]:
  "length (\<^bold>u y i) = length y"
  by (induct i) (simp_all)

text \<open>
  \<open>inc\<close> produces vectors that are pointwise smaller than \<open>y\<close>
\<close>

lemma us_le:
  assumes "length y > 0"
  shows "\<^bold>u y i \<le>\<^sub>v y"
  using assms by (induct i) (auto simp: inc_le le_length)

lemma sum_list_inc_le:
  "u \<le>\<^sub>v y \<Longrightarrow> sum_list (inc y i u) \<le> sum_list y"
  by (induct y i u rule: inc.induct)
    (auto simp: inc.simps intro: le_sum_list_mono)

lemma sum_list_inc_gt0:
  assumes "sum_list u > 0" and "length y = length u"
  shows "sum_list (inc y i u) > 0"
  using assms
proof (induct y i u rule: inc.induct)
  case (1 y i u)
  then show ?case
    by (auto simp add: inc.simps)
      (meson Suc_neq_Zero gr_zeroI set_update_memI sum_list_eq_0_iff)
qed

lemma sum_list_inc_gt0':
  assumes "length u = length y" and "i < length y" and "y ! i > 0" and "j \<le> i"
  shows "sum_list (inc y j u) > 0"
  using assms
proof (induct y j u rule: inc.induct)
  case (1 y i u)
  then show ?case
    by (auto simp: inc.simps [of y i] sum_list_update)
      (metis elem_le_sum_list le_antisym le_zero_eq neq0_conv not_less_eq_eq sum_list_inc_gt0)
qed

lemma sum_list_us_gt0:
  assumes "sum_list y \<noteq> 0"
  shows "0 < sum_list (\<^bold>u y i)"
  using assms by (induct i) (auto simp: in_set_conv_nth sum_list_inc_gt0' sum_list_inc_gt0)

lemma sum_list_inc_le':
  assumes "length u = length y"
  shows "sum_list (inc y i u) \<le> sum_list u + 1"
  using assms
  by (induct y i u rule: inc.induct) (auto simp: inc.simps sum_list_update)

lemma sum_list_us_bounded:
  assumes "i < k"
  shows "sum_list (\<^bold>u y i) \<le> k"
  using assms and sum_list_us_le [of y i] by force

lemma sum_list_inc_eq_sum_list_Suc:
  assumes "length u = length y" and "i < length y"
    and "\<exists>j\<ge>i. j < length y \<and> u ! j < y ! j"
  shows "sum_list (inc y i u) = Suc (sum_list u)"
  using assms
  by (induct y i u rule: inc.induct)
    (metis  inc.simps Suc_eq_plus1 Suc_leI antisym_conv2 leD sum_list_list_update_Suc)

lemma sum_list_us_eq:
  assumes "i < sum_list y"
  shows "sum_list (\<^bold>u y i) = i + 1"
  using assms
proof (induct i)
  case (Suc i)
  then show ?case
    by (auto)
      (metis (no_types, lifting) Suc_eq_plus1 gr_implies_not0 length_pos_if_in_set
       length_us less_Suc_eq_le less_imp_le_nat antisym_conv2 not_less_eq_eq
       sum_list_eq_0_iff sum_list_inc_eq_sum_list_Suc sum_list_less_diff_Ex us_le)
qed (metis Suc_eq_plus1 Suc_leI antisym_conv gr_implies_not0 sum_list_us_gt0 sum_list_us_le)

lemma inc_ge: "length u = length y \<Longrightarrow> u \<le>\<^sub>v inc y i u"
  by (induct y i u rule: inc.induct) (auto simp: inc.simps nth_list_update less_eq_def)

lemma us_le_mono:
  assumes "i < j"
  shows "\<^bold>u y i \<le>\<^sub>v \<^bold>u y j"
  using assms
proof (induct "j - i" arbitrary: j i)
  case (Suc n)
  then show ?case
    by (simp add: Suc.prems inc_ge order.strict_implies_order order_vec.lift_Suc_mono_le)
qed simp

lemma us_mono:
  assumes "i < j" and "j < sum_list y"
  shows "\<^bold>u y i <\<^sub>v \<^bold>u y j"
proof -
  let ?u = "\<^bold>u y i" and ?v = "\<^bold>u y j"
  have "?u \<le>\<^sub>v ?v"
    using us_le_mono [OF \<open>i < j\<close>] by simp
  moreover have "sum_list ?u < sum_list ?v"
    using assms by (auto simp: sum_list_us_eq)
  ultimately show ?thesis by (intro le_sum_list_less) (auto simp: less_eq_def)
qed

context hlde
begin

lemma max_coeff_bound_right:
  assumes "(xs, ys) \<in> Minimal_Solutions"
  shows "\<forall>x \<in> set xs. x \<le> maxne0 ys b" (is "\<forall>x\<in>set xs. x \<le> ?m")
proof (rule ccontr)
  assume "\<not> ?thesis"
  then obtain k
    where k_def: "k < length xs \<and> \<not> (xs ! k \<le> ?m)"
    by (metis in_set_conv_nth)
  have sol: "(xs, ys) \<in> Solutions"
    using assms Minimal_Solutions_def by auto
  then have len: "m = length xs" by (simp add: in_Solutions_iff)
  have max_suml: "?m * sum_list ys \<ge> b \<bullet> ys"
    using maxne0_times_sum_list_gt_dotprod sol by (auto simp: in_Solutions_iff)
  then have is_sol: "b \<bullet> ys = a \<bullet> xs"
    using sol by (auto simp: in_Solutions_iff)
  then have a_ge_ak: "a \<bullet> xs \<ge> a ! k * xs ! k"
    using dotprod_pointwise_le k_def len by auto
  then have ak_gt_max: "a ! k * xs ! k > a ! k * ?m"
    using no0 in_set_conv_nth k_def len by fastforce
  then have sl_ys_g_ak: "sum_list ys > a ! k"
    by (metis a_ge_ak is_sol less_le_trans max_suml
        mult.commute mult_le_mono1 not_le)
  define Seq where
    Seq_def: "Seq = map (\<^bold>u ys) [0 ..< a ! k]"
  have ak_n0: "a ! k \<noteq> 0"
    using \<open>a ! k * ?m < a ! k * xs ! k\<close> by auto
  have "zeroes (length ys) <\<^sub>v ys"
    by (intro zero_less) (metis gr_implies_not0 nonzero_iff sl_ys_g_ak sum_list_eq_0_iff)
  then have "length Seq > 0"
    using ak_n0 Seq_def by auto
  have u_in_nton: "\<forall>u \<in> set Seq. length u = length ys"
    by (simp add: Seq_def)
  have prop_3: "\<forall>u \<in> set Seq. u \<le>\<^sub>v ys"
  proof -
    have "length ys > 0"
      using sl_ys_g_ak by auto
    then show ?thesis
      using us_le [of ys ] less_eq_def Seq_def by (simp)
  qed
  have prop_4_1: "\<forall>u \<in> set Seq. sum_list u > 0"
    by (metis Seq_def sl_ys_g_ak gr_implies_not_zero imageE
        set_map sum_list_us_gt0)
  have prop_4_2: "\<forall>u \<in> set Seq. sum_list u \<le> a ! k"
    by (simp add: Seq_def sum_list_us_bounded)
  have prop_5: "\<exists>u. length u = length ys \<and> u \<le>\<^sub>v ys \<and> sum_list u > 0 \<and> sum_list u \<le> a ! k"
    using \<open>0 < length Seq\<close> nth_mem prop_3 prop_4_1 prop_4_2 u_in_nton by blast
  define Us where
    "Us = {u. length u = length ys \<and> u \<le>\<^sub>v ys \<and> sum_list u > 0 \<and> sum_list u \<le> a ! k}"
  have "\<exists>u \<in> Us. b \<bullet> u mod a ! k = 0"
  proof (rule ccontr)
    assume neg_th: "\<not> ?thesis"
    define Seq_p where
      "Seq_p = map (dotprod b) Seq"
    have "length Seq = a ! k"
      by (simp add: Seq_def)
    then consider (eq_0)  "(\<exists>x\<in>set Seq_p. x mod (a ! k) = 0)" |
      (not_0) "(\<exists>i<length Seq_p. \<exists>j<length Seq_p. i \<noteq> j \<and>
               (Seq_p ! i) mod (a!k) = (Seq_p ! j) mod (a!k))"
      using list_mod_cases[of Seq_p] Seq_p_def ak_n0 by auto
    then show False
    proof (cases)
      case eq_0
      have "\<exists>u \<in> set Seq. b \<bullet> u mod a ! k = 0"
        using Seq_p_def eq_0 by auto
      then show False
        by (metis (mono_tags, lifting) Us_def mem_Collect_eq
            neg_th prop_3 prop_4_1 prop_4_2 u_in_nton)
    next
      case not_0
      obtain i and j where
        i_j: "i<length Seq_p" "j<length Seq_p" " i \<noteq> j"
        " Seq_p ! i mod a ! k = Seq_p ! j mod a ! k"
        using not_0 by blast
      define v where
        v_def: "v = Seq!i"
      define w where
        w_def: "w = Seq!j"
      have mod_eq: "b \<bullet> v mod a!k = b \<bullet> w mod a!k"
        using Seq_p_def i_j w_def v_def i_j  by auto
      have "v <\<^sub>v w \<or> w <\<^sub>v v"
        using \<open>i \<noteq> j\<close> and i_j
      proof (cases "i < j")
        case True
        then show ?thesis
          using Seq_p_def sl_ys_g_ak i_j(2) local.Seq_def us_mono v_def w_def by auto
      next
        case False
        then show ?thesis
          using Seq_p_def sl_ys_g_ak \<open>i \<noteq> j\<close> i_j(1) local.Seq_def us_mono v_def w_def by auto
      qed
      then show False
      proof
        assume ass: "v <\<^sub>v w"
        define u where
          u_def: "u = w -\<^sub>v v"
        have "w \<le>\<^sub>v ys"
          using Seq_p_def w_def i_j(2) prop_3 by force
        then have prop_3: "less_eq u ys"
          using vdiff_le ass less_eq_def order_vec.less_imp_le u_def by auto
        have prop_4_1: "sum_list u > 0"
          using le_sum_list_mono [of v w] ass u_def sum_list_vdiff_distr [of v w]
          by (simp add: less_vec_sum_list_less)
        have prop_4_2: "sum_list u \<le> a ! k"
        proof -
          have "u \<le>\<^sub>v w" using u_def
            using ass less_eq_def order_vec.less_imp_le vdiff_le by auto
          then show ?thesis
            by (metis Seq_p_def i_j(2) length_map le_sum_list_mono
                less_le_trans not_le nth_mem prop_4_2 w_def)
        qed
        have "b \<bullet> u mod a ! k = 0"
          by (metis (mono_tags, lifting) in_Solutions_iff \<open>w \<le>\<^sub>v ys\<close> u_def ass no0(2)
              less_eq_def mem_Collect_eq mod_eq mods_with_vec_2 prod.simps(2) sol)
        then show False using neg_th
          by (metis (mono_tags, lifting) Us_def less_eq_def mem_Collect_eq
              prop_3 prop_4_1 prop_4_2)
      next
        assume ass: "w <\<^sub>v v"
        define u where
          u_def: "u = v -\<^sub>v w"
        have "v \<le>\<^sub>v ys"
          using Seq_p_def v_def i_j(1) prop_3 by force
        then have prop_3: "u \<le>\<^sub>v ys"
          using vdiff_le ass less_eq_def order_vec.less_imp_le u_def by auto
        have prop_4_1: "sum_list u > 0"
          using le_sum_list_mono [of w v] sum_list_vdiff_distr [of w v]
            \<open>u \<equiv> v -\<^sub>v w\<close> ass less_vec_sum_list_less by auto
        have prop_4_2: "sum_list u \<le> a!k"
        proof -
          have "u \<le>\<^sub>v v" using u_def
            using ass less_eq_def order_vec.less_imp_le vdiff_le by auto
          then show ?thesis
            by (metis Seq_p_def i_j(1) le_neq_implies_less length_map less_imp_le_nat
                less_le_trans nth_mem prop_4_2 le_sum_list_mono v_def)
        qed
        have "b \<bullet> u mod a ! k = 0"
          by (metis (mono_tags, lifting) in_Solutions_iff \<open>v \<le>\<^sub>v ys\<close> u_def ass no0(2)
              less_eq_def mem_Collect_eq mod_eq mods_with_vec_2 prod.simps(2) sol)
        then show False
          by (metis (mono_tags, lifting) neg_th Us_def less_eq_def mem_Collect_eq prop_3 prop_4_1 prop_4_2)
      qed
    qed
  qed
  then obtain u where
    u3_4: "u \<le>\<^sub>v ys" "sum_list u > 0" "sum_list u \<le> a ! k" " b \<bullet> u mod (a ! k) = 0"
    "length u = length ys"
    unfolding Us_def by auto
  have u_b_len: "length u = n"
    using  less_eq_def u3_4 in_Solutions_iff sol by simp
  have "b \<bullet> u \<le> maxne0 u b * sum_list u"
    by (simp add: maxne0_times_sum_list_gt_dotprod u_b_len)
  also have "... \<le> ?m * a ! k"
    by (intro mult_le_mono) (simp_all add: u3_4 maxne0_mono)
  also have "... < a ! k * xs ! k"
    using ak_gt_max by auto
  then obtain zk where
    zk: "b \<bullet> u = zk * a ! k"
    using u3_4(4) by auto
  have "length xs > k"
    by (simp add: k_def)
  have "zk \<noteq> 0"
  proof -
    have "\<exists>e \<in> set u. e \<noteq> 0"
      using u3_4
      by (metis neq0_conv sum_list_eq_0_iff)
    then have "b \<bullet> u > 0"
      using assms no0 u3_4
      unfolding dotprod_gt0_iff[OF u_b_len [symmetric]]
      by (fastforce simp add: in_set_conv_nth u_b_len)
    then have "a ! k > 0"
      using \<open>a ! k \<noteq> 0\<close> by blast
    then show ?thesis
      using \<open>0 < b \<bullet> u\<close> zk by auto
  qed
  define z where
    z_def: "z = (zeroes (length xs))[k := zk]"
  then have zk_zk: "z ! k = zk"
    by (auto simp add: \<open>k < length xs\<close>)
  have "length z = length xs"
    using assms z_def \<open>k < length xs\<close> by auto
  then have bu_eq_akzk: "b \<bullet> u = a ! k * z ! k"
    by (simp add: \<open>b \<bullet> u = zk * a ! k\<close> zk_zk)
  then have "z!k < xs!k"
    using ak_gt_max  calculation by auto
  then have z_less_xs: "z <\<^sub>v xs"
    by (auto simp add: z_def) (metis \<open>k < length xs\<close> le0 le_list_update less_def
        less_imp_le order_vec.dual_order.antisym nat_neq_iff z_def zk_zk)
  then have "z @ u <\<^sub>v xs @ ys"
    by (intro less_append) (auto simp add: u3_4(1) z_less_xs)
  moreover have "(z, u) \<in> Solutions"
    by (auto simp add: bu_eq_akzk in_Solutions_iff z_def u_b_len \<open>k < length xs\<close> len)
  moreover have "nonzero z"
    using \<open>length z = length xs\<close> and \<open>zk \<noteq> 0\<close> and k_def and zk_zk by (auto simp: nonzero_iff)
  ultimately show False using assms by (auto simp: Minimal_Solutions_def)
qed

text \<open>Proof of Lemma 1 of Huet's paper.\<close>
lemma max_coeff_bound:
  assumes "(xs, ys) \<in> Minimal_Solutions"
  shows "(\<forall>x \<in> set xs. x \<le> maxne0 ys b) \<and> (\<forall>y \<in> set ys. y \<le> maxne0 xs a)"
proof -
  interpret ba: hlde b a by (standard) (auto simp: no0)
  show ?thesis
    using assms and Minimal_Solutions_sym [OF no0, of xs ys]
    by (auto simp: max_coeff_bound_right ba.max_coeff_bound_right)
qed

lemma max_coeff_bound':
  assumes "(x, y) \<in> Minimal_Solutions"
  shows "\<forall>i<length x. x ! i \<le> Max (set b)" and "\<forall>j<length y. y ! j \<le> Max (set a)"
  using max_coeff_bound [OF assms] and maxne0_le_Max
  by auto (metis le_eq_less_or_eq less_le_trans nth_mem)+

lemma Minimal_Solutions_alt_def:
  "Minimal_Solutions = {(x, y)\<in>Solutions.
    (x, y) \<noteq> (zeroes m, zeroes n) \<and>
    x \<le>\<^sub>v replicate m (Max (set b)) \<and>
    y \<le>\<^sub>v replicate n (Max (set a)) \<and>
    \<not> (\<exists>(u, v)\<in>Solutions. nonzero u \<and> u @ v <\<^sub>v x @ y)}"
  by (auto simp: not_nonzero_iff Minimal_Solutions_imp_Solutions less_eq_def Minimal_Solutions_length max_coeff_bound'
    intro!: Minimal_SolutionsI' dest: Minimal_Solutions_gt0)
    (auto simp: Minimal_Solutions_def nonzero_Solutions_iff not_nonzero_iff)

subsection \<open>Special Solutions\<close>

definition Special_Solutions :: "(nat list \<times> nat list) set"
  where
    "Special_Solutions = {sij i j | i j. i < m \<and> j < n}"

lemma dij_neq_0:
  assumes "i < m"
    and "j < n"
  shows "dij i j \<noteq> 0"
proof -
  have "a ! i > 0" and "b ! j > 0"
    using assms and no0 by (simp_all add: in_set_conv_nth)
  then have "dij i j > 0"
    using lcm_div_gt_0 [of "a ! i" "b ! j"] by (simp add: dij_def)
  then show ?thesis by simp
qed

lemma eij_neq_0:
  assumes "i < m"
    and "j < n"
  shows "eij i j \<noteq> 0"
proof -
  have "a ! i > 0" and "b ! j > 0"
    using assms and no0  by (simp_all add: in_set_conv_nth)
  then have "eij i j > 0"
    using lcm_div_gt_0[of "b ! j"  "a ! i"] by (simp add: eij_def lcm.commute)
  then show ?thesis
    by simp
qed

lemma Special_Solutions_in_Solutions:
  "x \<in> Special_Solutions \<Longrightarrow> x \<in> Solutions"
  by (auto simp: in_Solutions_iff Special_Solutions_def sij_def dij_def eij_def)

lemma Special_Solutions_in_Minimal_Solutions:
  assumes "(x, y) \<in> Special_Solutions"
  shows "(x, y) \<in> Minimal_Solutions"
proof (intro Minimal_SolutionsI')
  show "(x, y) \<in> Solutions" by (fact Special_Solutions_in_Solutions [OF assms])
  then have [simp]: "length x = m" "length y = n" by (auto simp: in_Solutions_iff)
  show "nonzero x" using assms and dij_neq_0
    by (auto simp: Special_Solutions_def sij_def nonzero_iff)
     (metis length_replicate set_update_memI)
  show "\<not> (\<exists>(u, v)\<in>Minimal_Solutions. u @ v <\<^sub>v x @ y)"
  proof
    assume "\<exists>(u, v)\<in>Minimal_Solutions. u @ v <\<^sub>v x @ y"
    then obtain u and v where uv: "(u, v) \<in> Minimal_Solutions" and "u @ v <\<^sub>v x @ y"
      and [simp]: "length u = m" "length v = n"
      and "nonzero u" by (auto simp: Minimal_Solutions_def in_Solutions_iff)
    then consider "u <\<^sub>v x" and "v \<le>\<^sub>v y" | "v <\<^sub>v y" and "u \<le>\<^sub>v x" by (auto elim: less_append_cases)
    then show False
    proof (cases)
      case 1
      then obtain i and j where ij: "i < m" "j < n"
        and less_dij: "u ! i < dij i j"
        and "u \<le>\<^sub>v (zeroes m)[i := dij i j]"
        and "v \<le>\<^sub>v (zeroes n)[j := eij i j]"
        using assms by (auto simp: Special_Solutions_def sij_def unit_less)
      then have u: "u = (zeroes m)[i := u ! i]" and v: "v = (zeroes n)[j := v ! j]"
        by (auto simp: less_eq_def list_eq_iff_nth_eq)
          (metis le_zero_eq length_list_update length_replicate rep_upd_unit)+
      then have "u ! i > 0" using \<open>nonzero u\<close> and ij
        by (metis gr_implies_not0 neq0_conv unit_less zero_less)

      define c where "c = a ! i * u ! i"
      then have ac: "a ! i dvd c" by simp

      have "a \<bullet> u = b \<bullet> v" using uv by (auto simp: Minimal_Solutions_def in_Solutions_iff)
      then have "c = b ! j * v ! j"
        using ij unfolding c_def by (subst (asm) u, subst (asm)v, subst u, subst v) auto
      then have bc: "b ! j dvd c" by simp

      have "a ! i * u ! i < a ! i * dij i j"
        using less_dij and no0 and ij by (auto simp: in_set_conv_nth)
      then have "c < lcm (a ! i) (b ! j)" by (auto simp: dij_def c_def)
      moreover have "lcm (a ! i) (b ! j) dvd c" by (simp add: ac bc)
      moreover have "c > 0" using \<open>u ! i > 0\<close> and no0 and ij by (auto simp: c_def in_set_conv_nth)
      ultimately show False using ac and bc by (auto dest: nat_dvd_not_less)
    next
      case 2
      then obtain i and j where ij: "i < m" "j < n"
        and less_dij: "v ! j < eij i j"
        and "u \<le>\<^sub>v (zeroes m)[i := dij i j]"
        and "v \<le>\<^sub>v (zeroes n)[j := eij i j]"
        using assms by (auto simp: Special_Solutions_def sij_def unit_less)
      then have u: "u = (zeroes m)[i := u ! i]" and v: "v = (zeroes n)[j := v ! j]"
        by (auto simp: less_eq_def list_eq_iff_nth_eq)
          (metis le_zero_eq length_list_update length_replicate rep_upd_unit)+
      moreover have "nonzero v"
        using \<open>nonzero u\<close> and \<open>(u, v) \<in> Minimal_Solutions\<close>
          and Minimal_Solutions_imp_Solutions Solutions_snd_not_0 by blast
      ultimately have "v ! j > 0" using ij
        by (metis gr_implies_not0 neq0_conv unit_less zero_less)

      define c where "c = b ! j * v ! j"
      then have bc: "b ! j dvd c" by simp

      have "a \<bullet> u = b \<bullet> v" using uv by (auto simp: Minimal_Solutions_def in_Solutions_iff)
      then have "c = a ! i * u ! i"
        using ij unfolding c_def by (subst (asm) u, subst (asm)v, subst u, subst v) auto
      then have ac: "a ! i dvd c" by simp

      have "b ! j * v ! j < b ! j * eij i j"
        using less_dij and no0 and ij by (auto simp: in_set_conv_nth)
      then have "c < lcm (a ! i) (b ! j)" by (auto simp: eij_def c_def)
      moreover have "lcm (a ! i) (b ! j) dvd c" by (simp add: ac bc)
      moreover have "c > 0" using \<open>v ! j > 0\<close> and no0 and ij by (auto simp: c_def in_set_conv_nth)
      ultimately show False using ac and bc by (auto dest: nat_dvd_not_less)
    qed
  qed
qed

(*Lemma 2 of Huet*)
lemma non_special_solution_non_minimal:
  assumes "(x, y) \<in> Solutions - Special_Solutions"
    and ij: "i < m" "j < n"
    and "x ! i \<ge> dij i j" and "y ! j \<ge> eij i j"
  shows "(x, y) \<notin> Minimal_Solutions"
proof
  assume min: "(x, y) \<in> Minimal_Solutions"
  moreover have "sij i j \<in> Solutions"
    using ij by (intro Special_Solutions_in_Solutions) (auto simp: Special_Solutions_def)
  moreover have "(case sij i j of (u, v) \<Rightarrow> u @ v) <\<^sub>v x @ y"
    using assms and min
    apply (cases "sij i j")
    apply (auto simp: sij_def Special_Solutions_def)
    by (metis List_Vector.le0 Minimal_Solutions_length le_append le_list_update less_append order_vec.dual_order.strict_iff_order same_append_eq)
  moreover have "(case sij i j of (u, v) \<Rightarrow> nonzero u)"
    apply (auto simp: sij_def)
    by (metis dij_neq_0 ij length_replicate nonzero_iff set_update_memI)
  ultimately show False
    by (auto simp: Minimal_Solutions_def)
qed

subsection \<open>Huet's conditions\<close>

(*A*)
definition "cond_A xs ys \<longleftrightarrow> (\<forall>x\<in>set xs. x \<le> maxne0 ys b)"

(*B*)
definition "cond_B x \<longleftrightarrow>
  (\<forall>k\<le>m. take k a \<bullet> take k x \<le> b \<bullet> map (max_y (take k x)) [0 ..< n])"

(*C*)
definition "boundr x y \<longleftrightarrow> (\<forall>j<n. y ! j \<le> max_y x j)"

(*D*)
definition "cond_D x y \<longleftrightarrow> (\<forall>l\<le>n. take l b \<bullet> take l y \<le> a \<bullet> x)"

subsection \<open>New conditions: facilitating generation of candidates from right to left\<close>

(*condition on right sub-dotproduct*)
definition "subdprodr y \<longleftrightarrow>
  (\<forall>l\<le>n. take l b \<bullet> take l y \<le> a \<bullet> map (max_x (take l y)) [0 ..< m])"

(*condition on left sub-dotproduct*)
definition "subdprodl x y \<longleftrightarrow> (\<forall>k\<le>m. take k a \<bullet> take k x \<le> b \<bullet> y)"

(*bound on elements of left vector*)
definition "boundl x y \<longleftrightarrow> (\<forall>i<m. x ! i \<le> max_x y i)"

lemma boundr:
  assumes min: "(x, y) \<in> Minimal_Solutions"
    and "(x, y) \<notin> Special_Solutions"
  shows "boundr x y"
proof (unfold boundr_def, intro allI impI)
  fix j
  assume ass: "j < n"
  have ln: "m = length x \<and> n = length y"
    using assms Minimal_Solutions_def in_Solutions_iff min by auto
  have is_sol: "(x, y) \<in> Solutions"
    using assms Minimal_Solutions_def min by auto
  have j_less_l: "j < n"
    using assms ass le_less_trans by linarith
  consider (notemp) "Ej j x \<noteq> {}"  | (empty) " Ej j x = {}"
    by blast
  then show "y ! j \<le> max_y x j"
  proof (cases)
    case notemp
    have max_y_def: "max_y x j =  Min (Ej j x)"
      using j_less_l max_y_def notemp by auto
    have fin_e: "finite (Ej j x)"
      using finite_Ej [of j x] by auto
    have e_def': "\<forall>e \<in> Ej j x. (\<exists>i<length x. x ! i \<ge> dij i j \<and> eij i j - 1 = e)"
      using Ej_def [of j x] by auto
    then have "\<exists>i<length x. x ! i \<ge> dij i j \<and> eij i j - 1 = Min (Ej j x)"
      using notemp Min_in e_def' fin_e by blast
    then obtain i where
      i: "i < length x" "x ! i \<ge> dij i j" "eij i j - 1 = Min (Ej j x)"
      by blast
    show ?thesis
    proof (rule ccontr)
      assume "\<not> ?thesis"
      with non_special_solution_non_minimal [of x y i j]
        and i and ln and assms and is_sol and j_less_l
      have "case sij i j of (u, v) \<Rightarrow> u @ v \<le>\<^sub>v x @ y"
        by (force simp: max_y_def)
      then have cs:"case sij i j of (u, v) \<Rightarrow> u @ v <\<^sub>v x @ y"
        using assms by(auto simp: Special_Solutions_def) (metis append_eq_append_conv
            i(1) j_less_l length_list_update length_replicate sij_def
            order_vec.le_neq_trans ln prod.sel(1))
      then obtain u v where
        u_v: "sij i j = (u, v)" "u @ v <\<^sub>v x @ y"
        by blast
      have dij_gt0: "dij i j > 0"
        using assms(1) assms(2) dij_neq_0 i(1) j_less_l ln by auto
      then have not_0_u: "nonzero u"
      proof (unfold nonzero_iff)
        have "i < length (zeroes m)" by (simp add: i(1) ln)
        then show "\<exists>i\<in>set u. i \<noteq> 0"
          by (metis (no_types) Pair_inject dij_gt0 set_update_memI sij_def u_v(1) neq0_conv)
      qed
      then have "sij i j \<in> Solutions"
        by (metis (mono_tags, lifting) Special_Solutions_def i(1)
            Special_Solutions_in_Solutions j_less_l ln mem_Collect_eq u_v(1))
      then show False
        using assms cs u_v not_0_u Minimal_Solutions_def min by auto
    qed
  next
    case empty
    have "\<forall>y\<in>set y. y \<le> Max (set a)"
      using assms and max_coeff_bound and maxne0_le_Max
      using le_trans by blast
    then  show ?thesis
      using empty j_less_l ln max_y_def by auto
  qed
qed

lemma boundl:
  assumes min: "(x, y) \<in> Minimal_Solutions"
    and "(x, y) \<notin> Special_Solutions"
  shows "boundl x y"
proof (unfold boundl_def, intro allI impI)
  fix i
  assume ass: "i < m"
  have ln: "n = length y \<and> m = length x"
    using assms Minimal_Solutions_def in_Solutions_iff min by auto
  have is_sol: "(x, y) \<in> Solutions"
    using assms Minimal_Solutions_def min by auto
  have i_less_l: "i < m"
    using assms ass le_less_trans by linarith
  consider (notemp) "Di i y \<noteq> {}"  | (empty) " Di i y = {}"
    by blast
  then show "x ! i \<le> max_x y i"
  proof (cases)
    case notemp
    have max_x_def: "max_x y i =  Min (Di i y)"
      using i_less_l max_x_def notemp by auto
    have fin_e: "finite (Di i y)"
      using finite_Di [of i y] by auto
    have e_def': "\<forall>e \<in> Di i y. (\<exists>j<length y. y ! j \<ge> eij i j \<and> dij i j - 1 = e)"
      using Di_def [of i y] by auto
    then have "\<exists>j<length y. y ! j \<ge> eij i j \<and> dij i j - 1 = Min (Di i y)"
      using notemp Min_in e_def' fin_e by blast
    then obtain j where
      j: "j < length y" "y ! j \<ge> eij i j" "dij i j - 1 = Min (Di i y)"
      by blast
    show ?thesis
    proof (rule ccontr)
      assume "\<not> ?thesis"
      with non_special_solution_non_minimal [of x y i j]
        and j and ln and assms and is_sol and i_less_l
      have "case sij i j of (u, v) \<Rightarrow> u @ v \<le>\<^sub>v x @ y"
        by (force simp: max_x_def)
      then have cs: "case sij i j of (u, v) \<Rightarrow> u @ v <\<^sub>v x @ y"
        using assms by(auto simp: Special_Solutions_def) (metis append_eq_append_conv
            j(1) i_less_l length_list_update length_replicate sij_def
            order_vec.le_neq_trans ln prod.sel(1))
      then obtain u v where
        u_v: "sij i j = (u, v)" "u @ v <\<^sub>v x @ y"
        by blast
      have dij_gt0: "dij i j > 0"
        using assms(1) assms(2) dij_neq_0 j(1) i_less_l ln by auto
      then have not_0_u: "nonzero u"
      proof (unfold nonzero_iff)
        have "i < length (zeroes m)"
          using ass by simp
        then show "\<exists>i\<in>set u. i \<noteq> 0"
          by (metis (no_types) Pair_inject dij_gt0 set_update_memI sij_def u_v(1) neq0_conv)
      qed
      then have "sij i j \<in> Solutions"
        by (metis (mono_tags, lifting) Special_Solutions_def j(1)
            Special_Solutions_in_Solutions i_less_l ln mem_Collect_eq u_v(1))
      then show False
        using assms cs u_v not_0_u Minimal_Solutions_def min by auto
    qed
  next
    case empty
    have "\<forall>x\<in>set x. x \<le> Max (set b)"
      using assms and max_coeff_bound and maxne0_le_Max
      using le_trans by blast
    then  show ?thesis
      using empty i_less_l ln max_x_def by auto
  qed
qed

lemma Solution_imp_cond_D:
  assumes "(x, y) \<in> Solutions"
  shows "cond_D x y"
  using assms and dotprod_le_take by (auto simp: cond_D_def in_Solutions_iff)

lemma Solution_imp_subdprodl:
  assumes "(x, y) \<in> Solutions"
  shows "subdprodl x y"
  using assms and dotprod_le_take
  by (auto simp: subdprodl_def in_Solutions_iff) metis

theorem conds:
  assumes min: "(x, y) \<in> Minimal_Solutions"
  shows cond_A: "cond_A x y"
    and cond_B: "(x, y) \<notin> Special_Solutions \<Longrightarrow> cond_B x"
    and "(x, y) \<notin> Special_Solutions \<Longrightarrow> boundr x y"
    and cond_D: "cond_D x y"
    and subdprodr: "(x, y) \<notin> Special_Solutions \<Longrightarrow> subdprodr y"
    and subdprodl: "subdprodl x y"
proof -
  have sol: "a \<bullet> x = b \<bullet> y" and ln: "m = length x \<and> n = length y"
    using min by (auto simp: Minimal_Solutions_def in_Solutions_iff)
  then have "\<forall>i<m. x ! i \<le> maxne0 y b"
    by (metis min max_coeff_bound_right nth_mem)
  then show "cond_A x y"
    using min and le_less_trans by (auto simp: cond_A_def max_coeff_bound)
  show "(x, y) \<notin> Special_Solutions \<Longrightarrow> cond_B x"
  proof (unfold cond_B_def, intro allI impI)
    fix k assume non_spec: "(x, y) \<notin> Special_Solutions" and k: "k \<le> m"
    from k have "take k a \<bullet> take k x \<le> a \<bullet> x"
      using dotprod_le_take ln by blast
    also have "... = b \<bullet> y" by fact
    also have map_b_dot_p: "... \<le> b \<bullet> map (max_y x) [0..<n]" (is "_ \<le> _ b \<bullet> ?nt")
      using non_spec and less_eq_def and ln and boundr and min
      by (fastforce intro!: dotprod_le_right simp: boundr_def)
    also have "... \<le> b \<bullet> map (max_y (take k x)) [0..<n]" (is "_ \<le> _ \<bullet> ?t")
    proof -
      have "\<forall>j<n. ?nt!j \<le> ?t!j"
        using min and ln and max_y_le_take and k by auto
      then have "?nt \<le>\<^sub>v ?t"
        using less_eq_def by auto
      then show ?thesis
        by (simp add:  dotprod_le_right)
    qed
    finally show "take k a \<bullet> take k x \<le> b \<bullet> map (max_y (take k x)) [0..<n]"
      by (auto simp: cond_B_def)
  qed

  show "(x, y) \<notin> Special_Solutions \<Longrightarrow> subdprodr y"
  proof (unfold subdprodr_def, intro allI impI)
    fix l assume non_spec: "(x, y) \<notin> Special_Solutions" and l: "l \<le> n"
    from l have "take l b \<bullet> take l y \<le> b \<bullet> y"
      using dotprod_le_take ln by blast
    also have "... = a \<bullet> x" by (simp add: sol)
    also have map_b_dot_p: "... \<le> a \<bullet> map (max_x y) [0..<m]" (is "_ \<le> _ a \<bullet> ?nt")
      using non_spec and less_eq_def and ln and boundl and min
      by (fastforce intro!: dotprod_le_right simp: boundl_def)
    also have "... \<le> a \<bullet> map (max_x (take l y)) [0..<m]" (is "_ \<le> _ \<bullet> ?t")
    proof -
      have "\<forall>i<m. ?nt ! i \<le> ?t ! i"
        using min and ln and max_x_le_take and l by auto
      then have "?nt \<le>\<^sub>v ?t"
        using less_eq_def by auto
      then show ?thesis
        by (simp add:  dotprod_le_right)
    qed
    finally show "take l b \<bullet> take l y \<le> a \<bullet> map (max_x (take l y)) [0..<m]"
      by (auto simp: cond_B_def)
  qed

  show "(x, y) \<notin> Special_Solutions \<Longrightarrow> boundr x y"
    using boundr [of x y] and min by blast

  show "cond_D x y"
    using ln and dotprod_le_take and sol by (auto simp: cond_D_def)

  show "subdprodl x y"
    using ln and dotprod_le_take and sol by (force simp: subdprodl_def)
qed

lemma le_imp_Ej_subset:
  assumes "u \<le>\<^sub>v x"
  shows "Ej j u \<subseteq> Ej j x"
  using assms and le_trans by (force simp: Ej_def less_eq_def dij_def eij_def)

lemma le_imp_max_y_ge:
  assumes "u \<le>\<^sub>v x"
    and "length x \<le> m"
  shows "max_y u j \<ge> max_y x j"
  using assms and le_imp_Ej_subset and Min_Ej_le [of j, OF _ _ assms(2)]
  by (metis Min.subset_imp Min_in emptyE finite_Ej max_y_def order_refl subsetCE)

lemma le_imp_Di_subset:
  assumes "v \<le>\<^sub>v y"
  shows "Di i v \<subseteq> Di i y"
  using assms and le_trans by (force simp: Di_def less_eq_def dij_def eij_def)

lemma le_imp_max_x_ge:
  assumes "v \<le>\<^sub>v y"
    and "length y \<le> n"
  shows "max_x v i \<ge> max_x y i"
  using assms and le_imp_Di_subset and Min_Di_le [of i, OF _ _ assms(2)]
  by (metis Min.subset_imp Min_in emptyE finite_Di max_x_def order_refl subsetCE)

end

end


(* 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_weird_nat_add3acc_spec
imports "../../Test_Base"
begin

datatype Nat = Z | S "Nat"

fun plus :: "Nat => Nat => Nat" where
"plus (Z) y = y"
| "plus (S z) y = S (plus z y)"

fun add3acc :: "Nat => Nat => Nat => Nat" where
"add3acc (Z) (Z) z = z"
| "add3acc (Z) (S x3) z = add3acc Z x3 (S z)"
| "add3acc (S x2) y z = add3acc x2 (S y) z"

theorem property0 :
  "((add3acc x y z) = (plus x (plus y z)))"
  oops

end


theory Q_State
imports HOL.Complex vars HOL.Orderings
          Deep_Learning.Tensor_Matricization Separation_Algebra.Separation_Algebra
          QHLProver.Partial_State Tensor_Permutation HOL.Finite_Set
begin
\<comment>\<open>Function to obtain the index of variables in the vector\<close>
definition to_nat_set::"'q::linorder set \<Rightarrow> ('q \<Rightarrow> nat)"
  where "to_nat_set s \<equiv> (\<lambda>q. the (find_index q (sorted_list_of_set s)))"

lemma
  unique_nat_q:"finite s \<Longrightarrow> q \<in> s \<Longrightarrow> (\<exists>!i. to_nat_set s q = i) \<and> to_nat_set s q < card s"
proof-
  assume a0:"q \<in> s" and a1:"finite s"
  then have h:"q \<in> set (sorted_list_of_set s)" by auto
  moreover have q:"distinct (sorted_list_of_set s)" by auto
  ultimately show "(\<exists>!i. to_nat_set s q = i) \<and> to_nat_set s q < card s"
    unfolding to_nat_set_def using distinct_xs_index_a[OF q h]
    by (metis a1 distinct_card option.sel set_sorted_list_of_set)
qed

lemma
  distinct_nat_q:
  assumes a0:"finite s" and a1:"q1 \<in> s" and
     a2:"q2 \<in> s" and "q1\<noteq>q2"
   shows "to_nat_set s q1 \<noteq> to_nat_set s q2"
proof-
  have h:"q1 \<in> set (sorted_list_of_set s)" using a0 a1 by auto
  moreover have q:"distinct (sorted_list_of_set s)" by auto
  ultimately show ?thesis
    unfolding to_nat_set_def using distinct_xs_index_a[OF q h]
      find_index_equiv_less_i
    by (metis a0 a2 assms(4) distinct_xs_index_a option.distinct(1)
          option.expand set_sorted_list_of_set)
qed

lemma to_nat_set_lt:
  assumes a0:"q1 < q2" and a1:"q1 \<in> s" and a2:"q2 \<in> s" and
     a3:"finite s"
   shows "to_nat_set s q1 < to_nat_set s q2"
proof-
  let ?sl = "sorted_list_of_set s"
  obtain i where f1:"?sl ! i = q1 \<and> i < length ?sl "
    using a1 a3
    by (metis in_set_conv_nth set_sorted_list_of_set)
  moreover obtain j where f2:"?sl ! j = q2 \<and> j < length ?sl "
    using a2 a3
    by (metis in_set_conv_nth set_sorted_list_of_set)
  moreover have f3:"\<forall>i j. i \<le> j \<longrightarrow> j < length (?sl) \<longrightarrow>
                     ?sl ! i \<le> ?sl ! j"
    using sorted_nth_mono sorted_sorted_list_of_set by blast
  ultimately have "i<j"
    using not_less  a0 leD
    by metis
  then show ?thesis unfolding to_nat_set_def
    by (metis a1 a2 a3 distinct_sorted_list_of_set distinct_xs_index_b f1 f2
        find_index_distinct option.sel set_sorted_list_of_set)
qed

definition set_vars::"'q::linorder set \<Rightarrow> 'q::linorder set \<Rightarrow> nat set"
  where "set_vars vs s \<equiv> to_nat_set vs ` s"

lemma set_vars_empty:
  assumes a0:"s1 \<inter> s2 = {}" and a1:"finite s1" and a2:"finite s2"
  shows "set_vars (s1 \<union> s2) s1 \<inter> set_vars (s1 \<union> s2) s2 = {}"
proof-
  have t:"finite (s1 \<union> s2)" using a1 a2 by auto
  show ?thesis
    using a0 distinct_nat_q[OF t]
    unfolding set_vars_def by auto
qed

definition list_dims::"'q set \<Rightarrow> nat list"
  where "list_dims qvars \<equiv> replicate (card qvars) 2"

definition dims :: "'a list \<Rightarrow> nat set \<Rightarrow> 'a list" where
  "dims tv vs = nths tv vs"

\<comment>\<open> Lemmas on ptensor_vec \<close>

lemma tensor_neutral:
      shows "list_of_vec
             (partial_state2.ptensor_vec  {} {} (vec_of_list [1])
               (vec_of_list [1])) = [1::'a::comm_ring_1]"
proof-
  interpret ps2:partial_state2 "[]" "{}" "{}" apply standard by auto
  show ?thesis  unfolding ps2.ptensor_vec_def unfolding
   ind_in_set_def partial_state.tensor_vec_def  state_sig.d_def
   partial_state.encode1_def partial_state.dims1_def
    partial_state.encode2_def partial_state.dims2_def ps2.dims0_def ps2.vars0_def
    by auto
qed

lemma nths_set_gt_list_length:"nths l (- {0..<length l}) = []"
proof -
  have "nths l (- {0..<length l}) ! 0 \<notin> set (nths l (- {0..<length l}))"
    by (simp add: set_nths)
  then show ?thesis
    by (meson length_greater_0_conv nth_mem)
qed

lemma digit_decode_non_vars:"digit_decode
    (nths (nths (replicate (card d1) 2) d1) (- ind_in_set (d1 \<union> {}) ` d1))
    (nths (digit_encode (nths (replicate (card d1) 2) d1) i) (- ind_in_set (d1 \<union> {}) ` d1)) = 0"
proof-
  have "length (nths (nths (replicate (card d1) 2) d1) (- ind_in_set d1 ` d1)) = 0"
    using nths_reencode_eq_comp[of d1 d1 "(replicate (card d1) 2)",simplified] by auto
  then have
     "length (nths (digit_encode (nths (replicate (card d1) 2) d1) i) (- ind_in_set d1 ` d1)) = 0"
    by (simp add: length_digit_encode length_nths')
  then show ?thesis
    by (simp add: nths_reencode_eq_comp)
qed

lemma digit_decode_non_vars1:"digit_decode (nths (replicate (card (d1::nat set)) 2) (- ind_in_set (d1 \<union> {}) ` d1))
          (nths (digit_encode (replicate (card d1) 2) i) (- ind_in_set (d1 \<union> {}) ` d1)) = 0"
  by (metis boolean_algebra_cancel.sup0 digit_decode.simps(1) image_empty inf_bot_right
            length_digit_encode length_replicate nths_complement_ind_in_set nths_empty)

lemma digit_decode_vars:
   "i< (2::nat) ^ card (d1) \<Longrightarrow> finite (d1::nat set)  \<Longrightarrow>
     digit_decode (nths (replicate (card (d1 \<union> {})) 2) (ind_in_set (d1 \<union> {}) ` d1))
     (nths (digit_encode (replicate (card (d1 \<union> {})) 2) i) (ind_in_set (d1 \<union> {}) ` d1))   = i"
  by (metis atLeast0LessThan digit_decode_encode_lt
            length_digit_encode length_replicate lessThan_iff nths_all
            prod_list_replicate ind_in_set_id sup_bot.right_neutral)

lemma list_of_neutral:"list_of_vec (vCons 1 vNil) = [1::'a::comm_ring_1]"
  unfolding vCons_def by auto

lemma list_ptensor_neutral:"list_of_vec
       (partial_state2.ptensor_vec  {} {}
       (vCons (1::'a) vNil) (vCons (1::'a::comm_ring_1) vNil)) =
       [1::'a::comm_ring_1]"
  using tensor_neutral by auto

lemma idempoten_qstate1:
  assumes
    a0:"dim_vec (v::('a::comm_ring_1) vec) = (2::nat) ^ card (d1)" and
    a1:"i < dim_vec v" and a2:"finite d1"
  shows
     "partial_state2.ptensor_vec
             d1 {} v (vCons 1 vNil) $ i =
         v $ i"
proof-
  interpret ps2:partial_state2 "(replicate (card d1) (2::nat))" d1 "{}" apply standard
    using a2 by auto
  let  ?d0 = "digit_decode (nths ps2.dims0 (- ps2.vars1'))
                 (nths (digit_encode ps2.dims0 i) (- ps2.vars1'))"
  have  "digit_decode (nths ps2.dims0 ps2.vars1') (nths (digit_encode ps2.dims0 i) ps2.vars1') = i"
    unfolding ps2.dims0_def ps2.vars0_def ps2.vars1'_def using a0 a1 digit_decode_vars[OF _ a2]
    by  auto
  then show ?thesis unfolding ps2.ptensor_vec_def
      partial_state.tensor_vec_def state_sig.d_def partial_state.encode1_def
      partial_state.encode2_def partial_state.dims1_def partial_state.dims2_def ps2.dims0_def
                                ps2.vars0_def
    using a1 a0   apply clarsimp unfolding ps2.vars0_def ps2.vars1'_def
    using digit_decode_non_vars1
    by auto
qed

lemma nths_a_as1:
     "nths (n # replicate m n) {0..(Suc m)} =
       n # (nths (replicate m n) {0..< (m)})"
proof (induct m)
  case 0
  then show ?case by auto
next
  case (Suc m)
  then show ?case
    by (simp add: nths_all)
qed

lemma nths_a_as:
     "nths (n # replicate m n) (insert (Suc m) {0..<Suc m}) =
       n # (nths (replicate m n) (insert m {0..< m}))"
proof-
  have "nths (n # replicate m n) (insert (Suc m) {0..<Suc m}) =
        nths (n # replicate m n) {0..<Suc (Suc m)}"
    using set_upt_Suc by presburger
  moreover have "n # (nths (replicate m n) (insert m {0..< m})) =
                 n # (nths (replicate m n) {0..< Suc m})"
    using set_upt_Suc by presburger
  ultimately show ?thesis using nths_a_as1
    by (simp add: atLeast0LessThan)
qed

lemma prod_list_dims_eq_2_pow_card_a:
   "finite (d1) \<Longrightarrow> d1 \<noteq> {} \<Longrightarrow>
    prod_list
     (nths (replicate (card d1) (2::nat))
       (insert (card d1) {0..<card  d1})) = 2 ^ card d1"
proof(induct "d1" rule:finite_induct)
  case empty
  then show ?case by auto
next
  case (insert x F)
  { assume a00:"F = {}"
    then have "insert x F = {x}" using insert by auto
    then have "card  {x} = 1"
      by (simp add: card_1_singleton_iff)
    moreover have "prod_list (nths (replicate 1 (2::nat)) {0,1}) = 2 ^ card  {x}"
      using calculation by auto
    ultimately have ?case
      by (simp add: a00)
  }
  moreover {
    assume F:"F\<noteq> {}"
    have "x \<notin> F" using insert by auto
    then have "prod_list (nths (replicate (card F) (2::nat)) (insert (card F) {0..<card F})) =
               2 ^ card F" using insert(3)[OF F] by auto
    then have ?case using insert(4)
      by (simp add: nths_all)
  }
  ultimately show ?case
    by blast
qed

lemma idempoten_qstate2:
  assumes a1:"dim_vec v = (2::nat) ^ card d " and a2:"finite d"
  shows "dim_vec (partial_state2.ptensor_vec  d {} v (vCons 1 vNil)) =
   dim_vec v"
proof-
  interpret ps2:partial_state2 "(replicate (card d) (2::nat))"
                               d "{}" apply standard using a2 by auto
  show ?thesis unfolding vCons_def
    using  ps2.ptensor_vec_dim a1
    unfolding  ps2.d1_def ps2.d2_def ps2.dims1_def ps2.dims2_def ps2.dims_product
    by auto
qed

lemma idempoten_qstate:
  assumes
    a1:"dim_vec (v::('a::comm_ring_1) vec) = (2::nat) ^ card d" and a2:"finite d"
  shows "partial_state2.ptensor_vec  d {} v (vCons (1) vNil) = v"
  unfolding list_dims_def
  using idempoten_qstate1[OF a1 _ a2]  idempoten_qstate2[OF  a1 a2] by auto

definition mapping::"'q set \<Rightarrow> 'q set \<Rightarrow> nat set \<times> nat set"
  where "mapping s1 s2 \<equiv>({},{})"

typedef (overloaded) ('a::comm_ring_1)
  QState = "{(s,v)| (s::nat set) (v::'a list).
              length v = (2^(card s)) \<and> finite s \<and>
              (s = {} \<longrightarrow> ((v!0) = (1::'a)))}"
  morphisms uQState Abs_QState
  by (rule exI[where x ="({},[1])"], auto)

setup_lifting type_definition_QState

definition tensor_mat_ord::"'a QState \<Rightarrow> nat set \<Rightarrow> 'a::comm_ring_1 mat \<Rightarrow> 'a QState set"
  where "tensor_mat_ord Q q M \<equiv> {}"

lemma QState_rel1:"length(snd(uQState x)) = 2 ^ card (fst(uQState x))"
proof -
  have "\<exists>B v. uQState x = (B, v) \<and> length v = (2 ^ card B) \<and>
              (B = {}) \<longrightarrow> (v ! 0 = 1)"
    using uQState by fastforce
  then show ?thesis using uQState  by (auto simp add:  split_beta)
qed

lemma QState_rel2:"fst (uQState (x::('a::comm_ring_1) QState )) = {} \<longrightarrow>
                  (((snd (uQState x)) ! 0) = 1)"
proof -
  have "\<exists>B v. uQState x = (B, v) \<and> length v = (2 ^ card B) \<and>
              (B = {}) \<longrightarrow> (v ! 0 = 1)"
    using uQState by fastforce
  then show ?thesis using uQState  by (auto simp add:  split_beta)
qed

lemma QState_rel3:"finite (fst (uQState (x::('a::comm_ring_1) QState )))"
  apply transfer by auto

lift_definition QState_vars :: "('a::comm_ring_1) QState \<Rightarrow> nat set" is fst .
lift_definition QState_list :: "('a::comm_ring_1) QState \<Rightarrow> 'a::comm_ring_1 list" is snd .
lift_definition QState_vector::"('a::comm_ring_1) QState \<Rightarrow> 'a::comm_ring_1 vec" is "\<lambda>s. vec_of_list (snd s)" .
lift_definition QState :: "nat set \<times> 'a::comm_ring_1 list \<Rightarrow> 'a QState" is
  "\<lambda>s. (if fst s = {} \<and> snd s = [1] then (fst s, snd s)
       else (if finite (fst s) \<and> fst s \<noteq> {} \<and> length (snd s) = 2 ^ (card (fst s)) then (fst s, snd s)
       else ({}, [1])))"  by auto

lift_definition Conc :: " 'a QState \<Rightarrow> nat set \<times> 'a::comm_ring_1 vec" is
  "\<lambda>s. (QState_vars s, QState_vector s)" .

definition sca_mult_qstate::"'a::comm_ring_1 \<Rightarrow> 'a QState \<Rightarrow> 'a QState"  (infixl "\<cdot>\<^sub>q" 70)
  where "sca_mult_qstate s qs \<equiv> QState(QState_vars qs, list_of_vec (s \<cdot>\<^sub>v (QState_vector qs)))"

definition empty_qstate::"'a::comm_ring_1 QState"  ("|>")
  where "empty_qstate  \<equiv> QState({}, [1])"

lemma uqstate_fst:"fst (uQState a) = QState_vars a" apply transfer' by auto
lemma uqstate_snd:"snd (uQState a) = QState_list a" apply transfer' by auto

lemma QState_rel3':"finite (QState_vars (x::('a::comm_ring_1) QState ))"
  apply transfer by auto

lemma QState_rel1':"length(QState_list x) = 2 ^ card (QState_vars x)"
  using uqstate_fst uqstate_snd  QState_rel1
  by metis

lemma QState_rel2':"QState_vars x = {} \<Longrightarrow>
                  (((QState_list x) ! 0) = 1)"
using uqstate_fst uqstate_snd  QState_rel2
  by metis

lemma QState_empty0:"QState_vars x = {} \<Longrightarrow>
                     QState_list x = [1]"
  apply (frule QState_rel2'[of x]) apply (insert QState_rel1'[of x])
  apply auto
  by (metis Suc_length_conv list_exhaust_size_eq0 nth_Cons_0)

lemma QState_empty1:"QState_list x = [1] \<Longrightarrow> QState_vars x = {}"
  using QState_rel1' QState_rel3'
  by (metis One_nat_def card_eq_0_iff length_Cons list.size(3) nat_power_eq_Suc_0_iff
     numeral_eq_one_iff semiring_norm(85))

lemma QState_empty:"QState_vars x = {} = ((QState_list x) = [1])"
  using QState_empty1 QState_empty0 by auto

lemma uQState_fst_id_concat:"fst (uQState a) \<union> fst (uQState (QState ({}, [1]))) = fst (uQState a)"
  by (simp add: QState.rep_eq)

lemma QState_vars_id:"QState_vars a \<union> QState_vars (QState ({},[1])) = QState_vars a"
  by (simp add: uqstate_fst[THEN sym] uQState_fst_id_concat)

lemma fst_uQState_empty: "fst (uQState (QState ({}, [1]))) = {}"
  apply transfer by auto

lemma snd_uQState_empty: "snd (uQState (QState ({}, [1]))) = [1]"
  apply transfer by auto

lemma q_state_eq:
 "a = b =
 (QState_vars a = QState_vars b \<and> QState_list a = QState_list b)"
  apply transfer by auto

lemma QState_id_fst_empty:
    "a = QState ({}, [1]) \<Longrightarrow>
    fst (uQState a) = {}"
  apply transfer by auto

lemma fst_uQState_empty_snd_1:"a \<noteq> QState ({}, [1]) \<Longrightarrow>
       fst (uQState a) = {} \<Longrightarrow> snd (uQState a) = [1]"
  apply (cases "QState_vars a \<noteq> {} \<and> length (QState_list a) = 2^(card (QState_vars a)) ")
  apply transfer'
   apply (simp add: QState_list.rep_eq QState_rel1 QState_vars.rep_eq)
  apply transfer apply auto using  List.list_eq_iff_nth_eq by fastforce

lemma fst_uQState_not_empty_wf_uQState:"fst (uQState a) \<noteq> {} \<Longrightarrow>
      length (snd (uQState a)) =  2^(card (fst (uQState a)))"
  apply transfer by auto

lemma QState_refl:"QState (QState_vars a, QState_list a) = a"
  apply transfer apply auto using List.list_eq_iff_nth_eq by fastforce

lemma "QState_vars (QState (QState_vars a, QState_list a)) = QState_vars a"
  by (simp add:  QState_refl)

lemma "QState_list (QState (QState_vars a, QState_list a)) = QState_list a"
  by (simp add:  QState_refl)

definition plus_QState_vector::"('a::comm_ring_1) QState \<Rightarrow> 'a QState \<Rightarrow>nat set \<times> 'a list"
  where "plus_QState_vector q1 q2 \<equiv>
     let d1 = QState_vars q1;
         d2 = QState_vars q2;
         l1 = QState_vector q1; l2 = QState_vector q2 in
          (d1 \<union> d2, list_of_vec(partial_state2.ptensor_vec d1 d2 l1 l2))"

definition vector_element_12::"('a::comm_ring_1) QState \<Rightarrow> nat set \<Rightarrow> nat \<times> nat \<Rightarrow> 'a"
  where "vector_element_12 q v p \<equiv>
         let d = QState_vars q;
         d2 = d - v;
         l1 = QState_vector q in l1$(partial_state2.pencode12 v d2 p)"

lemma plus_QState_vector_vars:
 "fst (plus_QState_vector q1 q2) = (QState_vars q1) \<union> (QState_vars q2)"
  unfolding plus_QState_vector_def Let_def by auto

lemma plus_QState_vector_vector:
 "snd (plus_QState_vector q1 q2) =
  list_of_vec(partial_state2.ptensor_vec (QState_vars q1) (QState_vars q2) (QState_vector q1) (QState_vector q2))"
  unfolding plus_QState_vector_def Let_def by auto

lemma QState_vars_empty:"QState_vars (QState ({}, [1])) = {}"
  by (metis (no_types) QState_id_fst_empty uqstate_fst)

lemma plus_QState_vector_a_idem:
  "snd (plus_QState_vector a (QState ({}, [1]))) = QState_list a"
proof-
  let ?v0 = "QState ({}, [1])::('a) QState"
  let ?v = "(QState_vars a)"
  let ?v1 = "{}"
  let ?s = "list_dims ?v"
  have card_vars_a:"dim_vec (QState_vector a) = 2^card (QState_vars a)"
    by (simp add: QState_rel1' QState_vector.rep_eq uqstate_snd)
  moreover have finite_vars_a:"finite (QState_vars a)"
    by (simp add: QState_rel3')
  moreover have v1:"?v = (QState_vars a)" and v2:"?v1 = {}"
    by auto
  ultimately have
    tensor_prod:"partial_state2.ptensor_vec
                                (QState_vars a) {}
                                (QState_vector a) (vCons (1) vNil) = QState_vector a"
    by (fastforce intro:idempoten_qstate)
  then show ?thesis unfolding plus_QState_vector_def Let_def
     using  v1  apply transfer' by (auto simp add: list_vec)
qed

definition plus_QState:: "('a::comm_ring_1) QState \<Rightarrow> 'a QState \<Rightarrow> 'a QState"
  where "plus_QState q1 q2 \<equiv>
    let d1 = (QState_vars q1); d2 = (QState_vars q2) in
      if (d1 \<inter> d2 \<noteq> {}) then QState ({},[1])
      else QState (plus_QState_vector q1 q2)"

definition disj_QState::"('a::comm_ring_1) QState \<Rightarrow> 'a QState \<Rightarrow> bool"
  where "disj_QState q1 q2 \<equiv> QState_vars q1 \<inter> QState_vars q2 = {}"

\<comment>\<open>Lemmas on plus_QState_vector\<close>

\<comment>\<open>plus_QState_vector is well formed:
   the set of vars is finite, the length of the product tensor is 2^ of the cardinality of the vars
   if the set of vars is empty, then the tensor is [1]
\<close>

lemma plus_QState_set_wf:"\<lbrakk>d1 = (QState_vars q1); d2 = (QState_vars q2);
          s = d1 \<union> d2\<rbrakk> \<Longrightarrow> finite s"
  apply transfer by fastforce

lemma plus_QState_vector_set_wf:"finite (fst (plus_QState_vector q1 q2))"
  unfolding plus_QState_vector_def Let_def using plus_QState_set_wf
  by fastforce

lemma prod_list_card_d_empty_one:" d\<noteq>{} \<Longrightarrow>
       prod_list (nths (replicate (card d) 2) {0..<Suc (card d)}) = 2 ^ card d"
  by (metis atLeast0LessThan length_replicate lessI lessThan_iff
           less_trans nths_all prod_list_replicate)

lemma card_ind_in_set:
   assumes a0: "(v1::nat set) \<inter> v2 = {}" and
           a1:"finite v1"
   shows "card (ind_in_set (v1 \<union> v2) ` v1) = card v1"
proof-
  have f1: "finite (ind_in_set (v1 \<union> v2) ` v1)"
    using a1 by blast
  moreover have  "v1 \<subseteq> v1"
    by simp
  ultimately show ?thesis
    by (metis a1 card_atLeastLessThan diff_zero ind_in_set_assoc ind_in_set_id sup_ge1)
qed

lemma dim_vec_plus_2_pow_s:
  assumes a0:"d1 =  QState_vars q1" and
          a1:"d2 =  QState_vars q2" and
          a2:"s = d1 \<union> d2" and a3:"l1 = QState_vector q1" and a4:"l2 = QState_vector q2" and
          a5:"ds = list_dims s" and
          a6:"v = partial_state2.ptensor_vec  d1 d2 l1 l2"  and
          a7:"QState_vars q1 \<inter> QState_vars q2 = {}"
  shows "dim_vec v = (2^(card ((QState_vars q1) \<union> (QState_vars q2))))"
proof-
  have f1:"finite (QState_vars q1)" and f2:"finite (QState_vars q2)"
    using QState_rel3' by auto
  have int_d1_d2:"d1 \<inter> d2 = {}" using a0 a1 a7
    by (smt disjoint_iff_not_equal image_iff ind_in_set_inj subset_eq
          sup_commute sup_ge1)
  interpret ps2:partial_state2 ds  d1 d2  apply standard using int_d1_d2
    using f1 f2 a0 a1 a5 f1 f2 unfolding list_dims_def
    by auto

   have "dim_vec v = prod_list ds"
    using a6  a5 a7 a2 unfolding ps2.ptensor_vec_def partial_state.tensor_vec_def
      state_sig.d_def
   partial_state.encode1_def partial_state.dims1_def ps2.dims0_def ps2.vars0_def
    partial_state.encode2_def partial_state.dims2_def list_dims_def
    by auto
  moreover have "card s = card ((QState_vars q1) \<union> (QState_vars q2))"
    using a0 a1 a2 by blast
  ultimately show ?thesis using a5 unfolding list_dims_def by auto
qed

lemma plus_QState_vector_wf':
  assumes a9:"QState_vars q1 \<inter> QState_vars q2 = {}" and
          a0:"d1 = QState_vars q1" and
          a1:"d2 = QState_vars q2" and
          a2:"s = d1 \<union> d2" and a3:"l1 = QState_vector q1" and a4:"l2 = QState_vector q2" and
          a5:"ds = list_dims s" and
          a6:"v = partial_state2.ptensor_vec  d1 d2 l1 l2"
        shows "dim_vec v =  2 ^ card (QState_vars q1 \<union> QState_vars q2)"
  using dim_vec_plus_2_pow_s[OF a0 a1 a2 a3 a4 a5 a6 a9] by auto

lemma plus_QState_vector_wf: assumes a0: "QState_vars q1 \<inter> QState_vars q2 = {}"
  shows "length (snd (plus_QState_vector q1 q2)) =
        2 ^ card (fst (plus_QState_vector q1 q2))"
  unfolding plus_QState_vector_def Let_def using a0
  apply clarsimp  apply (frule plus_QState_vector_wf')
  by force+

lemma plus_QState_vector_empty_vars_one_wf:
  assumes a0:"fst (plus_QState_vector q1 q2) = {} "
  shows "snd (plus_QState_vector q1 q2) = [1]"
proof-
  have "QState_vars q1 = {} \<and> QState_vars q2 = {}"
    using a0 unfolding plus_QState_vector_def Let_def by  auto
  moreover have "QState_list q1 = [1] \<and> QState_list q2 = [1]"
    using QState_empty calculation
    by auto
  ultimately show ?thesis
    unfolding plus_QState_vector_def Let_def list_dims_def
    apply auto apply transfer'
    using tensor_neutral by auto
qed

lemma QState_vars_Plus:"(QState_vars q1 \<inter> QState_vars q2 \<noteq> {} \<longrightarrow>
          QState_vars (plus_QState q1 q2) = {}) \<and>
       (QState_vars q1 \<inter> QState_vars q2 = {} \<longrightarrow>
           QState_vars (plus_QState q1 q2) = fst (plus_QState_vector q1 q2))"
    apply (auto simp add: plus_QState_def ) apply transfer
    apply simp
   apply transfer' using plus_QState_vector_set_wf plus_QState_vector_wf
   apply (smt fst_conv)
   apply transfer' using plus_QState_vector_set_wf plus_QState_vector_wf
  by fastforce

lemma QState_list_Plus:"(QState_vars q1 \<inter> QState_vars q2 \<noteq> {} \<longrightarrow>
          QState_list (plus_QState q1 q2) = [1]) \<and>
       (QState_vars q1 \<inter> QState_vars q2 = {} \<longrightarrow>
           QState_list (plus_QState q1 q2) = snd (plus_QState_vector q1 q2))"
    apply (auto simp add: plus_QState_def ) apply transfer
    apply auto
  apply transfer
  apply auto
  using plus_QState_vector_set_wf plus_QState_vector_wf plus_QState_vector_empty_vars_one_wf
  by  blast+

lemma neutral_vector_wf:"length [1] = (2^(card {}))" by auto

lemma plus_QState_finite:"finite (QState_vars (plus_QState q1 q2))"
  by (simp add: QState_rel3')

lemma plus_QState_length:"length (QState_list (plus_QState q1 q2)) =  2^card (QState_vars (plus_QState q1 q2))"
  by (simp add: QState_rel1')

lemma plus_QState_neutral:
  "QState_vars (plus_QState q1 q2) = {} =
   ((QState_list (plus_QState q1 q2)) = [1])"
  using QState_empty by auto

lemma plus_idem:"plus_QState a (QState ({},[1])) = a"
proof-
  {
    assume a00:"QState_vars a = {}"
    have ?thesis
      by (metis (no_types) QState_empty QState_list_Plus QState_refl a00 plus_QState_vector_a_idem)
  }
  moreover {
    let ?n = "QState ({},[1])"
    assume a00:"QState_vars a \<noteq>{}"
    have "fst (plus_QState_vector a ?n) = QState_vars a"
      by (simp add: QState_vars_empty plus_QState_vector_vars)
    moreover have "snd (plus_QState_vector a ?n) = QState_list a"
      by (simp add: plus_QState_vector_a_idem)
    moreover have "QState_vars (plus_QState a ?n) = fst (plus_QState_vector a ?n) "
      using QState_vars_Plus
      by (metis fst_uQState_empty inf_bot_right uqstate_fst)
    moreover have "QState_list (plus_QState a ?n) = snd (plus_QState_vector a ?n)"
      by (simp add: QState_list_Plus QState_vars.rep_eq fst_uQState_empty)
    ultimately have ?thesis using q_state_eq by auto
  }
  ultimately show ?thesis by auto
qed
typedef natsub = "{x. x<(10::nat)}"
  by (meson mem_Collect_eq zero_less_numeral)

lemma plus_comm:"disj_QState x y \<Longrightarrow> plus_QState x y = plus_QState y x"
proof-
  assume "disj_QState x y"
  then have disj:"QState_vars x  \<inter> QState_vars y = {}"
    unfolding disj_QState_def by auto
  moreover have f1:"finite (QState_vars x)" and f2:"finite (QState_vars y)"
    by (auto simp add: QState_rel3')
  then have "QState_vars (plus_QState x y)  = QState_vars (plus_QState y x)"
    by (metis QState_vars_Plus fst_conv inf_commute plus_QState_vector_def sup_commute)
  moreover have "snd (plus_QState_vector x y) = snd (plus_QState_vector y x)"
    unfolding plus_QState_vector_def Let_def using sup_commute
    by (auto simp add: ptensor_vec_comm[OF disj f1 f2])
  then have  "QState_list  (plus_QState x y) = QState_list (plus_QState y x)"
    by (metis QState_list_Plus inf_commute)
  ultimately show "plus_QState x y = plus_QState y x" using q_state_eq by auto
qed

lemma ind_in_set_union:"(ind_in_set (A \<union> B) ` A) \<union> (ind_in_set (A \<union> B) ` B) = ind_in_set (A \<union> B) ` (A \<union> B)"
  by blast

lemma ind_in_set_int:"A \<inter> B = {} \<Longrightarrow> finite (A::nat set) \<Longrightarrow> finite B \<Longrightarrow>
      ind_in_set (A \<union> B) ` A \<inter> ind_in_set (A \<union> B) ` B = {}"
  by (smt add_cancel_left_right add_diff_cancel_right' card_0_eq card_Un_Int
          card_atLeastLessThan card_ind_in_set finite_Int finite_UnI
          finite_imageI ind_in_set_union inf_commute ind_in_set_id sup_commute)

lemma ind_in_set_subset:
  assumes a0:"finite (A::nat set)" and a1:"finite B"
  shows "ind_in_set A ` A \<subseteq> ind_in_set (A \<union> B) ` (A \<union> B)"
  by (simp add: a0 a1 card_mono ind_in_set_id)

value "ind_in_set {0::nat,1,2,3,4,5} ` {1,2,3}"
value "ind_in_set {1,2,3::nat} ` {1,2,3}"

lemma ind_in_set_absorb:"finite (A::nat set) \<Longrightarrow> finite B \<Longrightarrow> finite C \<Longrightarrow>
      ((ind_in_set (A \<union> B) ` (A \<union> B)) \<union> (ind_in_set (A \<union> B \<union> C) ` (A \<union> B \<union> C))) = ind_in_set (A \<union> B \<union> C) ` (A \<union> B \<union> C) "
  by (simp add: ind_in_set_subset sup.absorb2)

lemma nths_eq:"v = {0..<card v} \<Longrightarrow>
       nths (list_dims v @ ds'') v =
       nths (list_dims v) v"
  unfolding list_dims_def
  by (smt Collect_cong add_cancel_left_right append_Nil2 atLeast0LessThan le_add_same_cancel1
          length_append length_nths length_replicate lessThan_iff less_le_trans
          list_exhaust_size_eq0 nths_append zero_le)

lemma QState_list_assoc:
   assumes a0:"QState_vars x  \<inter> QState_vars y = {}" and
              a1:"QState_vars y  \<inter> QState_vars z = {}" and
              a2:"QState_vars x  \<inter> QState_vars z = {}" and
              a3:"QState_vars (plus_QState  x y) \<inter> QState_vars z = {}" and
              a4:"QState_vars x \<inter> QState_vars (plus_QState y z) = {}"
            shows "QState_list (plus_QState (plus_QState x y) z) =
                     QState_list (plus_QState x (plus_QState y z))"
proof-
  have fx:"finite (QState_vars x)" and fy:"finite (QState_vars y)" and fz:"finite (QState_vars z)"
    by (auto simp add: QState_rel3')

  have "QState_vars (plus_QState x y) = QState_vars x \<union> QState_vars y" and
                "QState_vars (plus_QState y z) = QState_vars y \<union> QState_vars z"
    by (auto simp add: QState_vars_Plus a0 a1 plus_QState_vector_vars)
  moreover have "QState_vector (plus_QState x y) = vec_of_list (snd (plus_QState_vector x y))"
    using QState_list_Plus a0
    by (simp add: QState_list_Plus QState_vector.rep_eq uqstate_snd)
  moreover have "QState_vector (plus_QState y z) = vec_of_list (snd (plus_QState_vector y z))"
    using QState_list_Plus a1
    by (simp add: QState_list_Plus QState_vector.rep_eq uqstate_snd)
  moreover have f1:"QState_list (plus_QState (plus_QState x y) z) = snd (plus_QState_vector (plus_QState x y) z)"
    using QState_list_Plus a3
    by blast
  moreover have f2:" QState_list (plus_QState x (plus_QState y z)) = snd (plus_QState_vector x (plus_QState y z))"
    using QState_list_Plus a4 by blast
  ultimately show ?thesis unfolding plus_QState_vector_vector vec_list apply auto
    by (metis a0 a3 fx fy fz ptensor_vec_assoc)
qed

lemma plus_assoc:
  assumes a0:"disj_QState x y" and a1:"disj_QState y z" and a2:"disj_QState x z"
  shows "plus_QState (plus_QState x y) z = plus_QState x (plus_QState y z)"
proof-
  have disjxy:"QState_vars x  \<inter> QState_vars y = {}" and
       disjyz:"QState_vars y  \<inter> QState_vars z = {}" and
       disjxz:"QState_vars x  \<inter> QState_vars z = {}"
    using a0 a1 a2 unfolding disj_QState_def by auto
  have disjxyz1:"QState_vars (plus_QState  x y) \<inter> QState_vars z = {}"
    by (metis QState_vars_Plus Un_subset_iff disjoint_eq_subset_Compl
              disjxy disjxz disjyz plus_QState_vector_vars)
  have disjxyz2:"QState_vars x \<inter> QState_vars (plus_QState y z) = {}"
    by (metis QState_vars_Plus disjoint_eq_subset_Compl disjxy disjxz disjyz inf_sup_aci(1)
              plus_QState_vector_vars sup.bounded_iff)
  have "QState_vars (plus_QState (plus_QState x y) z) = QState_vars (plus_QState x  (plus_QState y z))"
    unfolding plus_QState_def Let_def using disjxy disjyz disjxz disjxyz1 disjxyz2 apply simp
    by (metis (no_types, lifting) QState_vars_Plus inf_sup_aci(6) plus_QState_def plus_QState_vector_vars)
  moreover have "QState_vars (plus_QState x y) = QState_vars x \<union> QState_vars y" and
                "QState_vars (plus_QState y z) = QState_vars y \<union> QState_vars z"
    by (auto simp add: QState_vars_Plus disjxy disjyz plus_QState_vector_vars)
  have "QState_list (plus_QState (plus_QState x y) z) = QState_list (plus_QState x (plus_QState y z))"
    using QState_list_assoc[OF disjxy disjyz disjxz disjxyz1 disjxyz2] by auto
  ultimately show ?thesis
    by (simp add: q_state_eq)

qed

lemma plus_disj_dist:"\<lbrakk>disj_QState x (plus_QState y z); disj_QState y z\<rbrakk> \<Longrightarrow> disj_QState x y"
  unfolding disj_QState_def  Let_def plus_QState_def  plus_QState_vector_vars apply auto
  by (metis QState_vars_Plus UnCI disjoint_iff_not_equal plus_QState_def plus_QState_vector_vars)

lemma plus_dis_dist2:" \<lbrakk>disj_QState x (plus_QState y z); disj_QState y z\<rbrakk> \<Longrightarrow> disj_QState (plus_QState x y) z"
proof-
  assume a0:"disj_QState x (plus_QState y z)" and a1:"disj_QState y z"
  have "disj_QState x y" using plus_disj_dist[OF a0 a1] by auto
  then show ?thesis  using QState_vars_Plus a0 a1 unfolding disj_QState_def
    by (simp add: QState_vars_Plus inf_sup_distrib1 inf_sup_distrib2 plus_QState_vector_vars)
qed

instantiation QState :: (comm_ring_1) sep_algebra
begin
definition zero_QState: "0 \<equiv> QState ({},[1])"
definition plus_QState: "s1 + s2 \<equiv> plus_QState s1 s2"
definition sep_disj_QState: "s1 ## s2 \<equiv> disj_QState s1 s2"
instance
  apply standard
  apply (simp add: zero_QState sep_disj_QState)
        apply (simp add: QState_vars_empty disj_QState_def)
       apply (simp add: disj_QState_def inf_commute sep_disj_QState)
      apply (auto simp add: zero_QState  plus_QState Let_def intro:plus_idem)[1]
     apply (auto simp add: sep_disj_QState plus_QState intro:plus_comm)[1]
    apply (auto simp add: sep_disj_QState plus_QState intro:plus_assoc)[1]
   apply (auto simp add: sep_disj_QState plus_QState intro:plus_disj_dist)[1]
  apply (auto simp add: sep_disj_QState plus_QState intro:plus_dis_dist2)[1]
  done
end

end


theory Paracontractions
imports
  Main Limits
  "~~/src/HOL/Library/Convex"
  "~~/src/HOL/Multivariate_Analysis/Topology_Euclidean_Space"
begin

abbreviation F :: "('a::real_vector \<Rightarrow> 'a::real_vector) \<Rightarrow> 'a::real_vector set" where
"F(f) \<equiv> {x. f(x) = x}"

definition "qne f \<longleftrightarrow>
((\<exists> x. f x = x) \<and> (\<forall>x y. (f y = y) \<longrightarrow> (norm (f x - y) \<le> norm (x - y))))"

definition "paracontraction f \<longleftrightarrow>
((\<exists>x. f x = x) \<and> (\<forall>x y. (f x \<noteq> x \<and> f y = y) \<longrightarrow> (norm (f x - y) < norm (x - y))))"

lemma paracontractionI:
  assumes "\<exists>x. f x = x"
  assumes "\<And>x y. f x \<noteq> x \<Longrightarrow> f y = y \<Longrightarrow> (norm (f x - y) < norm (x - y))"
  shows "paracontraction f"
by (simp add: assms paracontraction_def)

lemma paracontractionE:
  assumes "paracontraction f"
  shows "\<exists>z. f z = z" and "\<And>x y. f x \<noteq> x \<Longrightarrow> f y = y \<Longrightarrow> (norm (f x - y) < norm (x - y))"
using assms paracontraction_def apply auto[1]
using assms paracontraction_def by blast

lemma pc_qne:
  assumes "paracontraction f"
  shows "f y = y \<Longrightarrow> norm (f x - y) \<le> norm (x - y)"
by (metis assms le_less_linear less_imp_le paracontraction_def)

lemma pc_norm_eq_impl_fp:
  assumes "paracontraction f"
  assumes "f y = y"
  assumes n: "norm (f x - y) = norm (x - y)"
  shows "f x = x"
proof (rule ccontr)
  assume "f x \<noteq> x"
  hence "norm (f x - y) < norm (x - y)" using assms paracontractionE by blast
  thus "False" using assms by auto
qed

(* Composition of pc intersects fixed points *)
lemma pc_comp_intersect_fp:
  assumes f_g_pc: "paracontraction f" "paracontraction g"
  assumes ex_cfp: "\<exists> x. f x = x \<and> g x = x"
  shows "F(f o g) = F(f) \<inter> F(g)"
proof
  show "F (f) \<inter> F(g) \<subseteq> F(f o g)" using comp_def by auto
(*
proof
  assume "f x = x \<and> g x = x"
  hence "(f o g) x = x" by simp
  then have "?thesis" by auto
  qed
*)
next
  show "F(f o g) \<subseteq> F(f) \<inter> F(g)"
  proof
    fix x
    assume x_fp: "x \<in> F(f o g)"
    obtain y where y_cfp: "f y = y \<and> g y = y" using ex_cfp by auto

    have x_fp_g: "g x = x \<and> f (g x) = g x"
    proof (rule ccontr)
      assume "\<not> (g x = x \<and> f (g x) = g x)"
      hence "g x \<noteq> x \<or> f (g x) \<noteq> g x" by simp
      hence "norm (f (g x) - y) < norm (x - y)"
      proof
        assume "g x \<noteq> x"
        from this f_g_pc y_cfp have "norm (g x - y) < norm (x - y)"
          by (simp add: paracontraction_def)
        moreover have "norm (f (g x) - y) \<le> norm (g x - y)" using f_g_pc y_cfp pc_qne by auto
        ultimately show "?thesis" by simp
      next
        assume "f (g x) \<noteq> g x"
        from this f_g_pc y_cfp have "norm (f (g x) - y) < norm (g x - y)"
          by (simp add: paracontraction_def)
        moreover have "norm ((g x) - y) \<le> norm (x - y)" using f_g_pc y_cfp pc_qne by auto
        ultimately show "?thesis" by simp
      qed
      moreover have "x = f (g x)" using x_fp by simp
      ultimately have "norm x < norm x" by simp
      thus "False" by simp
    qed
    hence x_fp_f: "f x = x" by auto
    from x_fp_f x_fp_g show "x \<in> F(f) \<inter> F(g)" by simp
  qed
qed

(* Unsure if this is necessary to have.
 * Maybe the original theorem should be stated this way *)
(*
lemma pc_comp_intersect_fp2:
  assumes f_g_pc: "paracontraction f" "paracontraction g"
  assumes ex_cfp: "\<exists> x. f x = x \<and> g x = x"
  shows "(f o g) x = x \<longleftrightarrow> f x = x \<and> g x = x"
using assms pc_comp_intersect_fp by auto
*)

(* Composition of pc is pc *)
lemma pc_closed_comp:
  assumes f_g_pc: "paracontraction f" "paracontraction g"
  assumes ex_cfp: "\<exists> x. f x = x \<and> g x = x"
  shows "paracontraction (f o g)"
  unfolding paracontraction_def
proof (* Figure out an initial proof method for paracontractions. e.g.6 Introduction rules. *)
  show "\<exists>x. (f o g) x = x"
    using ex_cfp by (metis comp_apply)
    (* NOTE: We don't even need pc_comp_intersect_fp *)
next
  show  "\<forall>x y. ((f o g) x \<noteq> x) \<and> ((f o g) y = y) \<longrightarrow> norm ((f o g) x - y) < norm (x - y)"
  apply (auto) (* Make goals be correct. TODO: Look up the right way to do this in isar.
                * See isar-ref, Sec 2.3.6 *)
  proof -
    fix x y
    assume x_nfp: "f (g x) \<noteq> x"
    assume y_fp: "f (g y) = y"

    have y_cfp: "f y = y \<and> g y = y"
      using assms y_fp pc_comp_intersect_fp by auto
    moreover have x_or_nfp: "f x \<noteq> x \<or> g x \<noteq> x"
      using x_nfp f_g_pc pc_comp_intersect_fp by auto
    ultimately have "norm (f (g x) - y) < norm (g x - y) \<or> norm (g x - y) < norm (x - y)"
      using paracontraction_def f_g_pc  by metis
    thus "norm (f (g x) - y) < norm (x - y)" using f_g_pc y_cfp pc_qne by smt
  qed
qed

(* Fixed points of pc is convex *)
lemma pc_fp_convex:
  assumes "paracontraction f"
  shows "convex (F(f))"
unfolding convex_alt
apply(auto) (* TODO: Figure out how to do this in isar *)
proof -
  fix x y
  fix u :: real
  assume x_y_fp: "f x = x" "f y = y"
  assume u_bound: "0 \<le> u" "u \<le> 1"
  def z \<equiv> "(1 - u) *\<^sub>R x + u *\<^sub>R y"
  have "z \<in> F f" (* This is the meat of it *)
  proof (rule ccontr)
    assume z_not_fp: "z \<notin> F f"
    have "norm (x - y) \<le> norm(f z - x) + norm(f z - y)"
      using norm_diff_triangle_le norm_imp_pos_and_ge norm_minus_commute by blast
    moreover have "norm(f z - x) < norm(z - x)" "norm(f z - y) < norm(z - y)"
      using assms paracontractionE x_y_fp z_not_fp mem_Collect_eq by auto
    hence "norm (x - y) < norm(z - x) + norm(z - y)"
      using paracontraction_def x_y_fp using calculation by linarith
    moreover have "norm(z-x) = u * norm(x-y)"
      apply (simp add: z_def algebra_simps)
      apply (smt norm_minus_commute norm_scaleR real_vector.scale_right_diff_distrib u_bound(1))
      done
    moreover have "norm(z-y) = (1-u) * norm(x-y)"
      proof -
        have "norm(z-y) = norm((1-u) *\<^sub>R (x-y))"
          by (simp add: z_def algebra_simps)
        thus "?thesis" using norm_scaleR u_bound(2) by auto
      qed
    ultimately have "norm (x - y) < norm(x-y)"
      by (metis add.commute diff_add_cancel distrib_right mult.left_neutral)
    thus "False" by simp
  qed
  thus "f ((1 - u) *\<^sub>R x + u *\<^sub>R y) = (1 - u) *\<^sub>R x + u *\<^sub>R y" using z_def by simp
qed

lemma pc_fejer_monotone:
  assumes "paracontraction f"
  assumes "f y = y"
  shows "norm ((f^^n) x - y) \<le> norm (x-y)"
apply(induction n)
apply(auto)
by (metis (full_types) assms le_less_trans linear not_le paracontractionE(2))

lemma pc_fejer_monotone2:
  assumes "paracontraction f"
  assumes "f y = y"
  shows "norm ((f^^(m+n)) x - y) \<le> norm ((f^^m) x - y)"
proof (induction n)
  show "norm ((f^^(m + 0)) x - y) \<le> norm ((f ^^ m) x - y)" by auto
next
  fix n
  assume induct_hyp: "norm ((f^^(m + n)) x - y) \<le> norm ((f^^m) x - y)"
  have "norm ((f ^^ (m + Suc n)) x - y) \<le> norm ((f^^(m + n)) x - y)" using assms pc_qne by simp
  thus "norm ((f ^^ (m + Suc n)) x - y) \<le> norm ((f ^^ m) x - y)" using le_trans induct_hyp by simp
qed

lemma pc_fejer_monotone3:
  assumes "paracontraction f"
  assumes "f y = y"
  assumes "m\<le>n"
  shows "norm ((f^^n) x - y) \<le> norm ((f^^m) x - y)"
using assms pc_fejer_monotone2 le_iff_add by auto

(* Replace this using facts about fejer monotone sequences *)
theorem pc_convergent:
  fixes f :: "'a::euclidean_space \<Rightarrow> 'a::euclidean_space"
  assumes f_pc: "paracontraction f"
  (* assumes "continuous f" *)
  shows "\<exists>z\<in>F(f). ((\<lambda>n. (f^^n) x) \<longlonglongrightarrow> z)"
proof
fix x
have "\<exists>y. f y = y" using f_pc paracontractionE by auto
from this obtain y where y_fp: "f y = y"  by auto

def ns \<equiv> "\<lambda>n. (norm ((f^^n) x - y))"
def xs \<equiv> "\<lambda>n. (f^^n) x"

(* norm sequence converges *)
have "decseq ns"
  by (simp add: decseq_def ns_def f_pc y_fp pc_fejer_monotone3)
then obtain d where ns_to_d: "ns \<longlonglongrightarrow> d"
  by (metis decseq_convergent norm_ge_zero ns_def)

(* xs has convergent subsequence *)
have "Bseq xs" (* Interestingly, *)
proof -
  have  "\<And>n. norm((f^^n) x) \<le> norm y + norm ((f^^n) x - y)" using norm_triangle_sub by auto
  moreover have "\<And>n. norm((f^^n) x - y) \<le> norm (x - y)" using f_pc y_fp pc_fejer_monotone by auto
  finally have  "\<And>n. norm((f^^n) x) \<le> norm y + norm (x - y)" using le_trans by auto
  thus "?thesis" using BseqI' xs_def by metis
qed
hence "seq_compact (range xs)"
hence "bounded (range xs)"
using Bseq_def bounded_def
Bseq_eq_bounded
sledgehammer
(*bounded_closed_imp_seq_compact*)
hence "seq_compact {(f^^n) x | n \<ge> 0}"
from this obtain r z where "subseq r" "(xs o r) \<longlonglongrightarrow> z"
  by (metis bounded_seq_has_conv_subseq)

(* z is a limit point *)
moreover have "f z = z"
proof -
  have "(\<lambda>n. norm (f ((xs o r) n) - y)) \<longlonglongrightarrow> d"

thus "\<exists>z. (comp_power f x) \<longlonglongrightarrow> z"

(* Bounded sequence has convergent subsequence *)
theorem bounded_seq_has_conv_subseq:
  fixes f :: "nat \<Rightarrow> 'a::euclidean_space"
  assumes "Bseq f"
  obtains l r where "l \<in> S" "subseq r" "((f \<circ> r) \<longlongrightarrow> l) sequentially"
proof -
  have "compact {f^^n x. n \<ge> 0}"
  apply compact_def

lemma compact_def:
  "compact (S :: 'a::metric_space set) \<longleftrightarrow>
   (\<forall>f. (\<forall>n. f n \<in> S) \<longrightarrow> (\<exists>l\<in>S. \<exists>r. subseq r \<and> (f \<circ> r) \<longlonglongrightarrow> l))"
  unfolding compact_eq_seq_compact_metric seq_compact_def by auto

lemma seq_compactE:
  assumes "seq_compact S" "\<forall>n. f n \<in> S"
  obtains l r where "l \<in> S" "subseq r" "((f \<circ> r) \<longlongrightarrow> l) sequentially"

end