(*
  File: Union_Find.thy
  Author: Bohua Zhan
*)

section \<open>Union find\<close>

theory Union_Find
  imports Partial_Equiv_Rel
begin

text \<open>
  Development follows theory Union\_Find in \<^cite>\<open>"Separation_Logic_Imperative_HOL-AFP"\<close>.
\<close>

subsection \<open>Representing a partial equivalence relation using rep\_of array\<close>

function (domintros) rep_of where
  "rep_of l i = (if l ! i = i then i else rep_of l (l ! i))" by auto

setup \<open>register_wellform_data ("rep_of l i", ["i < length l"])\<close>
setup \<open>add_backward_prfstep @{thm rep_of.domintros}\<close>
setup \<open>add_rewrite_rule @{thm rep_of.psimps}\<close>
setup \<open>add_prop_induct_rule @{thm rep_of.pinduct}\<close>

definition ufa_invar :: "nat list \<Rightarrow> bool" where [rewrite]:
  "ufa_invar l = (\<forall>i<length l. rep_of_dom (l, i) \<and> l ! i < length l)"

lemma ufa_invarD:
  "ufa_invar l \<Longrightarrow> i < length l \<Longrightarrow> rep_of_dom (l, i) \<and> l ! i < length l" by auto2
setup \<open>add_forward_prfstep_cond @{thm ufa_invarD} [with_term "?l ! ?i"]\<close>
setup \<open>del_prfstep_thm_eqforward @{thm ufa_invar_def}\<close>

lemma rep_of_id [rewrite]: "ufa_invar l \<Longrightarrow> i < length l \<Longrightarrow> l ! i = i \<Longrightarrow> rep_of l i = i" by auto2

lemma rep_of_iff [rewrite]:
  "ufa_invar l \<Longrightarrow> i < length l \<Longrightarrow> rep_of l i = (if l ! i = i then i else rep_of l (l ! i))" by auto2
setup \<open>del_prfstep_thm @{thm rep_of.psimps}\<close>

lemma rep_of_min [rewrite]:
  "ufa_invar l \<Longrightarrow> i < length l \<Longrightarrow> l ! (rep_of l i) = rep_of l i"
@proof @prop_induct "rep_of_dom (l, i)" @qed

lemma rep_of_induct:
  "ufa_invar l \<and> i < length l \<Longrightarrow>
   \<forall>i<length l. l ! i = i \<longrightarrow> P l i \<Longrightarrow>
   \<forall>i<length l. l ! i \<noteq> i \<longrightarrow> P l (l ! i) \<longrightarrow> P l i \<Longrightarrow> P l i"
@proof @prop_induct "rep_of_dom (l, i)" @qed
setup \<open>add_prop_induct_rule @{thm rep_of_induct}\<close>

lemma rep_of_bound [forward_arg1]:
  "ufa_invar l \<Longrightarrow> i < length l \<Longrightarrow> rep_of l i < length l"
@proof @prop_induct "ufa_invar l \<and> i < length l" @qed

lemma rep_of_idem [rewrite]:
  "ufa_invar l \<Longrightarrow> i < length l \<Longrightarrow> rep_of l (rep_of l i) = rep_of l i" by auto2

lemma rep_of_idx [rewrite]:
  "ufa_invar l \<Longrightarrow> i < length l \<Longrightarrow> rep_of l (l ! i) = rep_of l i" by auto2

definition ufa_\<alpha> :: "nat list \<Rightarrow> (nat \<times> nat) set" where [rewrite]:
  "ufa_\<alpha> l = {(x, y). x < length l \<and> y < length l \<and> rep_of l x = rep_of l y}"

lemma ufa_\<alpha>_memI [backward, forward_arg]:
  "x < length l \<Longrightarrow> y < length l \<Longrightarrow> rep_of l x = rep_of l y \<Longrightarrow> (x, y) \<in> ufa_\<alpha> l"
  by (simp add: ufa_\<alpha>_def)

lemma ufa_\<alpha>_equiv [forward]: "part_equiv (ufa_\<alpha> l)" by auto2

lemma ufa_\<alpha>_refl [rewrite]: "(i, i) \<in> ufa_\<alpha> l \<longleftrightarrow> i < length l" by auto2

subsection \<open>Operations on rep\_of array\<close>

definition uf_init_rel :: "nat \<Rightarrow> (nat \<times> nat) set" where [rewrite]:
  "uf_init_rel n = ufa_\<alpha> [0..<n]"

lemma ufa_init_invar [resolve]: "ufa_invar [0..<n]" by auto2

lemma ufa_init_correct [rewrite]:
  "(x, y) \<in> uf_init_rel n \<longleftrightarrow> (x = y \<and> x < n)"
@proof @have "ufa_invar [0..<n]" @qed

abbreviation ufa_union :: "nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat list" where
  "ufa_union l x y \<equiv> l[rep_of l x := rep_of l y]"

lemma ufa_union_invar [forward_arg]:
  "ufa_invar l \<Longrightarrow> x < length l \<Longrightarrow> y < length l \<Longrightarrow> l' = ufa_union l x y \<Longrightarrow> ufa_invar l'"
@proof
  @have "\<forall>i<length l'. rep_of_dom (l', i) \<and> l' ! i < length l'" @with
    @prop_induct "ufa_invar l \<and> i < length l"
  @end
@qed

lemma ufa_union_aux [rewrite]:
  "ufa_invar l \<Longrightarrow> x < length l \<Longrightarrow> y < length l \<Longrightarrow> l' = ufa_union l x y \<Longrightarrow>
   i < length l' \<Longrightarrow> rep_of l' i = (if rep_of l i = rep_of l x then rep_of l y else rep_of l i)"
@proof @prop_induct "ufa_invar l \<and> i < length l" @qed

text \<open>Correctness of union operation.\<close>
theorem ufa_union_correct [rewrite]:
  "ufa_invar l \<Longrightarrow> x < length l \<Longrightarrow> y < length l \<Longrightarrow> l' = ufa_union l x y \<Longrightarrow>
   ufa_\<alpha> l' = per_union (ufa_\<alpha> l) x y"
@proof
  @have "\<forall>a b. (a,b) \<in> ufa_\<alpha> l' \<longleftrightarrow> (a,b) \<in> per_union (ufa_\<alpha> l) x y" @with
    @case "(a,b) \<in> ufa_\<alpha> l'" @with
      @case "rep_of l a = rep_of l x"
      @case "rep_of l a = rep_of l y"
    @end
  @end
@qed

abbreviation ufa_compress :: "nat list \<Rightarrow> nat \<Rightarrow> nat list" where
  "ufa_compress l x \<equiv> l[x := rep_of l x]"

lemma ufa_compress_invar [forward_arg]:
  "ufa_invar l \<Longrightarrow> x < length l \<Longrightarrow> l' = ufa_compress l x \<Longrightarrow> ufa_invar l'"
@proof
  @have "\<forall>i<length l'. rep_of_dom (l', i) \<and> l' ! i < length l'" @with
    @prop_induct "ufa_invar l \<and> i < length l"
  @end
@qed

lemma ufa_compress_aux [rewrite]:
  "ufa_invar l \<Longrightarrow> x < length l \<Longrightarrow> l' = ufa_compress l x \<Longrightarrow> i < length l' \<Longrightarrow>
   rep_of l' i = rep_of l i"
@proof @prop_induct "ufa_invar l \<and> i < length l" @qed

text \<open>Correctness of compress operation.\<close>
theorem ufa_compress_correct [rewrite]:
  "ufa_invar l \<Longrightarrow> x < length l \<Longrightarrow> ufa_\<alpha> (ufa_compress l x) = ufa_\<alpha> l" by auto2

setup \<open>del_prfstep_thm @{thm rep_of_iff}\<close>

end


theory Short_Theory_11_7
  imports "HOL-IMP.Denotational" "HOL-IMP.Vars"
begin

fun Dep :: "com \<Rightarrow> (vname * vname) set" where
  "Dep SKIP = Id" |
  "Dep (x::=a) = {(u,v). if v = x then u \<in> vars a else u = v}" |
  "Dep (c1;;c2) = Dep c1 O Dep c2" |
  "Dep (IF b THEN c1 ELSE c2) = Dep c1 \<union> Dep c2 \<union> vars b \<times> (lvars c1 \<union> lvars c2)" |
  "Dep (WHILE b DO c) = lfp (\<lambda>R. Id \<union> vars b \<times> lvars c \<union> Dep c O R)"

abbreviation Deps :: "com \<Rightarrow> vname set \<Rightarrow> vname set" where
  "Deps c X \<equiv> (\<Union> x\<in>X. {y. (y, x) \<in> Dep c})"

lemma nlvars_Dep: "\<lbrakk>lvars c \<inter> X = {}; x \<in> X; (y, x) \<in> Dep c\<rbrakk> \<Longrightarrow> y = x"
proof (induct c arbitrary: x y)
  case (Assign x1 x2)
  from Assign(1) have "x1 \<notin> X" by simp
  with Assign(2) have "x \<noteq> x1" by auto
  with Assign(3) show ?case by simp
