(* Author: Alexander Bentkamp, Universität des Saarlandes
*)
section \<open>Unit Vectors as Tensors\<close>

theory Tensor_Unit_Vec
imports Tensor_Product
begin

definition unit_vec::"nat \<Rightarrow> nat \<Rightarrow> 'a::ring_1 tensor"
where "unit_vec n i = tensor_from_lookup [n] (\<lambda>x. if x=[i] then 1 else 0)"

lemma dims_unit_vec: "dims (unit_vec n i) = [n]" unfolding unit_vec_def by (simp add: tensor_from_lookup_def)

lemma lookup_unit_vec:
assumes "j<n"
shows "lookup (unit_vec n i) [j] = (if i=j then 1 else 0)"
proof -
  have "[j] \<lhd> [n]" by (simp add: assms valid_index.Cons valid_index.Nil)
  then have "lookup (unit_vec n i) [j] = (\<lambda>x. if x=[i] then 1 else 0) [j]"
    by (simp add: lookup_tensor_from_lookup unit_vec_def)
  then show ?thesis by auto
qed

lemma subtensor_prod_with_unit_vec:
fixes A::"'a::ring_1 tensor"
assumes "j<n"
shows "subtensor (unit_vec n i \<otimes> A) j = (if i=j then A else (tensor0 (dims A)))"
proof -
  have 0:"lookup (unit_vec n i) [j] = (if i=j then 1 else 0)" unfolding unit_vec_def
    by (simp add: assms lookup_tensor_from_lookup valid_index.Cons valid_index.Nil)
  have 1:"order (unit_vec n i) = 1" unfolding unit_vec_def by (simp add: tensor_from_lookup_def)
  from assms have 2:"j < hd (dims (tensor_from_lookup [n] (\<lambda>x. if x = [i] then 1 else 0)))"
    by (simp add: dims_tensor_from_lookup)
  show ?thesis using unit_vec_def subtensor_prod_with_vec 1 2 0 smult_1 tensor_smult0
    by (metis (no_types, lifting) tensor_from_lookup_eqI)
qed

lemma subtensor_decomposition:
assumes "dims A \<noteq> []"
shows "listsum (dims A) (map (\<lambda>i. unit_vec (hd (dims A)) i \<otimes> subtensor A i) [0..<hd (dims A)]) = A" (is "?LS = A")
proof -
  let ?f = "\<lambda>i. unit_vec (hd (dims A)) i \<otimes> subtensor A i"
  have correct_dims:"\<And>B. B \<in> set (map ?f [0..<hd (dims A)]) \<Longrightarrow> dims B = dims A"
  proof-
    fix B
    assume "B \<in> set (map ?f [0..<hd (dims A)])"
    then obtain i where B:"B = ?f i" and "i<hd (dims A)" by auto
    then have "dims (subtensor A i) = tl (dims A)" using dims_subtensor using assms by blast
    then show "dims B = dims A" unfolding B
      by (metis append_Cons assms dims_tensor_prod dims_unit_vec list.exhaust_sel self_append_conv2)
  qed
  have "\<And>j. j < hd (dims A) \<Longrightarrow> subtensor ?LS j = subtensor A j"
  proof -
    fix j
    assume "j < hd (dims A)"
    have 1:"subtensor ?LS j = listsum (tl (dims A)) (map (\<lambda>A. subtensor A j) (map ?f [0..<hd (dims A)]))"
      using subtensor_listsum[of "(map (\<lambda>i. ?f i) [0..<hd (dims A)])" "dims A" j, OF correct_dims assms \<open>j < hd (dims A)\<close>]
      by linarith
    also have "... = listsum (tl (dims A)) (map (\<lambda>i. subtensor (?f i) j) [0..<hd (dims A)])"
    proof -
      have "map (\<lambda>A. subtensor A j) (map ?f [0..<hd (dims A)]) = map (\<lambda>i. subtensor (?f i) j) [0..<hd (dims A)]"
        unfolding map_map[of "(\<lambda>A. subtensor A j)" "?f" "[0..<hd (dims A)]"] by simp
      with 1 show ?thesis by metis
    qed
    also have "... =  map (\<lambda>i. if i = j then subtensor A i else tensor0 (dims (subtensor A i))) [0..<hd (dims A)] ! j"
      unfolding subtensor_prod_with_unit_vec[OF \<open>j < hd (dims A)\<close>]
      using listsum_all_0_but_one[of j "(map (\<lambda>i. if i = j then subtensor A i else tensor0 (dims (subtensor A i))) [0..<hd (dims A)])" "tl (dims A)"]
      by (simp add: \<open>j < hd (dims A)\<close> assms)
    also have "... = subtensor A j" by (simp add: \<open>j < hd (dims A)\<close>)
    finally show "subtensor ?LS j = subtensor A j" by auto
  qed
  moreover have "dims ?LS = dims A" using correct_dims listsum_dims by blast
  ultimately show ?thesis using subtensor_eqI by (metis (no_types, lifting) assms)
qed

end


section "Independent Set"

theory Approx_MIS_Hoare
imports
  "HOL-Hoare.Hoare_Logic"
  "HOL-Library.Disjoint_Sets"
begin

text \<open>The algorithm is classical, the proofs are inspired by the ones
by Berghammer and M\"uller-Olm \<^cite>\<open>"BerghammerM03"\<close>.
In particular the approximation ratio is improved from \<open>\<Delta>+1\<close> to \<open>\<Delta>\<close>.\<close>

subsection "Graph"

text \<open>A set set is simply a set of edges, where an edge is a 2-element set.\<close>

definition independent_vertices :: "'a set set \<Rightarrow> 'a set \<Rightarrow> bool" where
"independent_vertices E S \<longleftrightarrow> S \<subseteq> \<Union>E \<and> (\<forall>v1 v2. v1 \<in> S \<and> v2 \<in> S \<longrightarrow> {v1, v2} \<notin> E)"

locale Graph_E =
  fixes E :: "'a set set"
  assumes finite_E: "finite E"
  assumes edges2: "e \<in> E \<Longrightarrow> card e = 2"
begin

fun vertices :: "'a set set \<Rightarrow> 'a set" where
"vertices G = \<Union>G"

abbreviation V :: "'a set" where
"V \<equiv> vertices E"

definition approximation_miv :: "nat \<Rightarrow> 'a set \<Rightarrow> bool" where
"approximation_miv n S \<longleftrightarrow> independent_vertices E S \<and> (\<forall>S'. independent_vertices E S' \<longrightarrow> card S' \<le> card S * n)"

fun neighbors :: "'a \<Rightarrow> 'a set" where
"neighbors v = {u. {u,v} \<in> E}"

fun degree_vertex :: "'a \<Rightarrow> nat" where
"degree_vertex v = card (neighbors v)"

abbreviation \<Delta> :: nat where
"\<Delta> \<equiv> Max{degree_vertex u|u. u \<in> V}"

lemma finite_edges: "e \<in> E \<Longrightarrow> finite e"
  using card_ge_0_finite and edges2 by force

lemma finite_V: "finite V"
  using finite_edges and finite_E by auto

lemma finite_neighbors: "finite (neighbors u)"
  using finite_V and rev_finite_subset [of V "neighbors u"] by auto

lemma independent_vertices_finite: "independent_vertices E S \<Longrightarrow> finite S"
  by (metis rev_finite_subset independent_vertices_def vertices.simps finite_V)

lemma edge_ex_vertices: "e \<in> E \<Longrightarrow> \<exists>u v. u \<noteq> v \<and> e = {u, v}"
proof -
  assume "e \<in> E"
  then have "card e = Suc (Suc 0)" using edges2 by auto
  then show "\<exists>u v. u \<noteq> v \<and> e = {u, v}"
    by (metis card_eq_SucD insertI1)
qed

lemma \<Delta>_pos [simp]: "E = {} \<or> 0 < \<Delta>"
proof cases
  assume "E = {}"
  then show "E = {} \<or> 0 < \<Delta>" by auto
next
  assume 1: "E \<noteq> {}"
  then have "V \<noteq> {}" using edges2 by fastforce
  moreover have "finite {degree_vertex u |u. u \<in> V}"
    by (metis finite_V finite_imageI Setcompr_eq_image)
  ultimately have 2: "\<Delta> \<in> {degree_vertex u |u. u \<in> V}" using Max_in by auto
  have "\<Delta> \<noteq> 0"
  proof
    assume "\<Delta> = 0"
    with 2 obtain u where 3: "u \<in> V" and 4: "degree_vertex u = 0" by auto
    from 3 obtain e where 5: "e \<in> E" and "u \<in> e" by auto
    moreover with 4 have "\<forall>v. {u, v} \<noteq> e" using finite_neighbors insert_absorb by fastforce
    ultimately show False using edge_ex_vertices by auto
  qed
  then show "E = {} \<or> 0 < \<Delta>" by auto
qed

lemma \<Delta>_max_degree: "u \<in> V \<Longrightarrow> degree_vertex u \<le> \<Delta>"
proof -
  assume H: "u \<in> V"
  have "finite {degree_vertex u |u. u \<in> V}"
    by (metis finite_V finite_imageI Setcompr_eq_image)
  with H show "degree_vertex u \<le> \<Delta>" using Max_ge by auto
qed

subsection \<open>Wei's algorithm: \<open>(\<Delta>+1)\<close>-approximation\<close>

text \<open>The 'functional' part of the invariant, used to prove that the algorithm produces an independent set of vertices.\<close>

definition inv_iv :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
"inv_iv S X \<longleftrightarrow> independent_vertices E S
            \<and> X \<subseteq> V
            \<and> (\<forall>v1 \<in> (V - X). \<forall>v2 \<in> S. {v1, v2} \<notin> E)
            \<and> S \<subseteq> X"