next
  case (Seq c1 c2)
  from Seq(3) have Hv: "lvars c1 \<inter> X = {}" "lvars c2 \<inter> X = {}" by auto
  from Seq(5) obtain x' where Hd: "(y, x') \<in> Dep c1" "(x', x) \<in> Dep c2" by auto
  from Seq(2) [OF Hv(2) Seq(4) Hd(2)] have "x' = x" .
  moreover from this Seq(4) have "x' \<in> X" by simp
  from Seq(1) [OF Hv(1) this Hd(1)] have "y = x'" .
  ultimately show ?case by simp
next
  case (If b c1 c2)
  from If(3) have Hv: "lvars c1 \<inter> X = {}" "lvars c2 \<inter> X = {}" by auto
  from If(5) consider (Hc1) "(y, x) \<in> Dep c1" | (Hc2) "(y, x) \<in> Dep c2" | (Hb) "(y, x) \<in> vars b \<times> (lvars c1 \<union> lvars c2)" by auto
  then show ?case
  proof cases
    case Hc1
    from If(1) [OF Hv(1) If(4) this] show ?thesis .
  next
    case Hc2
    from If(2) [OF Hv(2) If(4) this] show ?thesis .
  next
    case Hb
    with If(4) have "x \<in> lvars (IF b THEN c1 ELSE c2) \<inter> X" by simp
    with If(3) show ?thesis by simp
  qed
next
  case (While b c)
  let ?f = "\<lambda>R. Id \<union> vars b \<times> lvars c \<union> Dep c O R"
  let ?GX = "{(y, x)|y x. x \<in> X \<longrightarrow> y = x}"
  from While(2) have lcXv: "lvars c \<inter> X = {}" by simp
  have "Id \<subseteq> ?GX" by auto
  moreover from lcXv have "vars b \<times> lvars c \<subseteq> ?GX" by auto
  moreover have "Dep c O ?GX \<subseteq> ?GX"
  proof
    fix p
    assume pin: "p \<in> Dep c O ?GX"
    then obtain x y where xy: "p = (y, x)" by auto
    show "p \<in> ?GX"
    proof (cases "x \<in> X")
      case True
      from pin xy obtain x' where xx'y: "(y, x') \<in> Dep c" "(x', x) \<in> ?GX" by auto
      from True xx'y(2) have "x' = x" by simp
      moreover from True this have "x' \<in> X" by simp
      from While(1) [OF lcXv this xx'y(1)] have "y = x'" .
      ultimately have "y = x" by simp
      with xy show ?thesis by simp
    next
      case False
      with xy show ?thesis by simp
    qed
  qed
  ultimately have "?f ?GX \<subseteq> ?GX" by simp
  then have "lfp ?f \<subseteq> ?GX" by (auto intro!: lfp_lowerbound)
  with While(4) have "(y, x) \<in> ?GX" by auto
  with While(3) show ?case by simp
qed simp

lemma nlvars_Dep_str: "\<lbrakk>lvars c \<inter> X = {}; x \<in> X\<rbrakk> \<Longrightarrow> (x, x) \<in> Dep c"
proof (induct c arbitrary: x)
  case (Assign x1 x2)
  from Assign(1, 2) have "x \<noteq> x1" by auto
  then show ?case by simp
next
  case (While b c)
  from While(2) have lcXv: "lvars c \<inter> X = {}" by simp
  from While(1) [OF this While(3)] have "(x, x) \<in> Dep c" .
  moreover let ?f = "\<lambda>R. Id \<union> vars b \<times> lvars c \<union> Dep c O R"
  have "mono ?f" unfolding mono_def by auto
  from lfp_fixpoint [OF this] have "?f (lfp ?f) = lfp ?f" .
  ultimately show ?case by auto
qed auto

lemma nlvars_Deps_X: "lvars c \<inter> X = {} \<Longrightarrow> Deps c X \<subseteq> X"
proof
  fix y
  assume assm: "lvars c \<inter> X = {}" "y \<in> Deps c X"
  from this(2) obtain x where Hx: "(y, x) \<in> Dep c" "x \<in> X" by auto
  from nlvars_Dep [OF assm(1) Hx(2) Hx(1)] have "y = x" .
  with Hx(2) show "y \<in> X" by simp
qed

lemma nlvars_X_Deps: "lvars c \<inter> X = {} \<Longrightarrow> X \<subseteq> Deps c X"
  by (auto simp add: nlvars_Dep_str)

lemma nlvars_Deps: "lvars c \<inter> X = {} \<Longrightarrow> Deps c X = X"
  by (intro equalityI) (simp add: nlvars_Deps_X nlvars_X_Deps)+

lemma nlvars_big_step: "\<lbrakk>(c, s) \<Rightarrow> s'; lvars c \<inter> X = {}\<rbrakk> \<Longrightarrow> s = s' on X"
proof (induct rule: big_step_induct)
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  from Seq(5) have "lvars c\<^sub>1 \<inter> X = {}" "lvars c\<^sub>2 \<inter> X = {}" by auto
  with Seq show ?case by auto
qed auto

lemma "\<lbrakk>(c, s) \<Rightarrow> s'; (c, t) \<Rightarrow> t'; s = t on Deps c X\<rbrakk> \<Longrightarrow> s' = t' on X"
proof (induct arbitrary: t t' X rule: big_step_induct)
  case (Seq c\<^sub>1 s\<^sub>1 s\<^sub>2 c\<^sub>2 s\<^sub>3)
  from Seq(5) obtain ti where Hti: "(c\<^sub>1, t) \<Rightarrow> ti" "(c\<^sub>2, ti) \<Rightarrow> t'" by auto
  from Seq(6) have "s\<^sub>1 = t on Deps c\<^sub>1 (Deps c\<^sub>2 X)" by auto
  from Seq(2) [OF Hti(1) this] have "s\<^sub>2 = ti on Deps c\<^sub>2 X" .
  from Seq(4) [OF Hti(2) this] show ?case .
next
  case (IfTrue b s c\<^sub>1 s' c\<^sub>2)
  let ?i = "IF b THEN c\<^sub>1 ELSE c\<^sub>2"
  show ?case
  proof (cases "lvars ?i \<inter> X = {}")
    case True
    from nlvars_Deps [OF this] IfTrue(5) have "s = t on X" by simp
    moreover from True have "lvars c\<^sub>1 \<inter> X = {}" by auto
    from nlvars_big_step [OF IfTrue(2) this] have "s = s' on X" .
    moreover from nlvars_big_step [OF IfTrue(4) True] have "t = t' on X" .
    ultimately show ?thesis by simp
  next
    case False
    with IfTrue(5) have Heq: "s = t on vars b" "s = t on Deps c\<^sub>1 X" by auto
    from bval_eq_if_eq_on_vars [OF Heq(1)] IfTrue(1) have "bval b t" by simp
    with IfTrue(4) have "(c\<^sub>1, t) \<Rightarrow> t'" by auto
    from IfTrue(3) [OF this Heq(2)] show ?thesis .
  qed
next
  case (IfFalse b s c\<^sub>2 s' c\<^sub>1)
  let ?i = "IF b THEN c\<^sub>1 ELSE c\<^sub>2"
  show ?case
  proof (cases "lvars ?i \<inter> X = {}")
    case True
    from nlvars_Deps [OF this] IfFalse(5) have "s = t on X" by simp
    moreover from True have "lvars c\<^sub>2 \<inter> X = {}" by auto
    from nlvars_big_step [OF IfFalse(2) this] have "s = s' on X" .
    moreover from nlvars_big_step [OF IfFalse(4) True] have "t = t' on X" .
    ultimately show ?thesis by simp
  next
    case False
    with IfFalse(5) have Heq: "s = t on vars b" "s = t on Deps c\<^sub>2 X" by auto
    from bval_eq_if_eq_on_vars [OF Heq(1)] IfFalse(1) have "\<not>bval b t" by simp
    with IfFalse(4) have "(c\<^sub>2, t) \<Rightarrow> t'" by auto
    from IfFalse(3) [OF this Heq(2)] show ?thesis .
  qed
next
  case (WhileFalse b s c)
  let ?f = "\<lambda>R. Id \<union> vars b \<times> lvars c \<union> Dep c O R"
  let ?w = "WHILE b DO c"
  have monof: "mono ?f" unfolding mono_def by auto
  from lfp_fixpoint [OF this] have fpf: "?f (lfp ?f) = lfp ?f" .
  show ?case
  proof (cases "lvars ?w \<inter> X = {}")
    case True
    from nlvars_Deps [OF this] WhileFalse(3) have "s = t on X" by simp
    moreover from nlvars_big_step [OF WhileFalse(2) True] have "t = t' on X" .
    ultimately show "s = t' on X" by simp
  next
    case False
    then have "vars b \<subseteq> (\<Union> x\<in>X. {y. (y,x) \<in> ?f (lfp ?f)})" by auto
    also from fpf have "\<dots> \<subseteq> Deps ?w X" by simp
    finally have "vars b \<subseteq> Deps ?w X" .
    with WhileFalse(3) have Heq1: "s = t on vars b" by auto
    from bval_eq_if_eq_on_vars [OF Heq1] WhileFalse(1) have "\<not>bval b t" by simp
    with WhileFalse(2) have Htt': "t' = t" by auto
    from False have "X \<subseteq> (\<Union>x\<in>X. {y. (y,x) \<in> ?f (lfp ?f)})" by auto
    also from fpf have "\<dots> \<subseteq> Deps ?w X" by simp
    finally have Heq2: "X \<subseteq> Deps ?w X" .
    with WhileFalse(3) Htt' show ?thesis by auto
  qed
next
  case (WhileTrue b s\<^sub>1 c s\<^sub>2 s\<^sub>3)
  let ?f = "\<lambda>R. Id \<union> vars b \<times> lvars c \<union> Dep c O R"
  let ?w = "WHILE b DO c"
  have monof: "mono ?f" unfolding mono_def by auto
  from lfp_fixpoint [OF this] have fpf: "?f (lfp ?f) = lfp ?f" .
  show ?case
  proof (cases "lvars ?w \<inter> X = {}")
    case True
    from nlvars_Deps [OF True] WhileTrue(7) have "s\<^sub>1 = t on X" by simp
    moreover from True have "lvars c \<inter> X = {}" by simp
    from nlvars_big_step [OF WhileTrue(2) this] have "s\<^sub>1 = s\<^sub>2 on X" .
    moreover from nlvars_big_step [OF WhileTrue(4) True] have "s\<^sub>2 = s\<^sub>3 on X" .
    moreover from nlvars_big_step [OF WhileTrue(6) True] have "t = t' on X" .
    ultimately show ?thesis by simp
  next
    case False
    then have "vars b \<subseteq> (\<Union> x\<in>X. {y. (y,x) \<in> ?f (lfp ?f)})" by auto
    also from fpf have "\<dots> \<subseteq> Deps ?w X" by simp
    finally have "vars b \<subseteq> Deps ?w X" .
    with WhileTrue(7) have Heq1: "s\<^sub>1 = t on vars b" by auto
    from bval_eq_if_eq_on_vars [OF Heq1] WhileTrue(1) have "bval b t" by simp
    with WhileTrue(6) obtain ti where Htw: "(c, t) \<Rightarrow> ti" "(?w, ti) \<Rightarrow> t'" by auto
    have "Deps c (Deps ?w X) \<subseteq> Deps ?w X" using lfp_fixpoint [OF monof] by auto
    with WhileTrue(7) have "s\<^sub>1 = t on Deps c (Deps ?w X)" by blast
    from WhileTrue(3) [OF Htw(1) this] have "s\<^sub>2 = ti on Deps ?w X" .
    from WhileTrue(5) [OF Htw(2) this] show ?thesis .
  qed
qed auto

lemma "\<exists> c s s' t X. (c, s) \<Rightarrow> s' \<and> s = t on Deps c X \<and> (\<nexists>t'. (c, t) \<Rightarrow> t')"
proof -
  let ?b = "Less (N 0) (V ''x'')"
  let ?c = "SKIP"
  let ?w = "WHILE ?b DO ?c"
  let ?s = "<> :: vname \<Rightarrow> val"
  let ?t = "<''x'' := 1> :: vname \<Rightarrow> val"
  have H1: "(?w, ?s) \<Rightarrow> ?s" unfolding null_state_def by auto
  have H2: "?s = ?t on Deps ?w {}" by simp
  have Hbt: "bval ?b ?t" by simp
  have H3: "\<nexists>t'. (?w, ?t) \<Rightarrow> t'"
  proof
    assume "\<exists>t'. (?w, ?t) \<Rightarrow> t'"
    then obtain t' where "(?w, ?t) \<Rightarrow> t'" by auto
    then show "False"
      using Hbt by (induct "?w" "?t" t' rule: big_step_induct) auto
  qed
  from H1 H2 H3 show ?thesis by blast
qed


(*
    File:        Nth.thy
    Time-stamp:  <2015-12-15T06:48:15Z>
    Author:      JRF
    Web:         http://jrf.cocolog-nifty.com/software/2016/01/post.html
    Logic Image: ZF (of Isabelle2015)
*)

theory Nth imports ZF_aux List_ZF begin

definition mapnth :: "[[i, i]=>i, i]=>i" where
  "mapnth(f, l) == rec(length(l), [],
                       %n r. r @ [f(n, nth(n, l))])"

lemma UN_succ:
    "(UN z: succ(n). f(z)) = (UN z: n. f(z)) Un f(n)"
apply (rule Un_commute [THEN [2] trans])
apply simp
done

lemmas nth_over_length_lemma = nth_eq_0
lemmas nth_type2 = nth_type

lemma nth_type1:
    "[| n: nat; l: list(A) |] ==> nth(n, l): A Un {0}"
apply (rule_tac i="n" and j="length(l)" in Ord_linear_lt)
apply (erule nat_into_Ord)
apply (rule nat_into_Ord)
apply (rule length_type, assumption)
apply (frule nth_type, assumption)
apply (erule UnI1)
apply (frule nth_eq_0, assumption)
apply (rule le_eqI)
apply (erule sym)
apply (erule nat_into_Ord)
apply blast
apply (frule nth_eq_0, assumption)
apply (erule leI)
apply blast
done

lemma nthlemma_0:
  "(UN y: A. 0) = 0"
	"Collect(0, P) = 0"
  "{x: A . False} = 0"
	"{x: A . True} = A"
by blast+

lemmas nthlemma = nat_ltI ball_mem_nat_in_nat
  (* nth_Cons nth_0 nth_empty *) UN_succ (* UN_0 UN_constant *)
  Un_assoc[THEN sym] (* lt_nat_in_nat mem_nat_in_nat *)
  nthlemma_0
(* declare nat_ltI [TC] *)

declare lt_nat_in_nat [TC]
declare mem_nat_in_nat [TC]

declare nthlemma [simp]
declare nat_bquant_succ1 [simp del]
declare nat_bquant_succ2 [simp]

lemma nth_app_right:
    assumes major: "l: list(A)"
    and prem: "x < length(l)"
    shows "nth(x, l@m) = nth(x, l)"
apply (rule prem [THEN ltD, THEN rev_bspec])
apply (rule major [THEN list.induct])
apply simp_all
done

lemma nth_app_left:
    "l: list(A) ==> nth(length(l), l @ Cons(x, m)) = x"
apply (erule list.induct)
apply simp_all
done

lemma nth_app_left2 [rule_format]:
  "l: list(A) ==> ALL n: nat. length(l) le n -->
              nth(n, l@m) = nth(n #- length(l), m)"
apply (erule list.induct)
apply simp_all
apply (intro ballI impI)
apply (erule natE)
apply simp_all
done

lemma nth_convert_list_type:
  assumes major: "l: list(B)"
  and prem: "ALL z: length(l). nth(z, l): A"
  shows "l: list(A)"
apply (rule prem [THEN rev_mp])
apply (rule major [THEN list.induct])
apply simp_all
done

lemma nth_map:
  assumes major: "l: list(A)"
  and prem: "n < length(l)"
  shows "nth(n, map(f, l)) = f(nth(n, l))"
apply (rule prem [THEN ltD, THEN rev_bspec])
apply (rule major [THEN list.induct])
apply simp_all
done

lemma nth_inj:
  assumes major: "ALL z: length(l). nth(z, m) = nth(z, l)"
      and prem: "length(m) = length(l)"
      and l_list: "l: list(A)"
      and m_list: "m: list(B)"
    shows "m = l"
apply (rule prem [THEN rev_mp])
apply (rule major [THEN rev_mp])
apply (rule m_list [THEN rev_bspec])
apply (rule l_list [THEN list.induct])
apply simp_all
apply clarify
apply (erule_tac a="x" in list.cases)
apply simp_all
apply blast
done

declare nat_bquant_succ1 [simp]
declare nat_bquant_succ2 [simp del]

lemma nth_existence_lemma:
  assumes major: "ALL z:n. f(z): A"
  and sub: "n: nat"
  shows "EX l: list(A). length(l) = n & (ALL z: n. nth(z, l) = f(z))"
apply (rule major [THEN rev_mp])
apply (rule sub [THEN nat_induct])
apply simp_all
apply clarify
apply (rule_tac x="l@[f(length(l))]" in bexI)
apply (simp_all add: nth_append)
apply blast
done

(** mapnth **)
lemma mapnth_Nil:
    "mapnth(f, []) = []"
apply (unfold mapnth_def)
apply simp
done

lemma mapnth_lemma:
    "n: nat ==>
       Cons(f(0, a), rec(n, [], %x r. r @ [f(succ(x), nth(x, l))])) =
          rec(n, [], %x r. r @ [f(x, nth(x, Cons(a, l)))])@
                      [f(n, nth(n, Cons(a, l)))]"
apply (erule nat_induct)
apply simp
apply (simp del: app_Cons add: app_Cons [THEN sym])
done

lemma mapnth_Cons:
    "l: list(A) ==>
      mapnth(f, Cons(a, l)) = Cons(f(0, a), mapnth(%x. f(succ(x)), l))"
apply (unfold mapnth_def)
apply (rule mapnth_lemma [THEN sym, THEN [2] trans])
apply simp_all
done

lemma mapnth_Cons2:
  "[| length(l): nat |] ==>
    mapnth(f, Cons(a, l)) = Cons(f(0, a), mapnth(%x. f(succ(x)), l))"
apply (unfold mapnth_def)
apply (rule mapnth_lemma [THEN sym, THEN [2] trans])
apply simp_all
done

lemma rec_nth_app_right [rule_format]:
    "[| n: nat; l: list(A) |] ==> n le length(l) -->
        rec(n, [], %n r. r @ [f(n, nth(n, l@m))]) =
        rec(n, [], %n r. r @ [f(n, nth(n, l))])"
apply (erule nat_induct)
apply (simp_all add: nth_app_right leI)
done

lemma mapnth_type:
  assumes prem1: "l: list(A)"
  and prem2: "!! n x. [| n: nat; x: A |] ==> f(n, x): B"
  shows "mapnth(f, l): list(B)"
apply (unfold mapnth_def)
apply (rule prem1 [THEN list_append_induct])
apply simp
apply (simp add: rec_nth_app_right)
apply (erule app_type)
apply (rule list.intros)
apply (rule prem2)
apply simp_all
done

lemma mapnth_app_last:
  "l: list(A) ==>
      mapnth(f, l@[a]) = mapnth(f, l) @ [f(length(l), a)]"
apply (unfold mapnth_def)
apply (drule_tac B="list(cons(a, A))" in rev_subsetD)
apply (rule list_mono)
apply blast
apply (simp add: rec_nth_app_right)
apply (simp add: nth_app_left2)
done

lemma mapnth_type2:
  "l: list(A) ==> mapnth(f, l): list({f(n, x). <n,x>: nat*A})"
apply (rule mapnth_type, assumption)
apply (rule_tac P="%y. y:{f(n, x). <n,x>: nat*A}"
         and b="f(n,x)" and a="split(f, <n, x>)" in ssubst)
apply simp_all
apply blast
done

lemma length_mapnth:
    "l: list(A) ==> length(mapnth(f, l)) = length(l)"
apply (erule list_append_induct)
apply (frule_tac [2] f="f" in mapnth_type2)
apply (simp_all add: mapnth_Nil mapnth_app_last)
apply (subst length_app, assumption)
apply (rule list.intros)
apply (rule_tac b="f(length(y), x)" in ssubst)
apply (rule_tac [2] RepFunI)
apply (rule_tac [2] a="length(y)" and b="x" in SigmaI)
apply simp_all
done

lemma nth_mapnth:
  assumes major: "l: list(A)"
  and prem: "n < length(l)"
  shows "nth(n, mapnth(f, l)) = f(n, nth(n, l))"
apply (rule prem [THEN ltD, THEN rev_bspec])
apply (rule major [THEN list_append_induct])
apply (simp_all add: mapnth_app_last)
apply (frule_tac f="f" in mapnth_type2)
apply (frule_tac f="f" in length_mapnth)
apply safe
apply (simp_all add: nth_app_left nth_app_right nth_app_left2)
done

lemma map_mapnth:
  "l: list(A) ==> map(f, mapnth(g, l)) = mapnth(%x r. f(g(x, r)), l)"
apply (frule_tac f="g" in mapnth_type2)
apply (rule nth_inj)
prefer 4 apply (rule map_type2, assumption)
prefer 3 apply (rule mapnth_type2, assumption)
apply (simp_all add: length_mapnth nth_map nth_mapnth)
done

lemma mapnth_map:
  "l: list(A) ==> mapnth(f, map(g, l)) = mapnth(%x r. f(x, g(r)), l)"
apply (frule_tac h="g" in map_type2)
apply (rule nth_inj)
prefer 4 apply (erule mapnth_type2)
prefer 3 apply (erule mapnth_type2)
apply (simp_all add: length_mapnth nth_map nth_mapnth)
done

lemma mapnth_mapnth:
  "l: list(A) ==> mapnth(f, mapnth(g, l)) = mapnth(%x r. f(x, g(x, r)), l)"
apply (frule_tac f="g" in mapnth_type2)
apply (rule nth_inj)
prefer 4 apply (erule mapnth_type2)
prefer 3 apply (erule mapnth_type2)
apply (simp_all add: length_mapnth nth_mapnth)
done

(** nth_0E **)
lemma nth_0E_lemma:
    "l: list(A) ==> ALL a. 0 < length(l) --> nth(0, l) = a
       --> (EX m: list(A). a: A & l = Cons(a, m))"
apply (erule list.cases)
apply simp_all
done

lemma nth_0E:
  assumes major: "nth(0, l) = a"
  and l_list: "l: list(A)"
  and l_len: "0 < length(l)"
  and prem: "!!m. [| a: A; m: list(A); l = Cons(a, m) |] ==> P"
  shows "P"
apply (rule l_list [THEN nth_0E_lemma,
                     THEN spec, THEN mp, THEN mp, THEN bexE])
apply (erule_tac [3] conjE)
apply (rule_tac [3] prem)
apply ((rule major l_len) | assumption)+
done

lemma length_0E:
  assumes major: "length(l) = 0"
  and l_list: "l: list(A)"
  and prem: "l = [] ==> P"
  shows "P"
apply (rule l_list [THEN list.cases])
apply (erule prem)
apply (insert major)
apply simp
done

declare mapnth_type2 [TC]
declare mapnth_type [TC]

lemmas nth_ss_lemmas = mapnth_Nil mapnth_Cons2
   add_0_right (* add_succ_right length_app app_right_Nil *)
   nth_app_right nth_app_left Cons_iff

declare nth_ss_lemmas [simp]

end


(*  Title:      HOL/UNITY/Simple/Channel.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

Unordered Channel

From Misra, "A Logic for Concurrent Programming" (1994), section 13.3
*)

theory Channel imports "../UNITY_Main" begin

type_synonym state = "nat set"

consts
  F :: "state program"

definition minSet :: "nat set => nat option" where
    "minSet A == if A={} then None else Some (LEAST x. x \<in> A)"

axiomatization where

  UC1:  "F \<in> (minSet -` {Some x}) co (minSet -` (Some`atLeast x))" and

  (*  UC1  "F \<in> {s. minSet s = x} co {s. x \<subseteq> minSet s}"  *)

  UC2:  "F \<in> (minSet -` {Some x}) leadsTo {s. x \<notin> s}"

(*None represents "infinity" while Some represents proper integers*)
lemma minSet_eq_SomeD: "minSet A = Some x ==> x \<in> A"
apply (unfold minSet_def)
apply (simp split: if_split_asm)
apply (fast intro: LeastI)
done

lemma minSet_empty [simp]: " minSet{} = None"
by (unfold minSet_def, simp)

lemma minSet_nonempty: "x \<in> A ==> minSet A = Some (LEAST x. x \<in> A)"
by (unfold minSet_def, auto)

lemma minSet_greaterThan:
     "F \<in> (minSet -` {Some x}) leadsTo (minSet -` (Some`greaterThan x))"
apply (rule leadsTo_weaken)
apply (rule_tac x1=x in psp [OF UC2 UC1], safe)
apply (auto dest: minSet_eq_SomeD simp add: linorder_neq_iff)
done

(*The induction*)
lemma Channel_progress_lemma:
     "F \<in> (UNIV-{{}}) leadsTo (minSet -` (Some`atLeast y))"
apply (rule leadsTo_weaken_R)
apply (rule_tac l = y and f = "the o minSet" and B = "{}"
       in greaterThan_bounded_induct, safe)
apply (simp_all (no_asm_simp))
apply (drule_tac [2] minSet_nonempty)
 prefer 2 apply simp
apply (rule minSet_greaterThan [THEN leadsTo_weaken], safe)
apply simp_all
apply (drule minSet_nonempty, simp)
done

lemma Channel_progress: "!!y::nat. F \<in> (UNIV-{{}}) leadsTo {s. y \<notin> s}"
apply (rule Channel_progress_lemma [THEN leadsTo_weaken_R], clarify)
apply (frule minSet_nonempty)
apply (auto dest: Suc_le_lessD not_less_Least)
done

end


theory regexp_SeqAssociative
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

datatype A = X | Y

datatype R
  = Nil2 | Eps | Atom "A" | Plus "R" "R" | Seq "R" "R" | Star "R"

fun seq :: "R => R => R" where
"seq x y =
   case x of
     | other =>
         case y of
           | other =>
               case x of
                 | other =>
                     case y of
                       | other => Seq x y
                       | Eps => x
                     end
                 | Eps => y
               end
           | Nil2 => y
         end
     | Nil2 => x
   end"

fun plus :: "R => R => R" where
"plus x y =
   case x of
     | other =>
         case y of
           | other => Plus x y
           | Nil2 => x
         end
     | Nil2 => y
   end"

fun or2 :: "bool => bool => bool" where
"or2 True y = True"
| "or2 False y = y"

fun eqA :: "A => A => bool" where
"eqA (X) y = False"
| "eqA (Y) (X) = False"
| "eqA (Y) (Y) = True"

fun and2 :: "bool => bool => bool" where
"and2 True y = y"
| "and2 False y = False"

fun eps :: "R => bool" where
"eps x =
   case x of
     | other => False
     | Eps => True
     | Plus p q => or2 (eps p) (eps q)
     | Seq p2 q2 => and2 (eps p2) (eps q2)
     | Star y => True
   end"

fun epsR :: "R => R" where
"epsR x = (if eps x then Eps else Nil2)"

fun step :: "R => A => R" where
"step x y =
   case x of
     | other => Nil2
     | Atom a => (if eqA a y then Eps else Nil2)
     | Plus p q => plus (step p y) (step q y)
     | Seq p2 q2 =>
         plus (seq (step p2 y) q2) (seq (epsR p2) (step q2 y))
     | Star p3 => seq (step p3 y) x
   end"

fun recognise :: "R => A list => bool" where
"recognise x (Nil2) = eps x"
| "recognise x (Cons2 z xs) = recognise (step x z) xs"

(*hipster seq plus or2 eqA and2 eps epsR step recognise *)

theorem x0 :
  "!! (p :: R) (q :: R) (r :: R) (s :: A list) .
     (recognise (Seq p (Seq q r)) s) = (recognise (Seq (Seq p q) r) s)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


section \<open>LTL Formulae\<close>

theory Formula
imports
  "Basics/Stuttering"
  Stuttering_Equivalence.PLTL
begin

  locale formula =
    fixes \<phi> :: "'a pltl"
  begin

    definition language :: "'a stream set"
      where "language \<equiv> {w. snth w \<Turnstile>\<^sub>p \<phi>}"

    lemma language_entails[iff]: "w \<in> language \<longleftrightarrow> snth w \<Turnstile>\<^sub>p \<phi>" unfolding language_def by simp

  end

  locale formula_next_free =
    formula \<phi>
    for \<phi> :: "'a pltl"
    +
    assumes next_free: "next_free \<phi>"
  begin

    lemma stutter_equivalent_entails[dest]: "u \<approx> v \<Longrightarrow> u \<Turnstile>\<^sub>p \<phi> \<longleftrightarrow> v \<Turnstile>\<^sub>p \<phi>"
      using next_free_stutter_invariant next_free by blast

  end

end


theory Extensionality imports Pure begin

lemma extensionality:
      assumes "!!x. f x == g x"
      shows "f == g"
    using assms[abs_def] .

end


theory list_append_inj_1
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin

datatype 'a list = Nil2 | Cons2 "'a" "'a list"

fun append :: "'a list => 'a list => 'a list" where
"append (Nil2) y = y"
| "append (Cons2 z xs) y = Cons2 z (append xs y)"

(*hipster append *)

theorem x0 :
  "!! (xs :: 'a list) (ys :: 'a list) (zs :: 'a list) .
     ((append xs zs) = (append ys zs)) ==> (xs = ys)"
  by (tactic \<open>Subgoal.FOCUS_PARAMS (K (Tactic_Data.hard_tac @{context})) @{context} 1\<close>)

end


section\<open>Main ZF Theory: Everything Except AC\<close>

theory ZF imports List IntDiv CardinalArith begin

(*The theory of "iterates" logically belongs to Nat, but can't go there because
  primrec isn't available into after Datatype.*)

subsection\<open>Iteration of the function \<^term>\<open>F\<close>\<close>

consts  iterates :: "[i\<Rightarrow>i,i,i] \<Rightarrow> i"   (\<open>(_^_ '(_'))\<close> [60,1000,1000] 60)

primrec
    "F^0 (x) = x"
    "F^(succ(n)) (x) = F(F^n (x))"

definition
  iterates_omega :: "[i\<Rightarrow>i,i] \<Rightarrow> i" (\<open>(_^\<omega> '(_'))\<close> [60,1000] 60) where
    "F^\<omega> (x) \<equiv> \<Union>n\<in>nat. F^n (x)"

lemma iterates_triv:
     "\<lbrakk>n\<in>nat;  F(x) = x\<rbrakk> \<Longrightarrow> F^n (x) = x"
by (induct n rule: nat_induct, simp_all)

lemma iterates_type [TC]:
     "\<lbrakk>n \<in> nat;  a \<in> A; \<And>x. x \<in> A \<Longrightarrow> F(x) \<in> A\<rbrakk>
      \<Longrightarrow> F^n (a) \<in> A"
by (induct n rule: nat_induct, simp_all)

lemma iterates_omega_triv:
    "F(x) = x \<Longrightarrow> F^\<omega> (x) = x"
by (simp add: iterates_omega_def iterates_triv)

lemma Ord_iterates [simp]:
     "\<lbrakk>n\<in>nat;  \<And>i. Ord(i) \<Longrightarrow> Ord(F(i));  Ord(x)\<rbrakk>
      \<Longrightarrow> Ord(F^n (x))"
by (induct n rule: nat_induct, simp_all)

lemma iterates_commute: "n \<in> nat \<Longrightarrow> F(F^n (x)) = F^n (F(x))"
by (induct_tac n, simp_all)

subsection\<open>Transfinite Recursion\<close>

text\<open>Transfinite recursion for definitions based on the
    three cases of ordinals\<close>

definition
  transrec3 :: "[i, i, [i,i]\<Rightarrow>i, [i,i]\<Rightarrow>i] \<Rightarrow>i" where
    "transrec3(k, a, b, c) \<equiv>
       transrec(k, \<lambda>x r.
         if x=0 then a
         else if Limit(x) then c(x, \<lambda>y\<in>x. r`y)
         else b(Arith.pred(x), r ` Arith.pred(x)))"

lemma transrec3_0 [simp]: "transrec3(0,a,b,c) = a"
by (rule transrec3_def [THEN def_transrec, THEN trans], simp)

lemma transrec3_succ [simp]:
     "transrec3(succ(i),a,b,c) = b(i, transrec3(i,a,b,c))"
by (rule transrec3_def [THEN def_transrec, THEN trans], simp)

lemma transrec3_Limit:
     "Limit(i) \<Longrightarrow>
      transrec3(i,a,b,c) = c(i, \<lambda>j\<in>i. transrec3(j,a,b,c))"
by (rule transrec3_def [THEN def_transrec, THEN trans], force)

declaration \<open>fn _ =>
  Simplifier.map_ss (Simplifier.set_mksimps (fn ctxt =>
    map mk_eq o Ord_atomize o Variable.gen_all ctxt))
\<close>

end


(*
  Title:  Refutations and Maximal Consistent Sets
  Author: Asta Halkjær From
*)

chapter \<open>Refutations\<close>

theory Refutations imports Maximal_Consistent_Sets begin

section \<open>Rearranging Refutations\<close>

locale Refutations =
  fixes refute :: \<open>'a list \<Rightarrow> bool\<close>
  assumes refute_struct: \<open>\<And>A B. refute A \<Longrightarrow> set A \<subseteq> set B \<Longrightarrow> refute B\<close>
begin

theorem refute_split:
  assumes \<open>set A \<subseteq> set B \<union> X\<close> \<open>refute A\<close>
  shows \<open>\<exists>C. set C \<subseteq> X \<and> refute (B @ C)\<close>
  using struct_split[where P=refute] refute_struct assms by blast

corollary refute_split1:
  assumes \<open>set A \<subseteq> {q} \<union> X\<close> \<open>refute A\<close>
  shows \<open>\<exists>C. set C \<subseteq> X \<and> refute (q # C)\<close>
  using assms refute_split[where B=\<open>[q]\<close>] by simp

end

section \<open>MCSs and Refutability\<close>

locale Refutations_MCS = Refutations + MCS_Base +
  assumes consistent_refute: \<open>\<And>S. consistent S = (\<nexists>S'. set S' \<subseteq> S \<and> refute S')\<close>
begin

theorem MCS_refute:
  assumes \<open>consistent S\<close> \<open>maximal S\<close>
  shows \<open>p \<notin> S \<longleftrightarrow> (\<exists>S'. set S' \<subseteq> S \<and> refute (p # S'))\<close>
proof
  assume \<open>p \<notin> S\<close>
  then show \<open>\<exists>S'. set S' \<subseteq> S \<and> refute (p # S')\<close>
    using assms refute_split1 consistent_refute unfolding maximal_def by metis
next
  assume \<open>\<exists>S'. set S' \<subseteq> S \<and> refute (p # S')\<close>
  then show \<open>p \<notin> S\<close>
    using assms consistent_refute by fastforce
qed

end

end


theory Matrix_Equation_Construction

imports BKR_Algorithm
begin

section "Results with Sturm's Theorem"

lemma relprime:
  fixes q::"real poly"
  assumes "coprime p q"
  assumes "p \<noteq> 0"
  assumes "q \<noteq> 0"
  shows "changes_R_smods p (pderiv p) = card {x. poly p x = 0 \<and> poly q x > 0} + card {x. poly p x = 0 \<and> poly q x < 0}"
proof -
  have 1: "{x. poly p x = 0 \<and> poly q x = 0} = {}"
    using assms(1) coprime_poly_0 by auto
  have 2: "changes_R_smods p (pderiv p) = int (card {x . poly p x = 0})" using sturm_R by auto
  have 3: "{x. poly p x = 0 \<and> poly q x > 0} \<inter> {x. poly p x = 0 \<and> poly q x < 0} = {}" by auto
  have "{x . poly p x = 0} =  {x. poly p x = 0 \<and> poly q x > 0} \<union>{x. poly p x = 0 \<and> poly q x < 0} \<union> {x. poly p x = 0 \<and> poly q x = 0}" by force
  then have "{x . poly p x = 0} = {x. poly p x = 0 \<and> poly q x > 0} \<union>{x. poly p x = 0 \<and> poly q x < 0}" using 1 by auto
  then have "(card {x . poly p x = 0}) = (card ({x. poly p x = 0 \<and> poly q x > 0} \<union>{x. poly p x = 0 \<and> poly q x < 0}))" by presburger
  then have 4: "(card {x . poly p x = 0}) =  card {x. poly p x = 0 \<and> poly q x > 0} + card {x. poly p x = 0 \<and> poly q x < 0}" using 3 by (simp add: card_Un_disjoint assms(2) poly_roots_finite)
  show ?thesis  by (simp add: "2" "4")
qed

(* This is the same proof as card_eq_sum *)
lemma card_eq_const_sum:
  fixes k:: real
  assumes "finite A"
  shows "k*card A = sum (\<lambda>x. k) A"
proof -
  have "plus \<circ> (\<lambda>_. Suc 0) = (\<lambda>_. Suc)"
    by (simp add: fun_eq_iff)
  then have "Finite_Set.fold (plus \<circ> (\<lambda>_. Suc 0)) = Finite_Set.fold (\<lambda>_. Suc)"
    by (rule arg_cong)
  then have "Finite_Set.fold (plus \<circ> (\<lambda>_. Suc 0)) 0 A = Finite_Set.fold (\<lambda>_. Suc) 0 A"
    by (blast intro: fun_cong)
  then show ?thesis
    by (simp add: card.eq_fold sum.eq_fold)
qed

lemma restate_tarski:
  fixes q::"real poly"
  assumes "coprime p q"
  assumes "p \<noteq> 0"
  assumes "q \<noteq> 0"
  shows "changes_R_smods p ((pderiv p) * q) = card {x. poly p x = 0 \<and> poly q x > 0} -  int(card {x. poly p x = 0 \<and> poly q x < 0})"
proof -
  have 3: "taq {x. poly p x=0} q \<equiv> \<Sum>y\<in>{x. poly p x=0}. Sturm_Tarski.sign (poly q y)" by (simp add: taq_def)
  have 4: "{x. poly p x=0} =  {x. poly p x = 0 \<and> poly q x > 0} \<union> {x. poly p x = 0 \<and> poly q x < 0} \<union> {x. poly p x = 0 \<and> poly q x = 0}" by force
  then have 5: "{x. poly p x=0} =  {x. poly p x = 0 \<and> poly q x > 0} \<union> {x. poly p x = 0 \<and> poly q x < 0}" using assms(1) coprime_poly_0 by auto
  then have 6: "\<Sum>y\<in>{x. poly p x=0}. Sturm_Tarski.sign (poly q y) \<equiv> \<Sum>y\<in>{x. poly p x = 0 \<and> poly q x > 0} \<union> {x. poly p x = 0 \<and> poly q x < 0}. Sturm_Tarski.sign (poly q y)" by presburger
  then have 12: "taq {x. poly p x=0} q \<equiv> \<Sum>y\<in>{x. poly p x = 0 \<and> poly q x > 0} \<union> {x. poly p x = 0 \<and> poly q x < 0}. Sturm_Tarski.sign (poly q y)"
    by (simp add: "3")
  have 7: "{x. poly p x = 0 \<and> poly q x > 0} \<inter> {x. poly p x = 0 \<and> poly q x < 0} = {}" by auto
  then have 8: "\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x > 0} \<union> {x. poly p x = 0 \<and> poly q x < 0}. Sturm_Tarski.sign (poly q y) \<equiv> (\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x > 0}.Sturm_Tarski.sign (poly q y)) + (\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x < 0}.Sturm_Tarski.sign(poly q y))" by (simp add: assms(2) poly_roots_finite sum.union_disjoint)
  then have 13: "taq {x. poly p x=0} q \<equiv> (\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x > 0}.Sturm_Tarski.sign (poly q y)) + (\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x < 0}.Sturm_Tarski.sign(poly q y))"
    by (simp add: "12")
  then have 9: "taq {x. poly p x = 0} q \<equiv> (\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x > 0}.1) + (\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x < 0}.(-1))" by simp
  have 10: "(\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x > 0}.1) =  card {x. poly p x = 0 \<and> poly q x > 0}" using card_eq_sum by auto
  have 11: " (\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x < 0}.(-1)) = -1*card {x. poly p x = 0 \<and> poly q x < 0}" using card_eq_const_sum by simp
  have 14: "taq {x. poly p x = 0} q \<equiv> card {x. poly p x = 0 \<and> poly q x > 0} + -1*card {x. poly p x = 0 \<and> poly q x < 0}" using 9 10 11 by simp
  have 1: "changes_R_smods p (pderiv p * q) = taq {x. poly p x=0} q" using sturm_tarski_R by simp
  then have 15: "changes_R_smods p (pderiv p * q) = card {x. poly p x = 0 \<and> poly q x > 0} + (-1*card {x. poly p x = 0 \<and> poly q x < 0})" using 14 by linarith
  have 16: "(-1*card {x. poly p x = 0 \<and> poly q x < 0}) = - card {x. poly p x = 0 \<and> poly q x < 0}" by auto
  then show ?thesis using 15 by linarith
qed

lemma restate_tarski2:
  fixes q::"real poly"
  assumes "p \<noteq> 0"
  shows "changes_R_smods p ((pderiv p) * q) =
        int(card {x. poly p x = 0 \<and> poly q x > 0}) -
        int(card {x. poly p x = 0 \<and> poly q x < 0})"
  unfolding sturm_tarski_R[symmetric] taq_def
proof -
  let ?all = "{x. poly p x=0}"
  let ?lt = "{x. poly p x=0 \<and> poly q x < 0}"
  let ?gt = "{x. poly p x=0 \<and> poly q x > 0}"
  let ?eq = "{x. poly p x=0 \<and> poly q x = 0}"
  have eq: "?all = ?lt \<union> ?gt \<union> ?eq" by force
  from poly_roots_finite[OF assms] have fin: "finite ?all" .
  show  "(\<Sum>x | poly p x = 0. Sturm_Tarski.sign (poly q x)) = int (card ?gt) - int (card ?lt)"
    unfolding eq
    apply (subst sum_Un)
      apply (auto simp add:fin)
    apply (subst sum_Un)
    by (auto simp add:fin)
qed

lemma coprime_set_prod:
  fixes I:: "real poly set"
  shows "finite I \<Longrightarrow> ((\<forall> q \<in> I. (coprime p q)) \<longrightarrow> (coprime p (\<Prod> I)))"
proof (induct rule: finite_induct)
  case empty
  then show ?case
    by simp
next
  case (insert x F)
  then show ?case using coprime_mult_right_iff
    by simp
qed

lemma finite_nonzero_set_prod:
  fixes I:: "real poly set"
  shows  nonzero_hyp: "finite I \<Longrightarrow> ((\<forall> q \<in> I. q \<noteq> 0) \<longrightarrow> \<Prod> I \<noteq> 0)"
proof (induct rule: finite_induct)
  case empty
  then show ?case
    by simp
next
  case (insert x F)
  have h: "\<Prod> (insert x F) = x * (\<Prod> F)"
    by (simp add: insert.hyps(1) insert.hyps(2))
  have h_xin: "x \<in> insert x F"
    by simp
  have hq: "(\<forall> q \<in> (insert x F). q \<noteq> 0) \<longrightarrow> x \<noteq> 0" using h_xin
    by blast
  show ?case using h hq
    using insert.hyps(3) by auto
qed

section "Setting up the construction: Definitions"

definition characterize_root_list_p:: "real poly \<Rightarrow> real list"
  where "characterize_root_list_p p \<equiv> sorted_list_of_set({x. poly p x = 0}::real set)"

(************** Renegar's N(I); towards defining the RHS of the matrix equation **************)

lemma construct_NofI_prop:
  fixes p:: "real poly"
  fixes I:: "real poly list"
  assumes nonzero: "p\<noteq>0"
  shows "construct_NofI p I =
    rat_of_int (int (card {x. poly p x = 0 \<and> poly (prod_list I) x > 0}) -
    int (card {x. poly p x = 0 \<and> poly (prod_list I) x < 0}))"
  unfolding construct_NofI_def
  using assms restate_tarski2 nonzero rsquarefree_def
  by (simp add: rsquarefree_def)

definition construct_s_vector:: "real poly \<Rightarrow> real poly list list \<Rightarrow> rat vec"
  where "construct_s_vector p Is = vec_of_list (map (\<lambda> I.(construct_NofI p I)) Is)"

(* Consistent Sturm_Tarski.sign asSturm_Tarski.signments *)
definition squash::"'a::linordered_field \<Rightarrow> rat"
  where "squash x = (if x > 0 then 1
                    else if x < 0 then -1
                    else 0)"

definition signs_at::"real poly list \<Rightarrow> real \<Rightarrow> rat list"
  where "signs_at qs x \<equiv>
    map (squash \<circ> (\<lambda>q. poly q x)) qs"

definition characterize_consistent_signs_at_roots:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat list list"
  where "characterize_consistent_signs_at_roots p qs =
  (remdups (map (signs_at qs) (characterize_root_list_p p)))"

(* An alternate version designed to be used when every polynomial in qs is relatively prime to p*)
definition consistent_sign_vec_copr::"real poly list \<Rightarrow> real \<Rightarrow> rat list"
  where "consistent_sign_vec_copr qs x \<equiv>
    map (\<lambda> q. if (poly q x > 0) then (1::rat) else (-1::rat)) qs"

definition characterize_consistent_signs_at_roots_copr:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat list list"
  where "characterize_consistent_signs_at_roots_copr p qss =
  (remdups (map (consistent_sign_vec_copr qss) (characterize_root_list_p p)))"

lemma csa_list_copr_rel:
  fixes p:: "real poly"
  fixes qs:: "real poly list"
  assumes nonzero: "p\<noteq>0"
  assumes pairwise_rel_prime: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))"
  shows "characterize_consistent_signs_at_roots p qs = characterize_consistent_signs_at_roots_copr p qs"
proof -
  have "\<forall>q \<in> set(qs). \<forall> x \<in> set (characterize_root_list_p p).  poly q x \<noteq> 0"
    using pairwise_rel_prime
    using coprime_poly_0 in_set_member nonzero poly_roots_finite characterize_root_list_p_def by fastforce
  then have h: "\<forall>q \<in> set(qs). \<forall> x \<in> set (characterize_root_list_p p). squash (poly q x) = (if (poly q x > 0) then (1::rat) else (-1::rat))"
    by (simp add: squash_def)
  have "map (\<lambda>r. map (\<lambda>p. if 0 < poly p r then 1 else - 1) qs) (characterize_root_list_p p) = map (\<lambda>r. map (squash \<circ> (\<lambda>p. poly p r)) qs) (characterize_root_list_p p)"
    by (simp add: h)
  thus ?thesis unfolding characterize_consistent_signs_at_roots_def characterize_consistent_signs_at_roots_copr_def
      signs_at_def consistent_sign_vec_copr_def
    by presburger
qed

(************** Towards defining Renegar's polynomial function and the LHS of the matrix equation **************)

definition list_constr:: "nat list \<Rightarrow> nat \<Rightarrow> bool"
  where "list_constr L n \<equiv> list_all (\<lambda>x. x < n) L"

definition all_list_constr:: "nat list list \<Rightarrow> nat \<Rightarrow> bool"
  where "all_list_constr L n \<equiv> (\<forall>x. List.member L x \<longrightarrow> list_constr x n)"

(* The first input is the subset; the second input is the consistent Sturm_Tarski.sign asSturm_Tarski.signment.
  We want to map over the first list and pull out all of the elements in the second list with
  corresponding positions, and then multiply those together.
*)
definition z:: "nat list \<Rightarrow> rat list \<Rightarrow> rat"
  where "z index_list sign_asg \<equiv> (prod_list (map (nth sign_asg) index_list))"

definition mtx_row:: "rat list list \<Rightarrow> nat list \<Rightarrow> rat list"
  where "mtx_row sign_list index_list \<equiv> (map ( (z index_list)) sign_list)"

definition matrix_A:: "rat list list \<Rightarrow> nat list list \<Rightarrow> rat mat"
  where "matrix_A sign_list subset_list =
    (mat_of_rows_list (length sign_list) (map (\<lambda>i .(mtx_row sign_list i)) subset_list))"

definition alt_matrix_A:: "rat list list \<Rightarrow> nat list list \<Rightarrow> rat mat"
  where "alt_matrix_A signs subsets = (mat (length subsets) (length signs)
    (\<lambda>(i, j). z (subsets ! i) (signs ! j)))"

lemma alt_matrix_char: "alt_matrix_A signs subsets = matrix_A signs subsets"
proof -
  have h0: "(\<And>i j. i < length subsets \<Longrightarrow>
            j < length signs \<Longrightarrow>
            map (\<lambda>index_list. map (z index_list) signs) subsets ! i ! j = z (subsets ! i) (signs ! j))"
  proof -
    fix i
    fix j
    assume i_lt: "i < length subsets"
    assume j_lt: "j < length signs"
    show "((map (\<lambda>index_list. map (z index_list) signs) subsets) ! i) ! j = z (subsets ! i) (signs ! j)"
    proof -
      have h0: "(map (\<lambda>index_list. map (z index_list) signs) subsets) ! i =  map (z (subsets ! i)) signs"
        using nth_map i_lt
        by blast
      then show ?thesis using nth_map j_lt
        by simp
    qed
  qed
  have h: " mat (length subsets) (length signs) (\<lambda>(i, j). z (subsets ! i) (signs ! j)) =
    mat (length subsets) (length signs) (\<lambda>(i, y). map (\<lambda>index_list. map (z index_list) signs) subsets ! i ! y)"
    using h0 eq_matI[where A = "mat (length subsets) (length signs) (\<lambda>(i, j). z (subsets ! i) (signs ! j))",
        where B = "mat (length subsets) (length signs) (\<lambda>(i, y). map (\<lambda>index_list. map (z index_list) signs) subsets ! i ! y)"]
    by auto
  show ?thesis unfolding alt_matrix_A_def matrix_A_def mat_of_rows_list_def apply (auto) unfolding mtx_row_def
    using h   by blast
qed

lemma subsets_are_rows: "\<forall>i < (length subsets). row (alt_matrix_A signs subsets) i  = vec (length signs) (\<lambda>j. z (subsets ! i) (signs ! j))"
  unfolding row_def unfolding alt_matrix_A_def by auto

lemma signs_are_cols: "\<forall>i < (length signs). col (alt_matrix_A signs subsets) i  = vec (length subsets) (\<lambda>j. z (subsets ! j) (signs ! i))"
  unfolding col_def unfolding alt_matrix_A_def
  by auto

(* ith entry of LHS vector is the number of (distinct) real zeros of p where the Sturm_Tarski.sign vector of the qs  is the ith entry of Sturm_Tarski.signs.*)
definition construct_lhs_vector:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat list list  \<Rightarrow> rat vec"
  where "construct_lhs_vector p qs signs \<equiv>
  vec_of_list (map (\<lambda>w.  rat_of_int (int (length (filter (\<lambda>v. v = w) (map (consistent_sign_vec_copr qs) (characterize_root_list_p p)))))) signs)"

(* Putting all of the pieces of the construction together *)
definition satisfy_equation:: "real poly \<Rightarrow> real poly list \<Rightarrow> nat list list \<Rightarrow> rat list list \<Rightarrow> bool"
  where "satisfy_equation p qs subset_list sign_list =
        (mult_mat_vec (matrix_A sign_list subset_list) (construct_lhs_vector p qs sign_list) = (construct_rhs_vector p qs subset_list))"

section "Setting up the construction: Proofs"

(* Some matrix lemmas  *)
lemma row_mat_of_rows_list:
  assumes "list_all (\<lambda>r. length r = nc) rs"
  assumes "i < length rs"
  shows "row (mat_of_rows_list nc rs) i = vec_of_list (nth rs i)"
  by (smt assms(1) assms(2) dim_col_mat(1) dim_vec_of_list eq_vecI index_row(2) index_vec list_all_length mat_of_rows_list_def row_mat split_conv vec_of_list_index)

lemma mult_mat_vec_of_list:
  assumes "length ls = nc"
  assumes "list_all (\<lambda>r. length r = nc) rs"
  shows "mat_of_rows_list nc rs *\<^sub>v vec_of_list ls =
    vec_of_list (map (\<lambda>r. vec_of_list r \<bullet> vec_of_list ls) rs)"
  unfolding mult_mat_vec_def
  using row_mat_of_rows_list assms
  apply auto
  by (smt dim_row_mat(1) dim_vec dim_vec_of_list eq_vecI index_map_vec(1) index_map_vec(2) index_vec list_all_length mat_of_rows_list_def row_mat_of_rows_list vec_of_list_index)

lemma mtx_row_length:
  "list_all (\<lambda>r. length r = length signs) (map (mtx_row signs) ls)"
  apply (induction ls)
  by (auto simp add: mtx_row_def)

thm construct_lhs_vector_def
thm  poly_roots_finite

(* Recharacterize the LHS vector *)
lemma construct_lhs_vector_clean:
  assumes "p \<noteq> 0"
  assumes "i < length signs"
  shows "(construct_lhs_vector p qs signs) $ i =
    card {x. poly p x = 0 \<and> ((consistent_sign_vec_copr qs x) = (nth signs i))}"
proof -
  from poly_roots_finite[OF assms(1)] have "finite {x. poly p x = 0}" .
  then have eq: "(Collect
       ((\<lambda>v. v = signs ! i) \<circ>
        consistent_sign_vec_copr qs) \<inter>
      set (sorted_list_of_set
            {x. poly p x = 0})) =
    {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = signs ! i}"
    by auto
  show ?thesis
    unfolding construct_lhs_vector_def vec_of_list_index characterize_root_list_p_def
    apply auto
    apply (subst nth_map[OF assms(2)])
    apply auto
    apply (subst distinct_length_filter)
    using eq by auto
qed

lemma construct_lhs_vector_cleaner:
  assumes "p \<noteq> 0"
  shows "(construct_lhs_vector p qs signs) =
   vec_of_list (map (\<lambda>s. rat_of_int (card {x. poly p x = 0 \<and> ((consistent_sign_vec_copr qs x) = s)})) signs)"
  apply (rule eq_vecI)
  apply (auto simp add:  construct_lhs_vector_clean[OF assms] )
  apply (simp add: vec_of_list_index)
  unfolding construct_lhs_vector_def
  using assms construct_lhs_vector_clean construct_lhs_vector_def apply auto[1]
  by simp

(* Show that because our consistent Sturm_Tarski.sign vectors consist of 1 and -1's, z returns 1 or -1
  when applied to a consistent Sturm_Tarski.sign vector *)
lemma z_signs:
  assumes "list_all (\<lambda>i. i < length signs) I"
  assumes "list_all (\<lambda>s. s = 1 \<or> s = -1) signs"
  shows "(z I signs = 1) \<or> (z I signs = -1)" using assms
proof (induction I)
  case Nil
  then show ?case
    by (auto simp add:z_def)
next
  case (Cons a I)
  moreover have "signs ! a = 1 \<or> signs ! a = -1"
    by (metis (mono_tags, lifting) add_Suc_right calculation(2) calculation(3) gr0_conv_Suc list.size(4) list_all_length nth_Cons_0)
  ultimately show ?case
    by (auto simp add:z_def)
qed

lemma z_lemma:
  fixes I:: "nat list"
  fixes sign:: "rat list"
  assumes consistent: "sign \<in> set (characterize_consistent_signs_at_roots_copr p qs)"
  assumes welldefined: "list_constr I (length qs)"
  shows "(z I sign = 1) \<or> (z I sign = -1)"
proof (rule z_signs)
  have "length sign = length qs" using consistent
    by (auto simp add: characterize_consistent_signs_at_roots_copr_def consistent_sign_vec_copr_def)
  thus "list_all (\<lambda>i. i < length sign) I"
    using welldefined
    by (auto simp add: list_constr_def characterize_consistent_signs_at_roots_copr_def consistent_sign_vec_copr_def)
  show "list_all (\<lambda>s. s = 1 \<or> s = - 1) sign" using consistent
    apply (auto simp add: list.pred_map  characterize_consistent_signs_at_roots_copr_def  consistent_sign_vec_copr_def)
    using Ball_set
    by force
qed

(* Show that all consistent sign vectors on roots of polynomials are in characterize_consistent_signs_at_roots_copr  *)
lemma in_set:
  fixes p:: "real poly"
  assumes nonzero: "p\<noteq>0"
  fixes qs:: "real poly list"
  fixes I:: "nat list"
  fixes sign:: "rat list"
  fixes x:: "real"
  assumes root_p: "x \<in> {x. poly p x = 0}"
  assumes sign_fix: "sign = consistent_sign_vec_copr qs x"
  assumes welldefined: "list_constr I (length qs)"
  shows "sign \<in> set (characterize_consistent_signs_at_roots_copr p qs)"
proof -
  have h1: "consistent_sign_vec_copr qs x \<in>
      set (remdups (map (consistent_sign_vec_copr qs) (sorted_list_of_set {x. poly p x = 0})))"
    using root_p apply auto apply (subst set_sorted_list_of_set)
    using nonzero poly_roots_finite rsquarefree_def apply blast by auto
  thus ?thesis unfolding characterize_consistent_signs_at_roots_copr_def characterize_root_list_p_def using sign_fix
    by blast
qed

(* Since all of the polynomials in qs are relatively prime to p, products of subsets of these
    polynomials are also relatively prime to p  *)
lemma nonzero_product:
  fixes p:: "real poly"
  assumes nonzero: "p\<noteq>0"
  fixes qs:: "real poly list"
  assumes pairwise_rel_prime_1: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))"
  fixes I:: "nat list"
  fixes x:: "real"
  assumes root_p: "x \<in> {x. poly p x = 0}"
  assumes welldefined: "list_constr I (length qs)"
  shows "(poly (prod_list (retrieve_polys qs I)) x > 0) \<or> (poly (prod_list (retrieve_polys qs I)) x < 0)"
proof -
  have "\<And>x. x \<in> set (retrieve_polys qs I) \<Longrightarrow> coprime p x"
    unfolding retrieve_polys_def
    by (smt in_set_conv_nth in_set_member length_map list_all_length list_constr_def nth_map pairwise_rel_prime_1 welldefined)
  then have coprimeh: "coprime p (prod_list (retrieve_polys qs I))"
    using prod_list_coprime_right by auto
  thus ?thesis using root_p
    using coprime_poly_0 linorder_neqE_linordered_idom by blast
qed

(* The next few lemmas relate z to the signs of the product of subsets of polynomials of qs *)
lemma horiz_vector_helper_pos_ind:
  fixes p:: "real poly"
  assumes nonzero: "p\<noteq>0"
  fixes qs:: "real poly list"
  assumes pairwise_rel_prime_1: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))"
  fixes I:: "nat list"
  fixes sign:: "rat list"
  fixes x:: "real"
  assumes root_p: "x \<in> {x. poly p x = 0}"
  assumes sign_fix: "sign = consistent_sign_vec_copr qs x"
  shows "(list_constr I (length qs)) \<longrightarrow> (poly (prod_list (retrieve_polys qs I)) x > 0) \<longleftrightarrow> (z I sign = 1)"
proof (induct I)
  case Nil
  then show ?case
    by (simp add: retrieve_polys_def z_def)
next
  case (Cons a I)
  have welldef: "list_constr (a#I) (length qs) \<longrightarrow> (list_constr I (length qs))"
    unfolding list_constr_def list_all_def by auto
  have set_hyp: "list_constr I (length qs) \<longrightarrow> sign \<in> set (characterize_consistent_signs_at_roots_copr p qs)"
    using in_set using nonzero root_p sign_fix by blast
  have z_hyp: "list_constr I (length qs) \<longrightarrow> ((z I sign = 1) \<or> (z I sign = -1))"
    using set_hyp z_lemma[where sign="sign", where I = "I", where p="p", where qs="qs"] by blast
  have sign_hyp: "sign = map (\<lambda> q. if (poly q x > 0) then 1 else -1) qs"
    using sign_fix unfolding consistent_sign_vec_copr_def by blast
  have ind_hyp_1: "list_constr (a#I) (length qs) \<longrightarrow>
    ((0 < poly (prod_list (retrieve_polys qs I)) x) = (z I sign = 1))"
    using welldef Cons.hyps by auto
  have ind_hyp_2: "list_constr (a#I) (length qs) \<longrightarrow>
    ((0 > poly (prod_list (retrieve_polys qs I)) x) = (z I sign = -1))"
    using welldef z_hyp Cons.hyps nonzero_product
    using pairwise_rel_prime_1 nonzero root_p by auto
  have h1: "prod_list (retrieve_polys qs (a # I)) = (nth qs a)*(prod_list (retrieve_polys qs I))"
    by (simp add: retrieve_polys_def)
  have h2: "(z (a # I) sign) = (nth sign a)*(z I sign)"
    by (metis (mono_tags, opaque_lifting) list.simps(9) prod_list.Cons z_def)
  have h3help: "list_constr (a#I) (length qs) \<longrightarrow> a < length qs" unfolding list_constr_def
    by simp
  then have h3: "list_constr (a#I) (length qs) \<longrightarrow>
    ((nth sign a) = (if (poly (nth qs a) x > 0) then 1 else -1))"
    using nth_map sign_hyp by auto
  have h2: "(0 < poly ((nth qs a)*(prod_list (retrieve_polys qs I))) x) \<longleftrightarrow>
    ((0 < poly (nth qs a) x \<and> (0 < poly (prod_list (retrieve_polys qs I)) x)) \<or>
   (0 > poly (nth qs a) x \<and> (0 > poly (prod_list (retrieve_polys qs I)) x)))"
    by (simp add: zero_less_mult_iff)
  have final_hyp_a: "list_constr (a#I) (length qs) \<longrightarrow> (((0 < poly (nth qs a) x \<and> (0 < poly (prod_list (retrieve_polys qs I)) x))
    \<or> (0 > poly (nth qs a) x \<and> (0 > poly (prod_list (retrieve_polys qs I)) x))) =
    ((nth sign a)*(z I sign) = 1))"
  proof -
    have extra_hyp_a: "list_constr (a#I) (length qs) \<longrightarrow> (0 < poly (nth qs a) x = ((nth sign a) = 1))" using h3
      by simp
    have extra_hyp_b: "list_constr (a#I) (length qs) \<longrightarrow>  (0 > poly (nth qs a) x = ((nth sign a) = -1))"
      using h3 apply (auto) using coprime_poly_0 h3help in_set_member nth_mem pairwise_rel_prime_1 root_p by fastforce
    have ind_hyp_1: "list_constr (a#I) (length qs) \<longrightarrow> (((0 < poly (nth qs a) x \<and> (z I sign = 1)) \<or>
    (0 > poly (nth qs a) x \<and> (z I sign = -1)))
      = ((nth sign a)*(z I sign) = 1))" using extra_hyp_a extra_hyp_b
      using zmult_eq_1_iff
      by (simp add: h3)
    then show ?thesis
      using ind_hyp_1 ind_hyp_2 by (simp add: Cons.hyps welldef)
  qed
  then show ?case
    using h1 z_def by (simp add: zero_less_mult_iff)
qed

lemma horiz_vector_helper_pos:
  fixes p:: "real poly"
  assumes nonzero: "p\<noteq>0"
  fixes qs:: "real poly list"
  assumes pairwise_rel_prime_1: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))"
  fixes I:: "nat list"
  fixes sign:: "rat list"
  fixes x:: "real"
  assumes root_p: "x \<in> {x. poly p x = 0}"
  assumes sign_fix: "sign = consistent_sign_vec_copr qs x"
  assumes welldefined: "list_constr I (length qs)"
  shows "(poly (prod_list (retrieve_polys qs I)) x > 0) \<longleftrightarrow> (z I sign = 1)"
  using horiz_vector_helper_pos_ind
  using pairwise_rel_prime_1 nonzero  root_p sign_fix welldefined by blast

lemma horiz_vector_helper_neg:
  fixes p:: "real poly"
  assumes nonzero: "p\<noteq>0"
  fixes qs:: "real poly list"
  assumes pairwise_rel_prime_1: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))"
  fixes I:: "nat list"
  fixes sign:: "rat list"
  fixes x:: "real"
  assumes root_p: "x \<in> {x. poly p x = 0}"
  assumes sign_fix: "sign = consistent_sign_vec_copr qs x"
  assumes welldefined: "list_constr I (length qs)"
  shows "(poly (prod_list (retrieve_polys qs I)) x < 0) \<longleftrightarrow> (z I sign = -1)"