text \<open>Strenghten the invariant with an approximation ratio \<open>r\<close>:\<close>

definition inv_approx :: "'a set \<Rightarrow> 'a set \<Rightarrow> nat \<Rightarrow> bool" where
"inv_approx S X r \<longleftrightarrow> inv_iv S X \<and> card X \<le> card S * r"

text \<open>Preservation of the functional invariant:\<close>

lemma inv_preserv:
  fixes S :: "'a set"
    and X :: "'a set"
    and x :: "'a"
  assumes inv: "inv_iv S X"
      and x_def: "x \<in> V - X"
    shows "inv_iv (insert x S) (X \<union> neighbors x \<union> {x})"
proof -
  have inv1: "independent_vertices E S"
   and inv2: "X \<subseteq> V"
   and inv3: "S \<subseteq> X"
   and inv4: "\<forall>v1 v2. v1 \<in> (V - X) \<and> v2 \<in> S \<longrightarrow> {v1, v2} \<notin> E"
    using inv unfolding inv_iv_def by auto
  have finite_S: "finite S" using inv1 and independent_vertices_finite by auto
  have S1: "\<forall>y \<in> S. {x, y} \<notin> E" using inv4 and x_def by blast
  have S2: "\<forall>x \<in> S. \<forall>y \<in> S. {x, y} \<notin> E" using inv1 unfolding independent_vertices_def by metis
  have S3: "v1 \<in> insert x S \<Longrightarrow> v2 \<in> insert x S \<Longrightarrow> {v1, v2} \<notin> E" for v1 v2
    proof -
      assume "v1 \<in> insert x S" and "v2 \<in> insert x S"
      then consider
          (a) "v1 = x" and "v2 = x"
        | (b) "v1 = x" and "v2 \<in> S"
        | (c) "v1 \<in> S" and "v2 = x"
        | (d) "v1 \<in> S" and "v2 \<in> S"
        by auto
      then show "{v1, v2} \<notin> E"
      proof cases
        case a then show ?thesis using edges2 by force
      next
        case b then show ?thesis using S1 by auto
      next
        case c then show ?thesis using S1 by (metis doubleton_eq_iff)
      next
        case d then show ?thesis using S2 by auto
      qed
    qed
  (* invariant conjunct 1 *)
  have "independent_vertices E (insert x S)"
    using S3 and inv1 and x_def unfolding independent_vertices_def by auto
  (* invariant conjunct 2 *)
  moreover have "X \<union> neighbors x \<union> {x} \<subseteq> V"
  proof
    fix xa
    assume "xa \<in> X \<union> neighbors x \<union> {x}"
    then consider (a) "xa \<in> X" | (b) "xa \<in> neighbors x" | (c) "xa = x" by auto
    then show "xa \<in> V"
    proof cases
      case a
      then show ?thesis using inv2 by blast
    next
      case b
      then show ?thesis by auto
    next
      case c
      then show ?thesis using x_def by blast
    qed
  qed
  (* invariant conjunct 3 *)
  moreover have "insert x S \<subseteq> X \<union> neighbors x \<union> {x}" using inv3 by auto
  (* invariant conjunct 4 *)
  moreover have "v1 \<in> V - (X \<union> neighbors x \<union> {x}) \<Longrightarrow> v2 \<in> insert x S \<Longrightarrow> {v1, v2} \<notin> E" for v1 v2
  proof -
    assume H: "v1 \<in> V - (X \<union> neighbors x \<union> {x})" and "v2 \<in> insert x S"
    then consider (a) "v2 = x" | (b) "v2 \<in> S" by auto
    then show "{v1, v2} \<notin> E"
    proof cases
      case a
      with H have "v1 \<notin> neighbors v2" by blast
      then show ?thesis by auto
    next
      case b
      from H have "v1 \<in> V - X" by blast
      with b and inv4 show ?thesis by blast
    qed
  qed
  (* conclusion *)
  ultimately show "inv_iv (insert x S) (X \<union> neighbors x \<union> {x})" unfolding inv_iv_def by blast
qed

lemma inv_approx_preserv:
  assumes inv: "inv_approx S X (\<Delta> + 1)"
      and x_def: "x \<in> V - X"
    shows "inv_approx (insert x S) (X \<union> neighbors x \<union> {x}) (\<Delta> + 1)"
proof -
  have finite_S: "finite S" using inv and independent_vertices_finite
    unfolding inv_approx_def inv_iv_def by auto
  have Sx: "x \<notin> S" using inv and x_def unfolding inv_approx_def inv_iv_def by blast
  (* main invariant is preserved *)
  from inv have "inv_iv S X" unfolding inv_approx_def by auto
  with x_def have "inv_iv (insert x S) (X \<union> neighbors x \<union> {x})"
  proof (intro inv_preserv, auto) qed
  (* the approximation ratio is preserved (at most \<Delta>+1 vertices are removed in any iteration) *)
  moreover have "card (X \<union> neighbors x \<union> {x}) \<le> card (insert x S) * (\<Delta> + 1)"
  proof -
    have "degree_vertex x \<le> \<Delta>" using \<Delta>_max_degree and x_def by auto
    then have "card (neighbors x \<union> {x}) \<le> \<Delta> + 1" using card_Un_le [of "neighbors x" "{x}"] by auto
    then have "card (X \<union> neighbors x \<union> {x}) \<le> card X + \<Delta> + 1" using card_Un_le [of X "neighbors x \<union> {x}"] by auto
    also have "... \<le> card S * (\<Delta> + 1) + \<Delta> + 1" using inv unfolding inv_approx_def by auto
    also have "... = card (insert x S) * (\<Delta> + 1)" using finite_S and Sx by auto
    finally show ?thesis .
  qed
  (* conclusion *)
  ultimately show "inv_approx (insert x S) (X \<union> neighbors x \<union> {x}) (\<Delta> + 1)"
    unfolding inv_approx_def by auto
qed

(* the antecedent combines inv_approx (for an arbitrary ratio r) and the negated post-condition *)
lemma inv_approx: "independent_vertices E S \<Longrightarrow> card V \<le> card S * r \<Longrightarrow> approximation_miv r S"
proof -
  assume 1: "independent_vertices E S" and 2: "card V \<le> card S * r"
  have "independent_vertices E S' \<Longrightarrow> card S' \<le> card S * r" for S'
  proof -
    assume  "independent_vertices E S'"
    then have "S' \<subseteq> V" unfolding independent_vertices_def by auto
    then have "card S' \<le> card V" using finite_V and card_mono by auto
    also have "... \<le> card S * r" using 2 by auto
    finally show "card S' \<le> card S * r" .
  qed
  with 1 show "approximation_miv r S" unfolding approximation_miv_def by auto
qed

theorem wei_approx_\<Delta>_plus_1:
"VARS (S :: 'a set) (X :: 'a set) (x :: 'a)
  { True }
  S := {};
  X := {};
  WHILE X \<noteq> V
  INV { inv_approx S X (\<Delta> + 1) }
  DO x := (SOME x. x \<in> V - X);
     S := insert x S;
     X := X \<union> neighbors x \<union> {x}
  OD
  { approximation_miv (\<Delta> + 1) S }"
proof (vcg, goal_cases)
  case (1 S X x) (* invariant initially true *)
  then show ?case unfolding inv_approx_def inv_iv_def independent_vertices_def by auto
next
  case (2 S X x) (* invariant preserved by loop *)
  (* definedness of assignment *)
  let ?x = "(SOME x. x \<in> V - X)"
  have "V - X \<noteq> {}" using 2 unfolding inv_approx_def inv_iv_def by blast
  then have "?x \<in> V - X" using some_in_eq by metis
  with 2 show ?case using inv_approx_preserv by auto
next
  case (3 S X x) (* invariant implies post-condition *)
  then show ?case using inv_approx unfolding inv_approx_def inv_iv_def by auto
qed

subsection \<open>Wei's algorithm: \<open>\<Delta>\<close>-approximation\<close>

text \<open>The previous approximation uses very little information about the optimal solution (it has at most as many vertices as the set itself). With some extra effort we can improve the ratio to \<open>\<Delta>\<close> instead of \<open>\<Delta>+1\<close>. In order to do that we must show that among the vertices removed in each iteration, at most \<open>\<Delta>\<close> could belong to an optimal solution. This requires carrying around a set \<open>P\<close> (via a ghost variable) which records the vertices deleted in each iteration.\<close>

definition inv_partition :: "'a set \<Rightarrow> 'a set \<Rightarrow> 'a set set \<Rightarrow> bool" where
"inv_partition S X P \<longleftrightarrow> inv_iv S X
                     \<and> \<Union>P = X
                     \<and> (\<forall>p \<in> P. \<exists>s \<in> V. p = {s} \<union> neighbors s)
                     \<and> card P = card S
                     \<and> finite P"

lemma inv_partition_preserv:
  assumes inv: "inv_partition S X P"
      and x_def: "x \<in> V - X"
    shows "inv_partition (insert x S) (X \<union> neighbors x \<union> {x}) (insert ({x} \<union> neighbors x) P)"