proof -
  have set_hyp: "list_constr I (length qs) \<longrightarrow> sign \<in> set (characterize_consistent_signs_at_roots_copr p qs)"
    using in_set using nonzero root_p sign_fix by blast
  have z_hyp: "list_constr I (length qs) \<longrightarrow> ((z I sign = 1) \<or> (z I sign = -1))"
    using set_hyp  z_lemma[where sign="sign", where I = "I", where p="p", where qs="qs"] by blast
  have poly_hyp: "(poly (prod_list (retrieve_polys qs I)) x > 0) \<or> (poly (prod_list (retrieve_polys qs I)) x < 0)"
    using nonzero_product
    using pairwise_rel_prime_1 nonzero root_p
    using welldefined by blast
  have pos_hyp: "(poly (prod_list (retrieve_polys qs I)) x > 0) \<longleftrightarrow> (z I sign = 1)" using horiz_vector_helper_pos
    using pairwise_rel_prime_1 nonzero root_p sign_fix welldefined by blast
  show ?thesis using z_hyp poly_hyp pos_hyp apply (auto)
    using welldefined by blast
qed

(* Recharacterize the dot product *)
lemma vec_of_list_dot_rewrite:
  assumes "length xs = length ys"
  shows "vec_of_list xs \<bullet> vec_of_list ys =
    sum_list (map2 (*) xs ys)"
  using assms
proof (induction xs arbitrary:ys)
  case Nil
  then show ?case by auto
next
  case (Cons a xs)
  then show ?case apply auto
    by (smt (verit, best) Suc_length_conv list.simps(9) old.prod.case scalar_prod_vCons sum_list.Cons vec_of_list_Cons zip_Cons_Cons)
qed

lemma lhs_dot_rewrite:
  fixes p:: "real poly"
  fixes qs:: "real poly list"
  fixes I:: "nat list"
  fixes signs:: "rat list list"
  assumes nonzero: "p\<noteq>0"
  shows
    "(vec_of_list (mtx_row signs I) \<bullet> (construct_lhs_vector p qs signs)) =
   sum_list (map (\<lambda>s. (z I s)  *  rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) signs)"
proof -
  have "p \<noteq> 0" using nonzero by auto
  from construct_lhs_vector_cleaner[OF this]
  have rhseq: "construct_lhs_vector p qs signs =
    vec_of_list
    (map (\<lambda>s. rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) signs)" by auto
  have "(vec_of_list (mtx_row signs I) \<bullet> (construct_lhs_vector p qs signs)) =
    sum_list (map2 (*) (mtx_row signs I) (map (\<lambda>s. rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) signs))"
    unfolding rhseq
    apply (intro vec_of_list_dot_rewrite)
    by (auto simp add: mtx_row_def)
  thus ?thesis unfolding mtx_row_def
    using map2_map_map
    by (auto simp add: map2_map_map)