proof -
  have finite_S: "finite S" using inv and independent_vertices_finite
    unfolding inv_partition_def inv_iv_def by auto
  have Sx: "x \<notin> S" using inv and x_def unfolding inv_partition_def inv_iv_def by blast
  (* main invariant is preserved *)
  from inv have "inv_iv S X" unfolding inv_partition_def by auto
  with x_def have "inv_iv (insert x S) (X \<union> neighbors x \<union> {x})"
  proof (intro inv_preserv, auto) qed
  (* conjunct 1 *)
  moreover have "\<Union>(insert ({x} \<union> neighbors x) P) = X \<union> neighbors x \<union> {x}"
    using inv unfolding inv_partition_def by auto
  (* conjunct 2 *)
  moreover have "(\<forall>p\<in>insert ({x} \<union> neighbors x) P. \<exists>s \<in> V. p = {s} \<union> neighbors s)"
    using inv and x_def unfolding inv_partition_def by auto
  (* conjunct 3 *)
  moreover have "card (insert ({x} \<union> neighbors x) P) = card (insert x S)"
  proof -
    from x_def and inv have "x \<notin> \<Union>P" unfolding inv_partition_def by auto
    then have "{x} \<union> neighbors x \<notin> P" by auto
    then have "card (insert ({x} \<union> neighbors x) P) = card P + 1" using inv unfolding inv_partition_def by auto
    moreover have "card (insert x S) = card S + 1" using Sx and finite_S by auto
    ultimately show ?thesis using inv unfolding inv_partition_def by auto
  qed
  (* conjunct 4 *)
  moreover have "finite (insert ({x} \<union> neighbors x) P)"
    using inv unfolding inv_partition_def by auto
  (* conclusion *)
  ultimately show "inv_partition (insert x S) (X \<union> neighbors x \<union> {x}) (insert ({x} \<union> neighbors x) P)"
    unfolding inv_partition_def by auto
qed

lemma card_Union_le_sum_card:
  fixes U :: "'a set set"
  assumes "\<forall>u \<in> U. finite u"
  shows "card (\<Union>U) \<le> sum card U"
proof (cases "finite U")
  case False
  then show "card (\<Union>U) \<le> sum card U"
    using card_eq_0_iff finite_UnionD by auto
next
  case True
  then show "card (\<Union>U) \<le> sum card U"
  proof (induct U rule: finite_induct)
    case empty
    then show ?case by auto
  next
    case (insert x F)
    then have "card(\<Union>(insert x F)) \<le> card(x) + card (\<Union>F)" using card_Un_le by auto
    also have "... \<le> card(x) + sum card F" using insert.hyps by auto
    also have "... = sum card (insert x F)" using sum.insert_if and insert.hyps by auto
    finally show ?case .
  qed
qed

(* this lemma could be more generally about U :: "nat set", but this makes its application more difficult later *)
lemma sum_card:
  fixes U :: "'a set set"
    and n :: nat
  assumes "\<forall>S \<in> U. card S \<le> n"
  shows "sum card U \<le> card U * n"
proof cases
  assume "infinite U \<or> U = {}"
  then have "sum card U = 0" using sum.infinite by auto
  then show "sum card U \<le> card U * n" by auto
next
  assume "\<not>(infinite U \<or> U = {})"
  with assms have "finite U" and "U \<noteq> {}"and "\<forall>S \<in> U. card S \<le> n" by auto
  then show "sum card U \<le> card U * n"
  proof (induct U rule: finite_ne_induct)
    case (singleton x)
    then show ?case by auto
  next
    case (insert x F)
    assume "\<forall>S\<in>insert x F. card S \<le> n"
    then have 1:"card x \<le> n" and 2:"sum card F \<le> card F * n" using insert.hyps by auto
    then have "sum card (insert x F) = card x + sum card F" using sum.insert_if and insert.hyps by auto
    also have "... \<le> n + card F * n" using 1 and 2 by auto
    also have "... = card (insert x F) * n" using card_insert_if and insert.hyps by auto
    finally show ?case .
  qed
qed

(* among the vertices deleted in each iteration, at most \<Delta> can belong to an independent set of
   vertices: the chosen vertex or (some of) its neighbors *)
lemma x_or_neighbors:
  fixes P :: "'a set set"
    and S :: "'a set"
  assumes inv: "\<forall>p\<in>P. \<exists>s \<in> V. p = {s} \<union> neighbors s"
      and ivS: "independent_vertices E S"
    shows "\<forall>p \<in> P. card (S \<inter> p) \<le> \<Delta>"
proof
  fix p
  assume "p \<in> P"
  then obtain s where 1: "s \<in> V \<and> p = {s} \<union> neighbors s" using inv by blast
  then show "card (S \<inter> p) \<le> \<Delta>"
  proof cases
    assume "s \<in> S"
    then have "S \<inter> neighbors s = {}" using ivS unfolding independent_vertices_def by auto
    then have "S \<inter> p \<subseteq> {s}" using 1 by auto
    then have 2: "card (S \<inter> p) \<le> 1" using subset_singletonD by fastforce
    consider (a) "E = {}" | (b) "0 < \<Delta>" using \<Delta>_pos by auto
    then show "card (S \<inter> p) \<le> \<Delta>"
    proof cases
      case a
      then have "S = {}" using ivS unfolding independent_vertices_def by auto
      then show ?thesis by auto
    next
      case b
      then show ?thesis using 2 by auto
    qed
  next
    assume "s \<notin> S"
    with 1 have "S \<inter> p \<subseteq> neighbors s" by auto
    then have "card (S \<inter> p) \<le> degree_vertex s" using card_mono and finite_neighbors by auto
    then show "card (S \<inter> p) \<le> \<Delta>" using 1 and \<Delta>_max_degree [of s] by auto
  qed
qed