qed

lemma sum_list_distinct_filter:
  fixes f:: "'a \<Rightarrow> int"
  assumes "distinct xs" "distinct ys"
  assumes "set ys \<subseteq> set xs"
  assumes "\<And>x. x \<in> set xs - set ys \<Longrightarrow> f x = 0"
  shows "sum_list (map f xs) = sum_list (map f ys)"
  by (metis List.finite_set assms(1) assms(2) assms(3) assms(4) sum.mono_neutral_cong_left sum_list_distinct_conv_sum_set)

(* If we have a superset of the signs, we can drop to just the consistent ones *)
lemma construct_lhs_vector_drop_consistent:
  fixes p:: "real poly"
  fixes qs:: "real poly list"
  fixes I:: "nat list"
  fixes signs:: "rat list list"
  assumes nonzero: "p\<noteq>0"
  assumes distinct_signs: "distinct signs"
  assumes all_info: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(signs)"
  assumes welldefined: "list_constr I (length qs)"
  shows
    "(vec_of_list (mtx_row signs I) \<bullet> (construct_lhs_vector p qs signs)) =
     (vec_of_list (mtx_row (characterize_consistent_signs_at_roots_copr p qs) I) \<bullet>
      (construct_lhs_vector p qs (characterize_consistent_signs_at_roots_copr p qs)))"
proof -
  have h0: "\<forall> sgn. sgn \<in> set signs \<and> sgn \<notin> consistent_sign_vec_copr qs ` set (characterize_root_list_p p) \<and> 0 < rat_of_nat (card
                  {xa. poly p xa = 0 \<and> consistent_sign_vec_copr qs xa = sgn}) \<longrightarrow> z I sgn = 0"
  proof -
    have "\<forall> sgn. sgn \<in> set signs \<and> sgn \<notin> consistent_sign_vec_copr qs ` set (characterize_root_list_p p) \<and> 0 < rat_of_int (card
                  {xa. poly p xa = 0 \<and> consistent_sign_vec_copr qs xa = sgn}) \<longrightarrow> {xa. poly p xa = 0 \<and> consistent_sign_vec_copr qs xa = sgn} \<noteq> {}"
      by fastforce
    then show ?thesis
    proof -
      { fix iis :: "rat list"
        have ff1: "0 \<noteq> p"
          using nonzero rsquarefree_def by blast
        obtain rr :: "(real \<Rightarrow> bool) \<Rightarrow> real" where
          ff2: "\<And>p. p (rr p) \<or> Collect p = {}"
          by moura
        { assume "\<exists>is. is = iis \<and> {r. poly p r = 0 \<and> consistent_sign_vec_copr qs r = is} \<noteq> {}"
          then have "\<exists>is. consistent_sign_vec_copr qs (rr (\<lambda>r. poly p r = 0 \<and> consistent_sign_vec_copr qs r = is)) = iis \<and> {r. poly p r = 0 \<and> consistent_sign_vec_copr qs r = is} \<noteq> {}"
            using ff2
            by (metis (mono_tags, lifting))
          then have "\<exists>r. poly p r = 0 \<and> consistent_sign_vec_copr qs r = iis"
            using ff2 by smt
          then have "iis \<in> consistent_sign_vec_copr qs ` set (sorted_list_of_set {r. poly p r = 0})"
            using ff1 poly_roots_finite by fastforce }
        then have "iis \<notin> set signs \<or> iis \<in> consistent_sign_vec_copr qs ` set (characterize_root_list_p p) \<or> \<not> 0 < rat_of_int (int (card {r. poly p r = 0 \<and> consistent_sign_vec_copr qs r = iis}))"
          by (metis (no_types) \<open>\<forall>sgn. sgn \<in> set signs \<and> sgn \<notin> consistent_sign_vec_copr qs ` set (characterize_root_list_p p) \<and> 0 < rat_of_int (int (card {xa. poly p xa = 0 \<and> consistent_sign_vec_copr qs xa = sgn})) \<longrightarrow> {xa. poly p xa = 0 \<and> consistent_sign_vec_copr qs xa = sgn} \<noteq> {}\<close> characterize_root_list_p_def) }
      then show ?thesis
        by fastforce
    qed
  qed
  then have "\<forall> sgn. sgn \<in> set signs \<and> sgn \<notin> consistent_sign_vec_copr qs ` set (characterize_root_list_p p) \<longrightarrow> ((0 = rat_of_nat (card
                  {xa. poly p xa = 0 \<and> consistent_sign_vec_copr qs xa = sgn}) \<or> z I sgn = 0))"
    by auto
  then have hyp: "\<forall> s. s \<in> set signs \<and> s \<notin> consistent_sign_vec_copr qs ` set (characterize_root_list_p p) \<longrightarrow> (z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}) = 0)"
    by auto
  then have "(\<Sum>s\<in> set(signs). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) =
        (\<Sum>s\<in>(set (signs) \<inter> (consistent_sign_vec_copr qs ` set (characterize_root_list_p p))). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))"
  proof -
    have "set(signs) =(set (signs) \<inter> (consistent_sign_vec_copr qs ` set (characterize_root_list_p p))) \<union>
              (set(signs)-(consistent_sign_vec_copr qs ` set (characterize_root_list_p p)))"
      by blast
    then have sum_rewrite: "(\<Sum>s\<in> set(signs). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) =
          (\<Sum>s\<in> (set (signs) \<inter> (consistent_sign_vec_copr qs ` set (characterize_root_list_p p))) \<union>
              (set(signs)-(consistent_sign_vec_copr qs ` set (characterize_root_list_p p))). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))"
      by auto
    then have sum_split: "(\<Sum>s\<in> (set (signs) \<inter> (consistent_sign_vec_copr qs ` set (characterize_root_list_p p))) \<union>
              (set(signs)-(consistent_sign_vec_copr qs ` set (characterize_root_list_p p))). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))
          =
(\<Sum>s\<in> (set (signs) \<inter> (consistent_sign_vec_copr qs ` set (characterize_root_list_p p))). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))
+ (\<Sum>s\<in> (set(signs)-(consistent_sign_vec_copr qs ` set (characterize_root_list_p p))). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))"
      by (metis (no_types, lifting) List.finite_set sum.Int_Diff)
    have sum_zero: "(\<Sum>s\<in> (set(signs)-(consistent_sign_vec_copr qs ` set (characterize_root_list_p p))). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) = 0"
      using hyp
      by (simp add: hyp)
    show ?thesis using sum_rewrite sum_split sum_zero by linarith
  qed
  then have set_eq: "set (remdups
           (map (consistent_sign_vec_copr qs)
             (characterize_root_list_p p))) = set (signs) \<inter> (consistent_sign_vec_copr qs ` set (characterize_root_list_p p))"
    using all_info
    by (simp add: characterize_consistent_signs_at_roots_copr_def subset_antisym)
  have hyp1: "(\<Sum>s\<leftarrow>signs. z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) =
        (\<Sum>s\<in>set (signs). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))"
    using distinct_signs sum_list_distinct_conv_sum_set by blast
  have hyp2: "(\<Sum>s\<leftarrow>remdups
           (map (consistent_sign_vec_copr qs)
             (characterize_root_list_p p)). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))
  = (\<Sum>s\<in> set (remdups
           (map (consistent_sign_vec_copr qs)
             (characterize_root_list_p p))). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))"
    using sum_list_distinct_conv_sum_set by blast
  have set_sum_eq: "(\<Sum>s\<in>(set (signs) \<inter> (consistent_sign_vec_copr qs ` set (characterize_root_list_p p))). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) =
    (\<Sum>s\<in> set (remdups
           (map (consistent_sign_vec_copr qs)
             (characterize_root_list_p p))). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))"
    using set_eq by auto
  then have "(\<Sum>s\<leftarrow>signs. z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) =
    (\<Sum>s\<leftarrow>remdups
           (map (consistent_sign_vec_copr qs)
             (characterize_root_list_p p)). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))"
    using set_sum_eq hyp1 hyp2
    using \<open>(\<Sum>s\<in>set signs. z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) = (\<Sum>s\<in>set signs \<inter> consistent_sign_vec_copr qs ` set (characterize_root_list_p p). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))\<close> by linarith
  then have "consistent_sign_vec_copr qs ` set (characterize_root_list_p p) \<subseteq> set signs \<Longrightarrow>
    (\<And>p qss.
        characterize_consistent_signs_at_roots_copr p qss =
        remdups (map (consistent_sign_vec_copr qss) (characterize_root_list_p p))) \<Longrightarrow>
    (\<Sum>s\<leftarrow>signs. z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) =
    (\<Sum>s\<leftarrow>remdups
           (map (consistent_sign_vec_copr qs)
             (characterize_root_list_p p)). z I s * rat_of_nat (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))"
    by linarith
  then show ?thesis  unfolding lhs_dot_rewrite[OF nonzero]
    apply (auto intro!: sum_list_distinct_filter simp add: distinct_signs  characterize_consistent_signs_at_roots_copr_def)
    using all_info characterize_consistent_signs_at_roots_copr_def by auto[1]
qed

(* Both matrix_equation_helper_step and matrix_equation_main_step relate the matrix construction
   to the Tarski queries, i.e. relate the product of a row of the matrix and the LHS vector to a
   Tarski query on the RHS *)
lemma matrix_equation_helper_step:
  fixes p:: "real poly"
  fixes qs:: "real poly list"
  fixes I:: "nat list"
  fixes signs:: "rat list list"
  assumes nonzero: "p\<noteq>0"
  assumes distinct_signs: "distinct signs"
  assumes all_info: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(signs)"
  assumes welldefined: "list_constr I (length qs)"
  assumes pairwise_rel_prime_1: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))"
  shows "(vec_of_list (mtx_row signs I) \<bullet> (construct_lhs_vector p qs signs)) =
   rat_of_int (card {x. poly p x = 0 \<and> poly (prod_list (retrieve_polys qs I)) x > 0}) -
   rat_of_int (card {x. poly p x = 0 \<and> poly (prod_list (retrieve_polys qs I)) x < 0})"