(* the premise combines the invariant and the negated post-condition *)
lemma inv_partition_approx: "inv_partition S V P \<Longrightarrow> approximation_miv \<Delta> S"
proof -
  assume H1: "inv_partition S V P"
  then have "independent_vertices E S" unfolding inv_partition_def inv_iv_def by auto
  moreover have "independent_vertices E S' \<Longrightarrow> card S' \<le> card S * \<Delta>" for S'
  proof -
    let ?I = "{S' \<inter> p | p. p \<in> P}"
    (* split the optimal solution among the sets of P, which cover V so no element is
       lost. We obtain a cover of S' and show the required bound on its cardinality *)
    assume H2: "independent_vertices E S'"
    then have "S' \<subseteq> V" unfolding independent_vertices_def using vertices.simps by blast
    with H1 have "S' = S' \<inter> \<Union>P" unfolding inv_partition_def by auto
    then have "S' = (\<Union>p \<in> P. S' \<inter> p)" using Int_Union by auto
    then have "S' = \<Union>?I" by blast
    moreover have "finite S'" using H2 and independent_vertices_finite by auto
    then have "p \<in> P \<Longrightarrow> finite (S' \<inter> p)" for p by auto
    ultimately have "card S' \<le> sum card ?I" using card_Union_le_sum_card [of ?I] by auto
    also have "... \<le> card ?I * \<Delta>"
      using x_or_neighbors [of P S']
        and sum_card [of ?I \<Delta>]
        and H1 and H2 unfolding inv_partition_def by auto
    also have "... \<le> card P * \<Delta>"
    proof -
      have "finite P" using H1 unfolding inv_partition_def by auto
      then have "card ?I \<le> card P"
        using Setcompr_eq_image [of "\<lambda>p. S' \<inter> p" P]
          and card_image_le unfolding inv_partition_def by auto
      then show ?thesis by auto
    qed
    also have "... = card S * \<Delta>" using H1 unfolding inv_partition_def by auto
    ultimately show "card S' \<le> card S * \<Delta>" by auto
  qed
  ultimately show "approximation_miv \<Delta> S" unfolding approximation_miv_def by auto
qed

theorem wei_approx_\<Delta>:
"VARS (S :: 'a set) (X :: 'a set) (x :: 'a)
  { True }
  S := {};
  X := {};
  WHILE X \<noteq> V
  INV { \<exists>P. inv_partition S X P }
  DO x := (SOME x. x \<in> V - X);
     S := insert x S;
     X := X \<union> neighbors x \<union> {x}
  OD
  { approximation_miv \<Delta> S }"
proof (vcg, goal_cases)
  case (1 S X x) (* invariant initially true *)
  (* the invariant is initially true with the ghost variable P := {} *)
  have "inv_partition {} {} {}" unfolding inv_partition_def inv_iv_def independent_vertices_def by auto
  then show ?case by auto
next
  case (2 S X x) (* invariant preserved by loop *)
  (* definedness of assignment *)
  let ?x = "(SOME x. x \<in> V - X)"
  from 2 obtain P where I: "inv_partition S X P" by auto
  then have "V - X \<noteq> {}" using 2 unfolding inv_partition_def by auto
  then have "?x \<in> V - X" using some_in_eq by metis
  (* show that the invariant is true with the ghost variable P := insert ({?x} \<union> neighbors ?x) P *)
  with I have "inv_partition (insert ?x S) (X \<union> neighbors ?x \<union> {?x}) (insert ({?x} \<union> neighbors ?x) P)"
    using inv_partition_preserv by blast
  then show ?case by auto
next
  case (3 S X x) (* invariant implies post-condition *)
  then show ?case using inv_partition_approx unfolding inv_approx_def by auto
qed

subsection "Wei's algorithm with dynamically computed approximation ratio"

text \<open>In this subsection, we augment the algorithm with a variable used to compute the effective approximation ratio of the solution. In addition, the vertex of smallest degree is picked. With this heuristic, the algorithm achieves an approximation ratio of \<open>(\<Delta>+2)/3\<close>, but this is not proved here.\<close>

definition vertex_heuristic :: "'a set \<Rightarrow> 'a \<Rightarrow> bool" where
"vertex_heuristic X v = (\<forall>u \<in> V - X. card (neighbors v - X) \<le> card (neighbors u - X))"

(* this lemma is needed to show that there exist a vertex to be picked by the heuristic *)
lemma ex_min_finite_set:
  fixes S :: "'a set"
    and f :: "'a \<Rightarrow> nat"
    shows "finite S \<Longrightarrow> S \<noteq> {} \<Longrightarrow> \<exists>x. x \<in> S \<and> (\<forall>y \<in> S. f x \<le> f y)"
          (is "?P1 \<Longrightarrow> ?P2 \<Longrightarrow> \<exists>x. ?minf S x")
proof (induct S rule: finite_ne_induct)
  case (singleton x)
  have "?minf {x} x" by auto
  then show ?case by auto
next
  case (insert x F)
  from insert(4) obtain y where Py: "?minf F y" by auto
  show "\<exists>z. ?minf (insert x F) z"
  proof cases
    assume "f x < f y"
    then have "?minf (insert x F) x" using Py by auto
    then show ?case by auto
  next
    assume "\<not>f x < f y"
    then have "?minf (insert x F) y" using Py by auto
    then show ?case by auto
  qed
qed

lemma inv_approx_preserv2:
  fixes S :: "'a set"
    and X :: "'a set"
    and s :: nat
    and x :: "'a"
  assumes inv: "inv_approx S X s"
      and x_def: "x \<in> V - X"
    shows "inv_approx (insert x S) (X \<union> neighbors x \<union> {x}) (max (card (neighbors x \<union> {x} - X)) s)"
proof -
  have finite_S: "finite S" using inv and independent_vertices_finite unfolding inv_approx_def inv_iv_def by auto
  have Sx: "x \<notin> S" using inv and x_def unfolding inv_approx_def inv_iv_def by blast
  (* main invariant is preserved *)
  from inv have "inv_iv S X" unfolding inv_approx_def by auto
  with x_def have "inv_iv (insert x S) (X \<union> neighbors x \<union> {x})"
  proof (intro inv_preserv, auto) qed
  (* the approximation ratio is preserved *)
  moreover have "card (X \<union> neighbors x \<union> {x}) \<le> card (insert x S) * max (card (neighbors x \<union> {x} - X)) s"
  proof -
    let ?N = "neighbors x \<union> {x} - X"
    have "card (X \<union> ?N) \<le> card X + card ?N" using card_Un_le [of X ?N] by auto
    also have "... \<le> card S * s + card ?N" using inv unfolding inv_approx_def by auto
    also have "... \<le> card S * max (card ?N) s + card ?N" by auto
    also have "... \<le> card S * max (card ?N) s + max (card ?N) s" by auto
    also have "... = card (insert x S) * max (card ?N) s" using Sx and finite_S by auto
    finally show ?thesis by auto
  qed
  (* conclusion *)
  ultimately show "inv_approx (insert x S) (X \<union> neighbors x \<union> {x}) (max (card (neighbors x \<union> {x} - X)) s)"
    unfolding inv_approx_def by auto
qed

theorem wei_approx_min_degree_heuristic:
"VARS (S :: 'a set) (X :: 'a set) (x :: 'a) (r :: nat)
  { True }
  S := {};
  X := {};
  r := 0;
  WHILE X \<noteq> V
  INV { inv_approx S X r }
  DO x := (SOME x. x \<in> V - X \<and> vertex_heuristic X x);
     S := insert x S;
     r := max (card (neighbors x \<union> {x} - X)) r;
     X := X \<union> neighbors x \<union> {x}
  OD
  { approximation_miv r S }"
proof (vcg, goal_cases)
  case (1 S X x r) (* invariant initially true *)
  then show ?case unfolding inv_approx_def inv_iv_def independent_vertices_def by auto
next
  case (2 S X x r) (* invariant preserved by loop *)
  (* definedness of assignment *)
  let ?x = "(SOME x. x \<in> V - X \<and> vertex_heuristic X x)"
  have "V - X \<noteq> {}" using 2 unfolding inv_approx_def inv_iv_def by blast
  moreover have "finite (V - X)" using 2 and finite_V by auto
  ultimately have "\<exists>x. x \<in> V - X \<and> vertex_heuristic X x"
    using ex_min_finite_set [where ?f = "\<lambda>x. card (neighbors x - X)"]
    unfolding vertex_heuristic_def by auto
  then have x_def: "?x \<in> V - X \<and> vertex_heuristic X ?x"
    using someI_ex [where ?P = "\<lambda>x. x \<in> V - X \<and> vertex_heuristic X x"] by auto
  with 2 show ?case using inv_approx_preserv2 by auto
next
  case (3 S X x r)
  then show ?case using inv_approx unfolding inv_approx_def inv_iv_def by auto
qed

end
end


(* Title: Linear_Bound_Argument.thy
   Author: Chelsea Edmonds
*)
section \<open>Linear Bound Argument - General \<close>
text \<open>Lemmas to enable general reasoning using the linear bound argument for combinatorial proofs.
Jukna \<^cite>\<open>"juknaExtremalCombinatorics2011"\<close> presents a good overview of the mathematical background
this theory is based on and applications \<close>
theory Linear_Bound_Argument imports Incidence_Matrices Jordan_Normal_Form.DL_Rank
Jordan_Normal_Form.Ring_Hom_Matrix
begin

subsection \<open>Vec Space Extensions\<close>
text \<open>Simple extensions to the existing vector space locale on linear independence \<close>
context vec_space
begin
lemma lin_indpt_set_card_lt_dim:
  fixes A :: "'a vec set"
  assumes "A \<subseteq> carrier_vec n"
  assumes "lin_indpt A"
  shows "card A \<le> dim"
  using assms(1) assms(2) fin_dim li_le_dim(2) by blast

lemma lin_indpt_dim_col_lt_dim:
  fixes A :: "'a mat"
  assumes "A \<in> carrier_mat n nc"
  assumes "distinct (cols A)"
  assumes "lin_indpt (set (cols A))"
  shows "nc \<le> dim"
proof -
  have b: "card (set (cols A)) = dim_col A" using cols_length assms(2)
    by (simp add: distinct_card)
  have "set (cols A) \<subseteq> carrier_vec n" using assms(1) cols_dim by blast
  thus ?thesis using lin_indpt_set_card_lt_dim assms b by auto
qed

lemma lin_comb_imp_lin_dep_fin:
  fixes A :: "'a vec set"
  assumes "finite A"
  assumes "A \<subseteq> carrier_vec n"
  assumes "lincomb c A = 0\<^sub>v n"
  assumes "\<exists> a. a \<in> A \<and> c a \<noteq> 0"
  shows "lin_dep A"
  unfolding lin_dep_def using assms lincomb_as_lincomb_list_distinct sumlist_nth by auto

text \<open>While a trivial definition, this enables us to directly reference the definition outside
of a locale context, as @{term "lin_indpt"} is an inherited definition \<close>
definition lin_indpt_vs:: "'a vec set \<Rightarrow> bool" where
"lin_indpt_vs A \<longleftrightarrow> lin_indpt A"

lemma lin_comb_sum_lin_indpt:
  fixes A :: "'a vec list"
  assumes "set (A) \<subseteq> carrier_vec n"
  assumes "distinct A"
  assumes "\<And> f. lincomb_list (\<lambda>i. f (A ! i)) A = 0\<^sub>v n \<Longrightarrow> \<forall>v\<in> (set A). f v = 0"
  shows "lin_indpt (set A)"
  by (rule finite_lin_indpt2, auto simp add: assms lincomb_as_lincomb_list_distinct)

lemma lin_comb_mat_lin_indpt:
  fixes A :: "'a vec list"
  assumes "set (A) \<subseteq> carrier_vec n"
  assumes "distinct A"
  assumes "\<And> f. mat_of_cols n A *\<^sub>v vec (length A) (\<lambda>i. f (A ! i))  = 0\<^sub>v n \<Longrightarrow> \<forall>v\<in> (set A). f v = 0"
  shows "lin_indpt (set A)"
proof (rule lin_comb_sum_lin_indpt, auto simp add: assms)
  fix f v
  have "\<And> v. v \<in> set A \<Longrightarrow> dim_vec v = n"
    using assms by auto
  then show "lincomb_list (\<lambda>i. f (A ! i)) A = 0\<^sub>v n \<Longrightarrow> v \<in> set A \<Longrightarrow> f v = 0"
    using  lincomb_list_as_mat_mult[of A "(\<lambda>i. f (A ! i))"] assms(3)[of f] by auto
qed

lemma lin_comb_mat_lin_indpt_vs:
  fixes A :: "'a vec list"
  assumes "set (A) \<subseteq> carrier_vec n"
  assumes "distinct A"
  assumes "\<And> f. mat_of_cols n A *\<^sub>v vec (length A) (\<lambda>i. f (A ! i))  = 0\<^sub>v n \<Longrightarrow> \<forall>v\<in> (set A). f v = 0"
  shows "lin_indpt_vs (set A)"
  using lin_comb_mat_lin_indpt lin_indpt_vs_def assms by auto

end

subsection \<open>Linear Bound Argument Lemmas\<close>

text \<open>Three general representations of the linear bound argument, requiring a direct fact of
linear independence onthe rows of the vector space over either a set A of vectors, list xs of vectors
or a Matrix' columns \<close>
lemma lin_bound_arg_general_set:
  fixes A ::"('a :: {field})vec set"
  assumes "A \<subseteq> carrier_vec nr"
  assumes "vec_space.lin_indpt_vs nr A"
  shows "card A \<le> nr"
  using vec_space.lin_indpt_set_card_lt_dim[of "A" "nr"] vec_space.lin_indpt_vs_def[of nr A]
    vec_space.dim_is_n assms by metis

lemma lin_bound_arg_general_list:
  fixes xs ::"('a :: {field})vec list"
  assumes "distinct xs"
  assumes "(set xs) \<subseteq> carrier_vec nr"
  assumes "vec_space.lin_indpt_vs nr (set xs)"
  shows "length (xs) \<le> nr"
  using lin_bound_arg_general_set[of "set xs" nr] distinct_card assms
  by force

lemma lin_bound_arg_general:
  fixes A ::"('a :: {field}) mat"
  assumes "distinct (cols A)"
  assumes "A \<in> carrier_mat nr nc"
  assumes "vec_space.lin_indpt_vs nr (set (cols A))"
  shows "nc \<le> nr"
proof -
  have ss: "set (cols A) \<subseteq> carrier_vec nr" using assms cols_dim by blast
  have "length (cols A) = nc"
    using assms(2) cols_length by blast
  thus ?thesis using lin_bound_arg_general_list[of "cols A" "nr"] ss assms by simp
qed

text\<open>The linear bound argument lemma on a matrix requiring the lower level assumption on a linear
combination. This removes the need to directly refer to any aspect of the linear algebra libraries \<close>
lemma lin_bound_argument:
  fixes A :: "('a :: {field}) mat"
  assumes "distinct (cols A)"
  assumes "A \<in> carrier_mat nr nc"
  assumes "\<And> f. A *\<^sub>v vec nc (\<lambda>i. f (col A i)) = 0\<^sub>v nr \<Longrightarrow> \<forall>v\<in> (set (cols A)). f v = 0"
  shows "nc \<le> nr"
proof (intro lin_bound_arg_general[of "A" nr nc] vec_space.lin_comb_mat_lin_indpt_vs, simp_all add: assms)
  show "set (cols A) \<subseteq> carrier_vec nr" using assms cols_dim by blast
next
  have mA: "mat_of_cols nr (cols A) = A" using mat_of_cols_def assms by auto
  have "\<And> f. vec (dim_col A) (\<lambda>i. f (cols A ! i)) = vec nc (\<lambda>i. f (col A i))"
  proof (intro eq_vecI, simp_all add: assms)
    show "\<And>f i. i < nc \<Longrightarrow> vec (dim_col A) (\<lambda>i. f (cols A ! i)) $ i = f (col A i)"
      using assms(2) by force
    show "dim_col A = nc " using assms by simp
  qed
  then show "\<And>f. mat_of_cols nr (cols A) *\<^sub>v vec (dim_col A) (\<lambda>i. f (cols A ! i)) = 0\<^sub>v nr \<Longrightarrow>
      \<forall>v\<in>set (cols A). f v = 0"
    using mA assms(3) by metis
qed

text \<open>A further extension to present the linear combination directly as a sum. This manipulation from
vector product to a summation was found to commonly be repeated in proofs applying this rule \<close>
lemma lin_bound_argument2:
  fixes A :: "('a :: {field}) mat"
  assumes "distinct (cols A)"
  assumes "A \<in> carrier_mat nr nc"
  assumes "\<And> f. vec nr (\<lambda>i. \<Sum> j \<in> {0..<nc} . f (col A j) * (col A j) $ i) = 0\<^sub>v nr \<Longrightarrow>
    \<forall>v\<in> (set (cols A)). f v = 0"
  shows "nc \<le> nr"
proof (intro lin_bound_argument[of A nr nc], simp add: assms, simp add: assms)
  fix f
  have "A *\<^sub>v vec nc (\<lambda>i. f (col A i)) =
      vec (dim_row A) (\<lambda>i. \<Sum> j \<in> {0..<nc} . (row A i $ j) * f (col A j))"
    by (auto simp add: mult_mat_vec_def scalar_prod_def assms(2))
  also have "... = vec (dim_row A) (\<lambda>i. \<Sum> j \<in> {0..<nc} . f (col A j) * (col A j $ i))"
    using assms(2) by (intro eq_vecI, simp_all) (meson mult.commute)
  finally show "A *\<^sub>v vec nc (\<lambda>i. f (col A i)) = 0\<^sub>v nr \<Longrightarrow> \<forall>v\<in>set (cols A). f v = 0"
    using assms(3)[of f] assms(2) by fastforce
qed

end


(*
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>Vectors as Lists of Naturals\<close>

theory List_Vector
  imports Main
begin

(*TODO: move*)
lemma lex_lengthD: "(x, y) \<in> lex P \<Longrightarrow> length x = length y"
  by (auto simp: lexord_lex)

(*TODO: move*)
lemma lex_take_index:
  assumes "(xs, ys) \<in> lex r"
  obtains i where "length ys = length xs"
    and "i < length xs" and "take i xs = take i ys"
    and "(xs ! i, ys ! i) \<in> r"
proof -
  obtain n us x xs' y ys' where "(xs, ys) \<in> lexn r n" and "length xs = n" and "length ys = n"
    and "xs = us @ x # xs'" and "ys = us @ y # ys'" and "(x, y) \<in> r"
    using assms by (fastforce simp: lex_def lexn_conv)
  then show ?thesis by (intro that [of "length us"]) auto
qed

(*TODO: move*)
lemma mods_with_nats:
  assumes "(v::nat) > w"
    and "(v * b) mod a = (w * b) mod a"
  shows "((v - w) * b) mod a = 0"
  using assms by (simp add: mod_eq_dvd_iff_nat algebra_simps)

\<comment> \<open>The 0-vector of length \<open>n\<close>.\<close>
abbreviation zeroes :: "nat \<Rightarrow> nat list"
  where
    "zeroes n \<equiv> replicate n 0"

lemma rep_upd_unit:
  assumes "x = (zeroes n)[i := a]"
  shows "\<forall>j < length x. (j \<noteq> i \<longrightarrow> x ! j = 0) \<and> (j = i \<longrightarrow> x ! j = a)"
  using assms by simp

definition nonzero_iff: "nonzero xs \<longleftrightarrow> (\<exists>x\<in>set xs. x \<noteq> 0)"

lemma nonzero_append [simp]:
  "nonzero (xs @ ys) \<longleftrightarrow> nonzero xs \<or> nonzero ys" by (auto simp: nonzero_iff)

subsection \<open>The Inner Product\<close>

definition dotprod :: "nat list \<Rightarrow> nat list \<Rightarrow> nat" (infixl "\<bullet>" 70)
  where
    "xs \<bullet> ys = (\<Sum>i<min (length xs) (length ys). xs ! i * ys ! i)"

lemma dotprod_code [code]:
  "xs \<bullet> ys = sum_list (map (\<lambda>(x, y). x * y) (zip xs ys))"
  by (auto simp: dotprod_def sum_list_sum_nth lessThan_atLeast0)

lemma dotprod_commute:
  assumes "length xs = length ys"
  shows "xs \<bullet> ys = ys \<bullet> xs"
  using assms by (auto simp: dotprod_def mult.commute)

lemma dotprod_Nil [simp]: "[] \<bullet> [] = 0"
  by (simp add: dotprod_def)

lemma dotprod_1_right [simp]:
  "xs \<bullet> replicate (length xs) 1 = sum_list xs"
  by (induct xs) (simp_all)

lemma dotprod_0_right [simp]:
  "xs \<bullet> zeroes (length xs) = 0"
  by (induct xs) (simp_all)

lemma dotprod_unit [simp]:
  assumes "length a = n"
    and "k < n"
  shows "a \<bullet> (zeroes n)[k := zk] = a ! k * zk"
  using assms by (induct a arbitrary: k n) (auto split: nat.splits)

lemma dotprod_gt0:
  assumes "length x = length y" and "\<exists>i<length y. x ! i > 0 \<and> y ! i > 0"
  shows "x \<bullet> y > 0"
  using assms by (induct x y rule: list_induct2) (fastforce simp: nth_Cons split: nat.splits)+

lemma dotprod_gt0D:
  assumes "length x = length y"
    and "x \<bullet> y > 0"
  shows "\<exists>i<length y. x ! i > 0 \<and> y ! i > 0"
  using assms by (induct x y rule: list_induct2) (auto simp: Ex_less_Suc2)

lemma dotprod_gt0_iff [iff]:
  assumes "length x = length y"
  shows "x \<bullet> y > 0 \<longleftrightarrow> (\<exists>i<length y. x ! i > 0 \<and> y ! i > 0)"
  using assms and dotprod_gt0D and dotprod_gt0 by blast

lemma dotprod_append:
  assumes "length a = length b"
  shows"(a @ x) \<bullet> (b @ y) = a \<bullet> b + x \<bullet> y"
  using assms by (induct a b rule: list_induct2) auto

lemma dotprod_le_take:
  assumes "length a = length b"
    and "k \<le> length a"
  shows"take k a \<bullet> take k b \<le> a \<bullet> b"
  using assms and append_take_drop_id [of k a] and append_take_drop_id [of k b]
  by (metis add_right_cancel leI length_append length_drop not_add_less1 dotprod_append)

lemma dotprod_le_drop:
  assumes "length a = length b"
    and "k \<le> length a"
  shows "drop k a \<bullet> drop k b \<le> a \<bullet> b"
  using assms and append_take_drop_id [of k a] and append_take_drop_id [of k b]
  by (metis dotprod_append length_take order_refl trans_le_add2)

lemma dotprod_is_0 [simp]:
  assumes "length x = length y"
  shows "x \<bullet> y = 0 \<longleftrightarrow> (\<forall>i<length y. x ! i = 0 \<or> y ! i = 0)"
  using assms by (metis dotprod_gt0_iff neq0_conv)

lemma dotprod_eq_0_iff:
  assumes "length x = length a"
    and "0 \<notin> set a"
  shows "x \<bullet> a = 0 \<longleftrightarrow> (\<forall>e \<in> set x. e = 0)"
  using assms by (fastforce simp: in_set_conv_nth)

lemma dotprod_eq_nonzero_iff:
  assumes "a \<bullet> x = b \<bullet> y" and "length x = length a" and "length y = length b"
    and "0 \<notin> set a" and "0 \<notin> set b"
  shows "nonzero x \<longleftrightarrow> nonzero y"
  using assms by (auto simp: nonzero_iff) (metis dotprod_commute dotprod_eq_0_iff neq0_conv)+

lemma eq_0_iff:
  "xs = zeroes n \<longleftrightarrow> length xs = n \<and> (\<forall>x\<in>set xs. x = 0)"
  using in_set_replicate [of _ n 0] and replicate_eqI [of xs n 0] by auto

lemma not_nonzero_iff: "\<not> nonzero x \<longleftrightarrow> x = zeroes (length x)"
  by (auto simp: nonzero_iff replicate_length_same eq_0_iff)

lemma neq_0_iff':
  "xs \<noteq> zeroes n \<longleftrightarrow> length xs \<noteq> n \<or> (\<exists>x\<in>set xs. x > 0)"
  by (auto simp: eq_0_iff)

lemma dotprod_pointwise_le:
  assumes "length as = length xs"
    and "i < length as"
  shows "as ! i * xs ! i \<le> as \<bullet> xs"
proof -
  have "as \<bullet> xs = (\<Sum>i<min (length as) (length xs). as ! i * xs ! i)"
    by (simp add: dotprod_def)
  then show ?thesis
    using assms by (auto intro: member_le_sum)
qed

lemma replicate_dotprod:
  assumes "length y = n"
  shows "replicate n x \<bullet> y = x * sum_list y"
proof -
  have "x * (\<Sum>i<length y.  y ! i) = (\<Sum>i<length y. x * y ! i)"
    using sum_distrib_left by blast
  then show ?thesis
    using assms by (auto simp: dotprod_def sum_list_sum_nth atLeast0LessThan)
qed

subsection \<open>The Pointwise Order on Vectors\<close>

definition  less_eq :: "nat list \<Rightarrow> nat list \<Rightarrow> bool" ("_/ \<le>\<^sub>v _" [51, 51] 50)
  where
    "xs \<le>\<^sub>v ys \<longleftrightarrow> length xs = length ys \<and> (\<forall>i<length xs. xs ! i \<le> ys ! i)"

definition less :: "nat list \<Rightarrow> nat list \<Rightarrow> bool" ("_/ <\<^sub>v _" [51, 51] 50)
  where
    "xs <\<^sub>v ys \<longleftrightarrow> xs \<le>\<^sub>v ys \<and> \<not> ys \<le>\<^sub>v xs"

interpretation order_vec: order less_eq less
  by (standard, auto simp add: less_def less_eq_def dual_order.antisym nth_equalityI) (force)

lemma less_eqI [intro?]: "length xs = length ys \<Longrightarrow> \<forall>i<length xs. xs ! i \<le> ys ! i \<Longrightarrow> xs \<le>\<^sub>v ys"
  by (auto simp: less_eq_def)

lemma le0 [simp, intro]: "zeroes (length xs) \<le>\<^sub>v xs" by (simp add: less_eq_def)

lemma le_list_update [simp]:
  assumes "xs \<le>\<^sub>v ys" and "i < length ys" and "z \<le> ys ! i"
  shows "xs[i := z] \<le>\<^sub>v ys"
  using assms by (auto simp: less_eq_def nth_list_update)

lemma le_Cons: "x # xs \<le>\<^sub>v y # ys \<longleftrightarrow> x \<le> y \<and> xs \<le>\<^sub>v ys"
  by (auto simp add: less_eq_def nth_Cons split: nat.splits)

lemma zero_less:
  assumes "nonzero x"
  shows "zeroes (length x) <\<^sub>v x"
  using assms and eq_0_iff order_vec.dual_order.strict_iff_order
  by (auto simp: nonzero_iff)

lemma le_append:
  assumes "length xs = length vs"
  shows "xs @ ys \<le>\<^sub>v vs @ ws \<longleftrightarrow> xs \<le>\<^sub>v vs \<and> ys \<le>\<^sub>v ws"
  using assms
  by (auto simp: less_eq_def nth_append)
    (metis add.commute add_diff_cancel_left' nat_add_left_cancel_less not_add_less2)

lemma less_Cons:
  "(x # xs) <\<^sub>v (y # ys) \<longleftrightarrow> length xs = length ys \<and> (x \<le> y \<and> xs <\<^sub>v ys \<or> x < y \<and> xs \<le>\<^sub>v ys)"
  by (simp add: less_def less_eq_def All_less_Suc2) (auto dest: leD)

lemma le_length [dest]:
  assumes "xs \<le>\<^sub>v ys"
  shows "length xs = length ys"
  using assms by (simp add: less_eq_def)

lemma less_length [dest]:
  assumes "x <\<^sub>v y"
  shows "length x = length y"
  using assms by (auto simp: less_def)

lemma less_appendD:
  assumes "xs @ ys <\<^sub>v vs @ ws"
    and "length xs = length vs"
  shows "xs <\<^sub>v vs \<or> ys <\<^sub>v ws"
  by (auto) (metis (no_types, lifting) assms le_append order_vec.order.strict_iff_order)

lemma less_append_cases:
  assumes "xs @ ys <\<^sub>v vs @ ws" and "length xs = length vs"
  obtains "xs <\<^sub>v vs" and "ys \<le>\<^sub>v ws" | "xs \<le>\<^sub>v vs" and "ys <\<^sub>v ws"
  using assms and that
  by (metis le_append less_appendD order_vec.order.strict_implies_order)

lemma less_append_swap:
  assumes "x @ y <\<^sub>v u @ v"
    and "length x = length u"
  shows "y @ x <\<^sub>v v @ u"
  using assms(2, 1)
  by (induct x u rule: list_induct2)
    (auto simp: order_vec.order.strict_iff_order le_Cons le_append le_length)

lemma le_sum_list_less:
  assumes "xs \<le>\<^sub>v ys"
    and "sum_list xs < sum_list ys"
  shows "xs <\<^sub>v ys"
proof -
  have "length xs = length ys" and "\<forall>i<length ys. xs ! i \<le> ys ! i"
    using assms by (auto simp: less_eq_def)
  then show ?thesis
    using \<open>sum_list xs < sum_list ys\<close>
    by (induct xs ys rule: list_induct2)
      (auto simp: less_Cons All_less_Suc2 less_eq_def)
qed

lemma dotprod_le_right:
  assumes "v \<le>\<^sub>v w"
    and "length b = length w"
  shows "b \<bullet> v \<le> b \<bullet> w"
  using assms by (auto simp: dotprod_def less_eq_def intro: sum_mono)

lemma dotprod_pointwise_le_right:
  assumes "length z = length u"
    and "length u = length v"
    and "\<forall>i<length v. u ! i \<le> v ! i"
  shows "z \<bullet> u \<le> z \<bullet> v"
  using assms by (intro dotprod_le_right) (auto intro: less_eqI)

lemma dotprod_le_left:
  assumes "v \<le>\<^sub>v w"
    and "length b = length w"
  shows "v \<bullet> b \<le> w \<bullet> b "
  using assms by (simp add: dotprod_le_right dotprod_commute le_length)

lemma dotprod_le:
  assumes "x \<le>\<^sub>v u" and "y \<le>\<^sub>v v"
    and "length y = length x" and "length v = length u"
  shows "x \<bullet> y \<le> u \<bullet> v"
  using assms by (metis dotprod_le_left dotprod_le_right le_length le_trans)

lemma dotprod_less_left:
  assumes "length b = length w"
    and "0 \<notin> set b"
    and "v <\<^sub>v w"
  shows "v \<bullet> b < w \<bullet> b"
proof -
  have "length v = length w" using assms
    using less_eq_def order_vec.order.strict_implies_order by blast
  then show ?thesis
    using assms
  proof (induct v w arbitrary: b rule: list_induct2)
    case (Cons x xs y ys)
    then show ?case
      by (cases b) (auto simp: less_Cons add_mono_thms_linordered_field dotprod_le_left)
  qed simp
qed

lemma le_append_swap:
  assumes "length y = length v"
    and "x @ y \<le>\<^sub>v w @ v"
  shows "y @ x \<le>\<^sub>v v @ w"
proof -
  have "length w = length x" using assms by auto
  with assms show ?thesis
    by (induct y v arbitrary: x w rule: list_induct2) (auto simp: le_Cons le_append)
qed

lemma le_append_swap_iff:
  assumes "length y = length v"
  shows "y @ x \<le>\<^sub>v v @ w  \<longleftrightarrow> x @ y \<le>\<^sub>v w @ v"
  using assms and le_append_swap
  by (auto) (metis (no_types, lifting) add_left_imp_eq le_length length_append)

lemma unit_less:
  assumes "i < n"
    and "x <\<^sub>v (zeroes n)[i := b]"
  shows "x ! i < b \<and> (\<forall>j<n. j \<noteq> i \<longrightarrow> x ! j = 0)"
proof
  show "x ! i < b"
    using assms less_def by fastforce
next
  have "x \<le>\<^sub>v (zeroes n)[i := b]" by (simp add: assms order_vec.less_imp_le)
  then show "\<forall>j<n. j \<noteq> i \<longrightarrow> x ! j = 0" by (auto simp: less_eq_def)
qed

lemma le_sum_list_mono:
  assumes "xs \<le>\<^sub>v ys"
  shows "sum_list xs \<le> sum_list ys"
  using assms and sum_list_mono [of "[0..<length ys]" "(!) xs" "(!) ys"]
  by (auto simp: less_eq_def) (metis map_nth)

lemma sum_list_less_diff_Ex:
  assumes "u \<le>\<^sub>v y"
    and "sum_list u < sum_list y"
  shows "\<exists>i<length y. u ! i < y ! i"
proof -
  have "length u = length y" and "\<forall>i<length y. u ! i \<le> y ! i"
    using \<open>u \<le>\<^sub>v y\<close> by (auto simp: less_eq_def)
  then show ?thesis
    using \<open>sum_list u < sum_list y\<close>
    by (induct u y rule: list_induct2) (force simp: Ex_less_Suc2 All_less_Suc2)+
qed

lemma less_vec_sum_list_less:
  assumes "v <\<^sub>v w"
  shows "sum_list v < sum_list w"
  using assms
proof -
  have "length v = length w"
    using assms less_eq_def less_imp_le by blast
  then show ?thesis
    using assms
  proof (induct v w rule: list_induct2)
    case (Cons x xs y ys)
    then show ?case
      using length_replicate less_Cons order_vec.order.strict_iff_order by force
  qed simp
qed

definition maxne0 :: "nat list \<Rightarrow> nat list \<Rightarrow> nat"
  where
    "maxne0 x a =
      (if length x = length a \<and> (\<exists>i<length a. x ! i \<noteq> 0)
      then Max {a ! i | i. i < length a \<and> x ! i \<noteq> 0}
      else 0)"

lemma maxne0_le_Max:
  "maxne0 x a \<le> Max (set a)"
  by (auto simp: maxne0_def nonzero_iff in_set_conv_nth) simp

lemma maxne0_Nil [simp]:
  "maxne0 [] as = 0"
  "maxne0 xs [] = 0"
  by (auto simp: maxne0_def)

lemma maxne0_Cons [simp]:
  "maxne0 (x # xs) (a # as) =
    (if length xs = length as then
      (if x = 0 then maxne0 xs as else max a (maxne0 xs as))
    else 0)"
proof -
  let ?a = "a # as" and ?x = "x # xs"
  have eq: "{?a ! i | i. i < length ?a \<and> ?x ! i \<noteq> 0} =
    (if x > 0 then {a} else {}) \<union> {as ! i | i. i < length as \<and> xs ! i \<noteq> 0}"
    by (auto simp: nth_Cons split: nat.splits) (metis Suc_pred)+
  show ?thesis
    unfolding maxne0_def and eq
    by (auto simp: less_Suc_eq_0_disj nth_Cons' intro: Max_insert2)
qed

lemma maxne0_times_sum_list_gt_dotprod:
  assumes "length b = length ys"
  shows "maxne0 ys b * sum_list ys \<ge> b \<bullet> ys"
  using assms
  apply (induct b ys rule: list_induct2)
   apply (auto  simp: max_def ring_distribs add_mono_thms_linordered_semiring(1))
  by (meson leI le_trans mult_less_cancel2 nat_less_le)

lemma max_times_sum_list_gt_dotprod:
  assumes "length b = length ys"
  shows "Max (set b) * sum_list ys \<ge> b \<bullet> ys"
proof -
  have "\<forall> e \<in> set b . Max (set b) \<ge> e" by simp
  then have "replicate (length ys) (Max (set b)) \<bullet> ys \<ge> b \<bullet> ys" (is "?rep \<ge> _")
    by (metis assms dotprod_pointwise_le_right dotprod_commute
        length_replicate nth_mem nth_replicate)
  moreover have "Max (set b) * sum_list ys = ?rep"
    using replicate_dotprod [of ys _ "Max (set b)"] by auto
  ultimately show ?thesis
    by (simp add: assms)
qed

lemma maxne0_mono:
  assumes "y \<le>\<^sub>v x"
  shows "maxne0 y a \<le> maxne0 x a"
proof (cases "length y = length a")
  case True
  have "length y = length x" using assms by (auto)
  then show ?thesis
    using assms and True
  proof (induct y x arbitrary: a rule: list_induct2)
    case (Cons x xs y ys)
    then show ?case by (cases a) (force simp: less_eq_def All_less_Suc2 le_max_iff_disj)+
  qed simp
next
  case False
  then show ?thesis
    using assms by (auto simp: maxne0_def)
qed

lemma all_leq_Max:
  assumes "x \<le>\<^sub>v y"
    and "x \<noteq> []"
  shows "\<forall>xi \<in> set x. xi \<le> Max (set y)"
  by (metis (no_types, lifting) List.finite_set Max_ge_iff
      assms in_set_conv_nth length_0_conv less_eq_def set_empty)

lemma le_not_less_replicate:
  "\<forall>x\<in>set xs. x \<le> b \<Longrightarrow> \<not> xs <\<^sub>v replicate (length xs) b \<Longrightarrow> xs = replicate (length xs) b"
  by (induct xs) (auto simp: less_Cons)

lemma le_replicateI: "\<forall>x\<in>set xs. x \<le> b \<Longrightarrow> xs \<le>\<^sub>v replicate (length xs) b"
  by (induct xs) (auto simp: le_Cons)

lemma le_take:
  assumes "x \<le>\<^sub>v y" and "i \<le> length x" shows "take i x \<le>\<^sub>v take i y"
  using assms by (auto simp: less_eq_def)

lemma wf_less:
  "wf {(x, y). x <\<^sub>v y}"
proof -
  have "wf (measure sum_list)" ..
  moreover have "{(x, y). x <\<^sub>v y} \<subseteq> measure sum_list"
    by (auto simp: less_vec_sum_list_less)
  ultimately show "wf {(x, y). x <\<^sub>v y}"
    by (rule wf_subset)
qed

subsection \<open>Pointwise Subtraction\<close>

definition vdiff :: "nat list \<Rightarrow> nat list \<Rightarrow> nat list" (infixl "-\<^sub>v" 65)
  where
    "w -\<^sub>v v = map (\<lambda>i. w ! i - v ! i) [0 ..< length w]"

lemma vdiff_Nil [simp]: "[] -\<^sub>v [] = []" by (simp add: vdiff_def)

lemma upt_Cons_conv:
  assumes "j < n"
  shows "[j..<n] = j # [j+1..<n]"
  by (simp add: assms upt_eq_Cons_conv)

lemma map_upt_Suc: "map f [Suc m ..< Suc n] = map (f \<circ> Suc) [m ..< n]"
  by (fold list.map_comp [of f "Suc" "[m ..< n]"]) (simp add: map_Suc_upt)

lemma vdiff_Cons [simp]:
  "(x # xs) -\<^sub>v (y # ys) = (x - y) # (xs -\<^sub>v ys)"
  by (simp add: vdiff_def upt_Cons_conv [OF zero_less_Suc] map_upt_Suc del: upt_Suc)

lemma vdiff_alt_def:
  assumes "length w = length v"
  shows "w -\<^sub>v v = map (\<lambda>(x, y). x - y) (zip w v)"
  using assms by (induct rule: list_induct2) simp_all

lemma vdiff_dotprod_distr:
  assumes "length b = length w"
    and "v \<le>\<^sub>v w"
  shows "(w -\<^sub>v v) \<bullet> b = w \<bullet> b - v \<bullet> b"
proof -
  have "length v = length w" and "\<forall>i<length w. v ! i \<le> w ! i"
    using assms less_eq_def by auto
  then show ?thesis
    using \<open>length b = length w\<close>
  proof (induct v w arbitrary: b rule: list_induct2)
    case (Cons x xs y ys)
    then show ?case
      by (cases b) (auto simp: All_less_Suc2 diff_mult_distrib
          dotprod_commute dotprod_pointwise_le_right)
  qed simp
qed

lemma sum_list_vdiff_distr [simp]:
  assumes "v \<le>\<^sub>v u"
  shows "sum_list (u -\<^sub>v v) = sum_list u - sum_list v"
  by (metis (no_types, lifting) assms diff_zero dotprod_1_right
      length_map length_replicate length_upt
      less_eq_def vdiff_def vdiff_dotprod_distr)

lemma vdiff_le:
  assumes "v \<le>\<^sub>v w"
    and "length v = length x"
  shows "v -\<^sub>v x \<le>\<^sub>v w"
  using assms by (auto simp add: less_eq_def vdiff_def)

lemma mods_with_vec:
  assumes "v <\<^sub>v w"
    and "0 \<notin> set b"
    and "length b = length w"
    and "(v \<bullet> b) mod a = (w \<bullet> b) mod a"
  shows "((w -\<^sub>v v) \<bullet> b) mod a = 0"
proof -
  have *: "v \<bullet> b < w \<bullet> b"
    using dotprod_less_left and assms by blast
  have "v \<le>\<^sub>v w"
    using assms by auto
  from vdiff_dotprod_distr [OF assms(3) this]
  have "((w -\<^sub>v v) \<bullet> b) mod a = (w \<bullet> b - v \<bullet> b) mod a "
    by simp
  also have "... = 0 mod a"
    using mods_with_nats [of "v \<bullet> b" "w \<bullet> b" "1" a, OF *] assms by auto
  finally show ?thesis by simp
qed

lemma mods_with_vec_2:
  assumes "v <\<^sub>v w"
    and "0 \<notin> set b"
    and "length b = length w"
    and "(b \<bullet> v) mod a = (b \<bullet> w) mod a"
  shows "(b \<bullet> (w -\<^sub>v v)) mod a = 0"
  by (metis (no_types, lifting) assms diff_zero dotprod_commute
      length_map length_upt less_eq_def order_vec.less_imp_le
      mods_with_vec vdiff_def)

subsection \<open>The Lexicographic Order on Vectors\<close>

abbreviation lex_less_than ("_/ <\<^sub>l\<^sub>e\<^sub>x _" [51, 51] 50)
  where
    "xs <\<^sub>l\<^sub>e\<^sub>x ys \<equiv> (xs, ys) \<in> lex less_than"

definition rlex (infix "<\<^sub>r\<^sub>l\<^sub>e\<^sub>x" 50)
  where
    "xs <\<^sub>r\<^sub>l\<^sub>e\<^sub>x ys \<longleftrightarrow> rev xs <\<^sub>l\<^sub>e\<^sub>x rev ys"

lemma rev_le [simp]:
  "rev xs \<le>\<^sub>v rev ys \<longleftrightarrow> xs \<le>\<^sub>v ys"
proof -
  { fix i assume i: "i < length ys" and [simp]: "length xs = length ys"
      and "\<forall>i < length ys. rev xs ! i \<le> rev ys ! i"
    then have "rev xs ! (length ys - i - 1) \<le> rev ys ! (length ys - i - 1)" by auto
    then have "xs ! i \<le> ys ! i" using i by (auto simp: rev_nth) }
  then show ?thesis by (auto simp: less_eq_def rev_nth)
qed

lemma rev_less [simp]:
  "rev xs <\<^sub>v rev ys \<longleftrightarrow> xs <\<^sub>v ys"
  by (simp add: less_def)

lemma less_imp_lex:
  assumes "xs <\<^sub>v ys" shows "xs <\<^sub>l\<^sub>e\<^sub>x ys"
proof -
  have "length ys = length xs" using assms by auto
  then show ?thesis using assms
    by (induct rule: list_induct2) (auto simp: less_Cons)
qed

lemma less_imp_rlex:
  assumes "xs <\<^sub>v ys" shows "xs <\<^sub>r\<^sub>l\<^sub>e\<^sub>x ys"
  using assms and less_imp_lex [of "rev xs" "rev ys"]
  by (simp add: rlex_def)

lemma lex_not_sym:
  assumes "xs <\<^sub>l\<^sub>e\<^sub>x ys"
  shows "\<not> ys <\<^sub>l\<^sub>e\<^sub>x xs"
proof
  assume "ys <\<^sub>l\<^sub>e\<^sub>x xs"
  then obtain i where "i < length xs" and "take i xs = take i ys"
    and "ys ! i < xs ! i" by (elim lex_take_index) auto
  moreover obtain j where "j < length xs" and "length ys = length xs" and "take j xs = take j ys"
    and "xs ! j < ys ! j" using assms by (elim lex_take_index) auto
  ultimately show False by (metis le_antisym nat_less_le nat_neq_iff nth_take)
qed

lemma rlex_not_sym:
  assumes "xs <\<^sub>r\<^sub>l\<^sub>e\<^sub>x ys"
  shows "\<not> ys <\<^sub>r\<^sub>l\<^sub>e\<^sub>x xs"
proof
  assume ass: "ys <\<^sub>r\<^sub>l\<^sub>e\<^sub>x xs"
  then obtain i where "i < length xs" and "take i xs = take i ys"
    and "ys ! i > xs ! i" using assms lex_not_sym rlex_def by blast
  moreover obtain j where "j < length xs" and "length ys = length xs" and "take j xs = take j ys"
    and "xs ! j > ys ! j" using assms rlex_def ass lex_not_sym by blast
  ultimately show False
    by (metis leD nat_less_le nat_neq_iff nth_take)
qed

lemma lex_trans:
  assumes "x <\<^sub>l\<^sub>e\<^sub>x y" and "y <\<^sub>l\<^sub>e\<^sub>x z"
  shows "x <\<^sub>l\<^sub>e\<^sub>x z"
  using assms by (auto simp: antisym_def intro: transD [OF lex_transI])

lemma rlex_trans:
  assumes "x <\<^sub>r\<^sub>l\<^sub>e\<^sub>x y" and "y <\<^sub>r\<^sub>l\<^sub>e\<^sub>x z"
  shows "x <\<^sub>r\<^sub>l\<^sub>e\<^sub>x z"
  using assms lex_trans rlex_def by blast

lemma lex_append_rightD:
  assumes "xs @ us <\<^sub>l\<^sub>e\<^sub>x ys @ vs" and "length xs = length ys"
    and "\<not> xs <\<^sub>l\<^sub>e\<^sub>x ys"
  shows "ys = xs \<and> us <\<^sub>l\<^sub>e\<^sub>x vs"
  using assms(2,1,3)
  by (induct xs ys rule: list_induct2) auto

lemma rlex_Cons:
  "x # xs <\<^sub>r\<^sub>l\<^sub>e\<^sub>x y # ys \<longleftrightarrow> xs <\<^sub>r\<^sub>l\<^sub>e\<^sub>x ys \<or> ys = xs \<and> x < y" (is "?A = ?B")
  by (cases "length ys = length xs")
    (auto simp: rlex_def intro: lex_append_rightI lex_append_leftI dest: lex_append_rightD lex_lengthD)

lemma rlex_irrefl:
  "\<not> x <\<^sub>r\<^sub>l\<^sub>e\<^sub>x x"
  by (induct x) (auto simp: rlex_def dest: lex_append_rightD)

subsection \<open>Code Equations\<close>

fun exists2
  where
    "exists2 d P [] [] \<longleftrightarrow> False"
  | "exists2 d P (x#xs) (y#ys) \<longleftrightarrow> P x y \<or> exists2 d P xs ys"
  | "exists2 d P _ _ \<longleftrightarrow> d"

lemma not_le_code [code_unfold]: "\<not> xs \<le>\<^sub>v ys \<longleftrightarrow> exists2 True (>) xs ys"
  by (induct "True" "(>) :: nat \<Rightarrow> nat \<Rightarrow> bool" xs ys rule: exists2.induct) (auto simp: le_Cons)

end


theory Tut04
  imports Main
begin

inductive ev :: "nat \<Rightarrow> bool" where
  ev0: "ev 0" |
  evSS: "ev n \<Longrightarrow> ev (Suc (Suc n))"

lemma conv_evSS: "ev (Suc (Suc n)) \<Longrightarrow> ev n"
proof -
  assume "ev (Suc (Suc n))" then show "ev n"
  proof (cases)
    txt \<open>\qquad ...\<close> qed
qed

inductive_cases evSS_elim: "ev (Suc (Suc n))"

lemma "\<not> ev (Suc (Suc (Suc 0)))"
proof
  assume "ev (Suc (Suc (Suc 0)))"
  then have "ev (Suc 0)" using conv_evSS
    by blast
  then show False
    using ev.cases by blast
qed

type_synonym ('q,'l) lts = "'q \<Rightarrow> 'l \<Rightarrow> 'q \<Rightarrow> bool"

inductive word :: "('q,'l) lts \<Rightarrow> 'q \<Rightarrow> 'l list \<Rightarrow> 'q \<Rightarrow> bool" for \<delta> where
  empty: "word \<delta> p [] p" |
  app: "\<delta> p x q \<Longrightarrow> word \<delta> q xs r \<Longrightarrow> word \<delta> p (x#xs) r"

definition "det \<delta> \<equiv> \<forall>p l q1 q2. \<delta> p l q1 \<and> \<delta> p l q2 \<longrightarrow> q1 = q2"

lemma
  assumes det: "det \<delta>"
  shows "word \<delta> p ls q \<Longrightarrow> word \<delta> p ls q' \<Longrightarrow> q = q'"
  using assms proof(induction ls arbitrary: p q q')
  case Nil
  from Nil.prems(1)  have "p = q"
    using word.cases by fastforce
  moreover
  from Nil.prems(2) have "p = q'"
    using word.cases by fastforce
  ultimately
  have "q = q'" by simp
  then show ?case .
next
  case (Cons a ls)
  from Cons.prems have "\<exists>r. (\<delta> p a r \<and> word \<delta> r ls q)"
    using word.cases by fastforce
  then obtain r where R: "\<delta> p a r " "word \<delta> r ls q"
    by force
  moreover
  from Cons.prems have "\<exists>r'. (\<delta> p a r' \<and> word \<delta> r' ls q')"
    using word.cases by force
  then obtain r' where R': "\<delta> p a r'" "word \<delta> r' ls q'"
    by force
  ultimately
  have "r = r'"
    using Cons.prems(3)
    by (simp add: det_def)
  then have "q = q'"
    using Cons.IH R'(2) R(2) det by blast
  then show ?case .
qed

fun count :: "'a \<Rightarrow> 'a list \<Rightarrow> nat" where
  "count x [] = 0"
| "count x (y # ys) = (if x=y then Suc (count x ys) else count x ys)"

lemma "count a xs = Suc n \<Longrightarrow> \<exists>ps ss. xs = ps @ a # ss \<and> count a ps = 0 \<and> count a ss = n"
proof(induction xs arbitrary: n)
  case Nil
  then show ?case by simp
next
  case (Cons x xs)
  then show ?case
  proof(cases "a=x")
    case True
    then show ?thesis using Cons by force
  next
    case False
    then obtain ps' ss' where P: "xs = ps' @ a # ss'" "count a ps' = 0" "count a ss' = n"
      using Cons.IH Cons.prems by fastforce
    from Cons.prems have "count a (x # xs) = Suc n"
      by auto
    moreover
    have "count a (x#ps') = 0"
      by (simp add: False P(2))
    ultimately
    have "\<exists>ps ss. x # xs = ps @ a # ss \<and> count a ps = 0 \<and> count a ss = n" using P append_Cons
      by metis
    then show ?thesis .
  qed
qed

end