proof -
  have "finite (set (map (consistent_sign_vec_copr qs)  (characterize_root_list_p p)))" by auto
  let ?gt = "(set (map (consistent_sign_vec_copr qs)  (characterize_root_list_p p)) \<inter> {s. z I s = 1})"
  let ?lt = "  (set (map (consistent_sign_vec_copr qs)  (characterize_root_list_p p)) \<inter> {s. z I s = -1})"
  have eq: "set (map (consistent_sign_vec_copr qs)  (characterize_root_list_p p)) = ?gt \<union> ?lt"
    apply auto
    by (metis characterize_root_list_p_def horiz_vector_helper_neg horiz_vector_helper_pos_ind nonzero nonzero_product pairwise_rel_prime_1 poly_roots_finite sorted_list_of_set(1) welldefined)
      (* First, drop the signs that are irrelevant *)
  from construct_lhs_vector_drop_consistent[OF assms(1-4)] have
    "vec_of_list (mtx_row signs I) \<bullet> construct_lhs_vector p qs signs =
  vec_of_list (mtx_row (characterize_consistent_signs_at_roots_copr p qs) I) \<bullet>
  construct_lhs_vector p qs (characterize_consistent_signs_at_roots_copr p qs)" .
    (* Now we split the sum *)
  from lhs_dot_rewrite[OF assms(1)]
  moreover have "... =
  (\<Sum>s\<leftarrow>characterize_consistent_signs_at_roots_copr p qs.
    z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))" .
  moreover have "... =
  (\<Sum>s\<in>set (map (consistent_sign_vec_copr qs)  (characterize_root_list_p p)).
    z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))" unfolding characterize_consistent_signs_at_roots_copr_def sum_code[symmetric]
    by (auto)
  ultimately have "... =
  (\<Sum>s\<in>?gt. z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) +
  (\<Sum>s\<in>?lt. z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))"
    apply (subst eq)
    apply (rule sum.union_disjoint)
    by auto
      (* Now recharacterize lt, gt*)
  have setroots: "set (characterize_root_list_p p) = {x. poly p x = 0}" unfolding characterize_root_list_p_def
    using poly_roots_finite nonzero rsquarefree_def set_sorted_list_of_set by blast
  have *: "\<And>s. {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s} =
        {x \<in>{x. poly p x = 0}. consistent_sign_vec_copr qs x = s}"
    by auto
  have lem_e1: "\<And>x. x \<in> {x. poly p x = 0} \<Longrightarrow>
       card
        {s \<in> consistent_sign_vec_copr  qs ` {x. poly p x = 0} \<inter> {s. z I s = 1}.
         consistent_sign_vec_copr qs x = s} =
       (if 0 < poly (prod_list (retrieve_polys qs I)) x then 1 else 0)"
  proof -
    fix x
    assume rt: "x \<in> {x. poly p x = 0}"
    then have 1: "{s \<in> consistent_sign_vec_copr qs ` {x. poly p x = 0} \<inter> {s. z I s = 1}. consistent_sign_vec_copr qs x = s} =
      {s. z I s = 1 \<and> consistent_sign_vec_copr qs x = s}"
      by auto
    from horiz_vector_helper_pos[OF assms(1) assms(5) rt]
    have 2: "... = {s. (0 < poly (prod_list (retrieve_polys qs I)) x)  \<and> consistent_sign_vec_copr qs x = s}"
      using welldefined by blast
    have 3: "... = (if (0 < poly (prod_list (retrieve_polys qs I)) x)  then {consistent_sign_vec_copr qs x} else {})"
      by auto
    thus "card {s \<in> consistent_sign_vec_copr qs ` {x. poly p x = 0} \<inter> {s. z I s = 1}. consistent_sign_vec_copr qs x = s} =
         (if 0 < poly (prod_list (retrieve_polys qs I)) x then 1 else 0) " using 1 2 3 by auto
  qed
  have e1: "(\<Sum>s\<in>consistent_sign_vec_copr qs ` {x. poly p x = 0} \<inter> {s. z I s = 1}.
       card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}) =
     (sum (\<lambda>x. if (poly (prod_list (retrieve_polys qs I)) x) > 0 then 1 else 0) {x. poly p x = 0})"
    unfolding * apply (rule sum_multicount_gen)
    using \<open>finite (set (map (consistent_sign_vec_copr qs) (characterize_root_list_p p)))\<close> setroots apply auto[1]
    apply (metis List.finite_set setroots)
    using lem_e1 by auto
  have gtchr: "(\<Sum>s\<in>?gt. z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) =
    rat_of_int (card {x. poly p x = 0 \<and> 0 < poly (prod_list (retrieve_polys qs I)) x})"
    apply (auto simp add: setroots)
    apply (subst of_nat_sum[symmetric])
    apply (subst of_nat_eq_iff)
    apply (subst e1)
    apply (subst card_eq_sum)
    apply (rule sum.mono_neutral_cong_right)
    apply (metis List.finite_set setroots)
    by auto
  have lem_e2: "\<And>x. x \<in> {x. poly p x = 0} \<Longrightarrow>
       card
        {s \<in> consistent_sign_vec_copr  qs ` {x. poly p x = 0} \<inter> {s. z I s = -1}.
         consistent_sign_vec_copr qs x = s} =
       (if poly (prod_list (retrieve_polys qs I)) x < 0 then 1 else 0)"
  proof -
    fix x
    assume rt: "x \<in> {x. poly p x = 0}"
    then have 1: "{s \<in> consistent_sign_vec_copr qs ` {x. poly p x = 0} \<inter> {s. z I s = -1}. consistent_sign_vec_copr qs x = s} =
      {s. z I s = -1 \<and> consistent_sign_vec_copr qs x = s}"
      by auto
    from horiz_vector_helper_neg[OF assms(1) assms(5) rt]
    have 2: "... = {s. (0 > poly (prod_list (retrieve_polys qs I)) x)  \<and> consistent_sign_vec_copr qs x = s}"
      using welldefined by blast
    have 3: "... = (if (0 > poly (prod_list (retrieve_polys qs I)) x)  then {consistent_sign_vec_copr qs x} else {})"
      by auto
    thus "card {s \<in> consistent_sign_vec_copr qs ` {x. poly p x = 0} \<inter> {s. z I s = -1}. consistent_sign_vec_copr qs x = s} =
       (if poly (prod_list (retrieve_polys qs I)) x < 0 then 1 else 0)" using 1 2 3 by auto
  qed
  have e2: " (\<Sum>s\<in>consistent_sign_vec_copr qs ` {x. poly p x = 0} \<inter> {s. z I s = - 1}.
       card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}) =
     (sum (\<lambda>x. if (poly (prod_list (retrieve_polys qs I)) x) < 0 then 1 else 0) {x. poly p x = 0})"
    unfolding * apply (rule sum_multicount_gen)
    using \<open>finite (set (map (consistent_sign_vec_copr qs) (characterize_root_list_p p)))\<close> setroots apply auto[1]
     apply (metis List.finite_set setroots)
    using lem_e2 by auto
  have ltchr: "(\<Sum>s\<in>?lt. z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) =
    - rat_of_int (card {x. poly p x = 0 \<and> 0 > poly (prod_list (retrieve_polys qs I)) x})"
    apply (auto simp add: setroots sum_negf)
    apply (subst of_nat_sum[symmetric])
    apply (subst of_nat_eq_iff)
    apply (subst e2)
    apply (subst card_eq_sum)
    apply (rule sum.mono_neutral_cong_right)
       apply (metis List.finite_set setroots)
    by auto
  show ?thesis using gtchr ltchr
    using \<open>(\<Sum>s\<in>set (map (consistent_sign_vec_copr qs) (characterize_root_list_p p)). z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) = (\<Sum>s\<in>set (map (consistent_sign_vec_copr qs) (characterize_root_list_p p)) \<inter> {s. z I s = 1}. z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) + (\<Sum>s\<in>set (map (consistent_sign_vec_copr qs) (characterize_root_list_p p)) \<inter> {s. z I s = - 1}. z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))\<close> \<open>(\<Sum>s\<leftarrow>characterize_consistent_signs_at_roots_copr p qs. z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s})) = (\<Sum>s\<in>set (map (consistent_sign_vec_copr qs) (characterize_root_list_p p)). z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))\<close> \<open>vec_of_list (mtx_row (characterize_consistent_signs_at_roots_copr p qs) I) \<bullet> construct_lhs_vector p qs (characterize_consistent_signs_at_roots_copr p qs) = (\<Sum>s\<leftarrow>characterize_consistent_signs_at_roots_copr p qs. z I s * rat_of_int (card {x. poly p x = 0 \<and> consistent_sign_vec_copr qs x = s}))\<close> \<open>vec_of_list (mtx_row signs I) \<bullet> construct_lhs_vector p qs signs = vec_of_list (mtx_row (characterize_consistent_signs_at_roots_copr p qs) I) \<bullet> construct_lhs_vector p qs (characterize_consistent_signs_at_roots_copr p qs)\<close>
    by linarith
qed

(* A clean restatement of the helper lemma *)
lemma matrix_equation_main_step:
  fixes p:: "real poly"
  fixes qs:: "real poly list"
  fixes I:: "nat list"
  fixes signs:: "rat list list"
  assumes nonzero: "p\<noteq>0"
  assumes distinct_signs: "distinct signs"
  assumes all_info: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(signs)"
  assumes welldefined: "list_constr I (length qs)"
  assumes pairwise_rel_prime_1: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))"
  shows "(vec_of_list (mtx_row signs I) \<bullet> (construct_lhs_vector p qs signs)) =
    construct_NofI p (retrieve_polys qs I)"
    unfolding construct_NofI_prop[OF nonzero]
    using matrix_equation_helper_step[OF assms]
    by linarith

lemma map_vec_vec_of_list_eq_intro:
  assumes "map f xs = map g ys"
  shows "map_vec f (vec_of_list xs) = map_vec g (vec_of_list ys)"
  by (metis assms vec_of_list_map)

(* Shows that as long as we have a "basis" of sign assignments (see assumptions all_info, welldefined),
  and some other mild assumptions on our inputs (given in nonzero, distinct_signs, pairwise_rel_prime),
  the construction will be satisfied *)
theorem matrix_equation:
  fixes p:: "real poly"
  fixes qs:: "real poly list"
  fixes subsets:: "nat list list"
  fixes signs:: "rat list list"
  assumes nonzero: "p\<noteq>0"
  assumes distinct_signs: "distinct signs"
  assumes all_info: "set (characterize_consistent_signs_at_roots_copr p qs) \<subseteq> set(signs)"
  assumes pairwise_rel_prime: "\<forall>q. ((List.member qs q) \<longrightarrow> (coprime p q))"
  assumes welldefined: "all_list_constr (subsets) (length qs)"
  shows "satisfy_equation p qs subsets signs"
  unfolding satisfy_equation_def matrix_A_def
    construct_lhs_vector_def construct_rhs_vector_def all_list_constr_def
  apply (subst mult_mat_vec_of_list)
    apply (auto simp add: mtx_row_length intro!: map_vec_vec_of_list_eq_intro)
  using matrix_equation_main_step[OF assms(1-3) _ assms(4), unfolded construct_lhs_vector_def]
  using all_list_constr_def in_set_member welldefined by fastforce

(* Prettifying some theorems*)
definition roots:: "real poly \<Rightarrow> real set"
  where "roots p = {x. poly p x = 0}"

definition sgn::"'a::linordered_field \<Rightarrow> rat"
  where "sgn x = (if x > 0 then 1
                  else if x < 0 then -1
                  else 0)"

definition sgn_vec::"real poly list \<Rightarrow> real \<Rightarrow> rat list"
  where "sgn_vec qs x \<equiv>  map (sgn \<circ> (\<lambda>q. poly q x)) qs"

definition consistent_signs_at_roots:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat list set"
  where "consistent_signs_at_roots p qs =
    (sgn_vec qs) ` (roots p)"

lemma consistent_signs_at_roots_eq:
  assumes "p \<noteq> 0"
  shows "consistent_signs_at_roots p qs =
         set (characterize_consistent_signs_at_roots p qs)"
  unfolding consistent_signs_at_roots_def characterize_consistent_signs_at_roots_def
    characterize_root_list_p_def
  apply auto
  apply (subst set_sorted_list_of_set)
  using assms poly_roots_finite apply blast
  unfolding sgn_vec_def sgn_def signs_at_def squash_def o_def
  using roots_def apply auto[1]
  by (smt Collect_cong assms image_iff poly_roots_finite roots_def sorted_list_of_set(1))

abbreviation w_vec:: "real poly \<Rightarrow> real poly list \<Rightarrow> rat list list  \<Rightarrow> rat vec"
  where "w_vec \<equiv> construct_lhs_vector"

abbreviation v_vec:: "real poly \<Rightarrow> real poly list \<Rightarrow> nat list list \<Rightarrow> rat vec"
  where "v_vec \<equiv> construct_rhs_vector"

abbreviation M_mat:: "rat list list \<Rightarrow> nat list list \<Rightarrow> rat mat"
  where "M_mat \<equiv> matrix_A"

theorem matrix_equation_pretty:
  assumes "p\<noteq>0"
  assumes "\<And>q. q \<in> set qs \<Longrightarrow> coprime p q"
  assumes "distinct signs"
  assumes "consistent_signs_at_roots p qs \<subseteq> set signs"
  assumes "\<And>l i. l \<in> set subsets \<Longrightarrow> i \<in> set l \<Longrightarrow> i < length qs"
  shows "M_mat signs subsets *\<^sub>v w_vec p qs signs = v_vec p qs subsets"
  unfolding satisfy_equation_def[symmetric]
  apply (rule matrix_equation[OF assms(1) assms(3)])
  apply (metis assms(1) assms(2) assms(4) consistent_signs_at_roots_eq csa_list_copr_rel member_def)
  apply (simp add: assms(2) in_set_member)
  using Ball_set all_list_constr_def assms(5) list_constr_def member_def by fastforce

end