theory ConcreteSemantics10_1_Def_Init_Small
  imports Main "~~/src/HOL/IMP/Vars" "~~/src/HOL/IMP/Star" "~~/src/HOL/IMP/Def_Init_Exp"  "~~/src/HOL/IMP/Def_Init"
begin

subsection "Initialization-Sensitive Small Step Semantics"
inductive
  small_step :: "(com \<times> state) \<Rightarrow> (com \<times> state) \<Rightarrow> bool" (infix "\<rightarrow>" 55)
where
Assign:  "aval a s = Some i \<Longrightarrow> (x ::= a, s) \<rightarrow> (SKIP, s(x := Some i))" |

Seq1:   "(SKIP;;c,s) \<rightarrow> (c,s)" |
Seq2:   "(c\<^sub>1,s) \<rightarrow> (c\<^sub>1',s') \<Longrightarrow> (c\<^sub>1;;c\<^sub>2,s) \<rightarrow> (c\<^sub>1';;c\<^sub>2,s')" |

IfTrue:  "bval b s = Some True \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>1,s)" |
IfFalse: "bval b s = Some False \<Longrightarrow> (IF b THEN c\<^sub>1 ELSE c\<^sub>2,s) \<rightarrow> (c\<^sub>2,s)" |

While:   "(WHILE b DO c,s) \<rightarrow> (IF b THEN c;; WHILE b DO c ELSE SKIP,s)"

lemmas small_step_induct = small_step.induct[split_format(complete)]

abbreviation small_steps :: "com * state \<Rightarrow> com * state \<Rightarrow> bool" (infix "\<rightarrow>*" 55)
where "x \<rightarrow>* y == star small_step x y"

subsection "Soundness wrt Small Steps"

(* Lemma 10.3 (D is increasing).*)
lemma D_increase: "D A c A' \<Longrightarrow> A \<subseteq> A'"
  by (simp add: D_incr)

theorem progress:
  "D (dom s) c A' \<Longrightarrow> c \<noteq> SKIP \<Longrightarrow> \<exists>cs'. (c,s) \<rightarrow> cs'"
proof(induction c arbitrary: s A')
  case SKIP
  then show ?case by simp
next
  case (Assign x1 x2)
  then show ?case by auto (metis aval_Some small_step.Assign)
next
  case (Seq c1 c2)
  then show ?case by (fastforce intro: small_step.intros)
next
  case (If x1 c1 c2)
  then obtain bv where "bval x1 s = Some bv" by (auto dest!:bval_Some)
  then show ?case
    by (metis (full_types) IfFalse IfTrue)
next
  case (While x1 c)
  then show ?case
    by (meson small_step.While)
qed
(*
proof(induction arbitrary: s A' rule: D.induct)
case (Skip A)
  then show ?case
    by simp
next
  case (Assign a A x)
  then obtain i where "aval a s = Some i" sorry
  then show ?case
    using small_step.Assign by blast
next
  case (Seq A\<^sub>1 c\<^sub>1 A\<^sub>2 c\<^sub>2 A\<^sub>3)
  then show ?case
    using Seq1 Seq2 by fastforce
next
  case (If b A c\<^sub>1 A\<^sub>1 c\<^sub>2 A\<^sub>2)
  then obtain bv where "bval b s = Some bv" sorry
  then show ?case
    by (metis (full_types) IfFalse IfTrue)
next
case (While b A c A')
  then show ?case
    by (meson small_step.While)
qed*)

lemma D_mono:  "D A c M \<Longrightarrow> A \<subseteq> A' \<Longrightarrow> \<exists>M'. D A' c M' & M <= M'"
proof(induction c arbitrary: A A' M)
case SKIP
  then show ?case by (fastforce intro: D.Skip)
next
  case (Assign x1 x2)
  then show ?case by (fastforce intro: D.Assign)
next
  case (Seq c1 c2)
  then show ?case by auto (metis D.intros(3))
(*by (fastforce intro: D.Seq)*)
next
  case (If x1 c1 c2)
(*
 1. \<And>x1 c1 c2 A A' M.
       (\<And>A A' M. D A c1 M \<Longrightarrow> A \<subseteq> A' \<Longrightarrow> \<exists>M'. D A' c1 M' \<and> M \<subseteq> M') \<Longrightarrow>
       (\<And>A A' M. D A c2 M \<Longrightarrow> A \<subseteq> A' \<Longrightarrow> \<exists>M'. D A' c2 M' \<and> M \<subseteq> M') \<Longrightarrow>
       D A (IF x1 THEN c1 ELSE c2) M \<Longrightarrow> A \<subseteq> A' \<Longrightarrow> \<exists>M'. D A' (IF x1 THEN c1 ELSE c2) M' \<and> M \<subseteq> M'
*)
  then obtain M1 M2 where "vars x1 \<subseteq> A" "D A c1 M1" "D A c2 M2" "M = M1 \<inter> M2"
    by blast
(* use IH Mx to  Mx' and A to A'*)
  then obtain M1' M2' where "D A' c1 M1'" "D A' c2 M2'"  "M1 \<subseteq> M1'" "M2 \<subseteq> M2'"
    by (meson If.IH(1) If.IH(2) If.prems(2))
(*  then have "D A (IF x1 THEN c1 ELSE c2) M"
    using If.prems(1) by blast*)
  then have "D A' (IF x1 THEN c1 ELSE c2) (M1' \<inter> M2')" "M \<subseteq> M1' \<inter> M2'" sledgehammer
    using \<open>vars x1 \<subseteq> A\<close> \<open>A \<subseteq> A'\<close> \<open>M = M1 \<inter> M2\<close> by(fastforce intro: D.intros)+
(*    using D.If If.prems(2) \<open>D A' c1 M1'\<close> \<open>D A' c2 M2'\<close> \<open>vars x1 \<subseteq> A\<close> apply blast*)
  then show ?case
    by meson (*by (fastforce intro: D.If)*)
next
  case (While x1 c)
  then show ?case
    by auto (metis D.intros(5) subset_trans)
    (*by (fastforce intro: D.While)*)
qed

theorem D_preservation:
  "(c,s) \<rightarrow> (c',s') \<Longrightarrow> D (dom s) c A \<Longrightarrow> \<exists>A'. D (dom s') c' A' & A <= A'"
proof(induction arbitrary: A rule:small_step_induct)
case (Assign a s i x)
  then show ?case by (auto intro: D.intros)
next
  case (Seq1 c s)
  then show ?case by (auto intro: D.intros)
next
  case (Seq2 c\<^sub>1 s c\<^sub>1' s' c\<^sub>2)
  then show ?case
    by auto (metis D_mono D.intros(3))
next
  case (IfTrue b s c\<^sub>1 c\<^sub>2)
  then show ?case by (auto intro: D.intros)
next
  case (IfFalse b s c\<^sub>1 c\<^sub>2)
  then show ?case by (auto intro: D.intros)
next
  case (While b c s)
(*
proof (state)
this:
  D (dom s) (WHILE b DO c) A

goal (1 subgoal):
 1. \<And>b c s A. D (dom s) (WHILE b DO c) A \<Longrightarrow> \<exists>A'. D (dom s) (IF b THEN c;; WHILE b DO c ELSE SKIP) A' \<and> A \<subseteq> A'
*)
  then obtain A' where A': "vars b \<subseteq> dom s" "A = dom s" "D (dom s) c A'" by blast
  then obtain A'' where "D A' c A''" by (metis D_incr D_mono)
  with A' have "D (dom s) (IF b THEN c;; WHILE b DO c ELSE SKIP) (dom s)"
    by (metis D.If[OF \<open>vars b \<subseteq> dom s\<close> D.Seq[OF \<open>D (dom s) c A'\<close> D.While[OF _ \<open>D A' c A''\<close>]] D.Skip] D_incr Int_absorb1 subset_trans)
    (* not shown only from sledgehammer *)
  then show ?case
    by (metis A'(2) D_increase)
(*    by (smt D.simps D_increase While.prems com.distinct(13) com.distinct(17) com.distinct(19)) (*> 1.0s*)*)
qed

(* Theorem 10.4 (D is sound). *)
theorem D_sound:
  "(c,s) \<rightarrow>* (c',s') \<Longrightarrow> D (dom s) c A'
   \<Longrightarrow> (\<exists>cs''. (c',s') \<rightarrow> cs'') \<or> c' = SKIP"
  apply(induction arbitrary: A' rule: star_induct )
   apply(metis progress)
  using D_preservation by blast

end


section \<open>Testing for Integrality and Conversion to Integers\<close>

theory Is_Int_To_Int
  imports
    Polynomial_Interpolation.Is_Rat_To_Rat
begin

lemma inv_of_rat: "inv of_rat (of_rat x) = x"
  by (meson injI inv_f_eq of_rat_eq_iff)

lemma of_rat_Ints_iff: "((of_rat x :: 'a :: field_char_0) \<in> \<int>) = (x \<in> \<int>)"
  by (metis Ints_cases Ints_of_int inv_of_rat of_rat_of_int_eq)

lemma is_int_code[code_unfold]:
  shows "(x \<in> \<int>) = (is_rat x \<and> is_int_rat (to_rat x))"
proof -
  have "x \<in> \<int> \<longleftrightarrow> x \<in> \<rat> \<and> x \<in> \<int>"
    by (metis Ints_cases Rats_of_int)
  also have "\<dots> = (is_rat x \<and> is_int_rat (to_rat x))"
  proof (simp, intro conj_cong[OF refl])
    assume "x \<in> \<rat>"
    then obtain y where x: "x = of_rat y" unfolding Rats_def by auto
    show "(x \<in> \<int>) = (to_rat x \<in> \<int>)" unfolding x
      by (simp add: of_rat_Ints_iff)
  qed
  finally show ?thesis .
qed

definition to_int :: "'a :: is_rat \<Rightarrow> int" where
  "to_int x = int_of_rat (to_rat x)"

lemma of_int_to_int: "x \<in> \<int> \<Longrightarrow> of_int (to_int x) = x"
  by (metis Ints_cases int_of_rat(1) of_rat_of_int_eq to_int_def to_rat_of_rat)

lemma to_int_of_int: "to_int (of_int x) = x"
  by (metis int_of_rat(1) of_rat_of_int_eq to_int_def to_rat_of_rat)

lemma to_rat_complex_of_real[simp]: "to_rat (complex_of_real x) = to_rat x"
  by (metis Re_complex_of_real complex_of_real_of_rat of_rat_to_rat to_rat to_rat_of_rat)

lemma to_int_complex_of_real[simp]: "to_int (complex_of_real x) = to_int x"
  by (simp add: to_int_def)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_regexp_RecNil
imports "../../Test_Base"
begin

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

datatype A = X | Y

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

fun seq :: "R => R => R" where
"seq x y =
   (case x of
      Nil => Nil
      | other =>
          (case y of
             Nil => Nil
             | other =>
                 (case x of
                    Eps => y
                    | other =>
                        (case y of
                           Eps => x
                           | other => Seq x y))))"

fun plus :: "R => R => R" where
"plus x y =
   (case x of
      Nil => y
      | other =>
          (case y of
             Nil => x
             | other => Plus x y))"

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

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

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

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

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

theorem property0 :
  "(~ (recognise Nil s))"
  oops

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory IsPrime
imports
  "AutoCorres.AutoCorres"
  "HOL-Computational_Algebra.Primes"
begin

external_file "is_prime.c"

(* Parse the input file. *)
install_C_file "is_prime.c"

(* Abstract the input file. *)
autocorres [ ts_rules = nondet, unsigned_word_abs = is_prime_linear is_prime ] "is_prime.c"

context is_prime begin

definition
  "partial_prime p (n :: nat) \<equiv>
        (1 < p \<and> (\<forall>i \<in> {2 ..< min p n}. \<not> i dvd p))"

lemma partial_prime_ge [simp]:
     "\<lbrakk> p' \<ge> p \<rbrakk> \<Longrightarrow> partial_prime p p' = prime p"
  by (clarsimp simp: partial_prime_def prime_nat_iff' min_def)

lemma divide_self_plus_one [simp]: "(x dvd Suc x) = (x = 1)"
  apply (case_tac "x = 0", simp)
  apply (case_tac "x = 1", simp)
  apply (clarsimp simp: dvd_def)
  apply (case_tac "k = 0", simp)
  apply (case_tac "k = 1", simp)
  apply (subgoal_tac "x * 2 \<le> x * k")
   apply (subgoal_tac "Suc x < x * 2")
    apply simp
   apply clarsimp
  apply clarsimp
  done

lemma partial_prime_Suc [simp]:
  "partial_prime p (Suc n)
              = (partial_prime p n \<and> (1 < n \<and> Suc n < p \<longrightarrow> \<not> n dvd p))"
   apply (clarsimp simp: partial_prime_def min_def atLeastLessThanSuc not_le)
  apply (case_tac "p = Suc n")
   apply (clarsimp simp: atLeastLessThanSuc)
  apply fastforce
  done

lemma mod_to_dvd:
   "(n mod i \<noteq> 0) = (\<not> i dvd (n :: nat))"
  by (clarsimp simp: dvd_eq_mod_eq_0)

lemma prime_of_product [simp]: "prime ((a::nat) * b) = ((a = 1 \<and> prime b) \<or> (prime a \<and> b = 1))"
  by (metis mult.commute mult.right_neutral prime_product)

lemma partial_prime_2 [simp]: "(partial_prime a 2) = (a > 1)"
  by (clarsimp simp: partial_prime_def)

definition [simp]:
  "is_prime_linear_inv n i s \<equiv> (1 < i \<and> 1 < n \<and> i \<le> n \<and> partial_prime n i)"

theorem is_prime_correct:
    "\<lbrace> \<lambda>s. n \<le> UINT_MAX \<rbrace> is_prime_linear' n \<lbrace> \<lambda>r s. (r \<noteq> 0) \<longleftrightarrow> prime n \<rbrace>!"
  apply (rule validNF_assume_pre)
  apply (case_tac "n = 0")
   apply (clarsimp simp: is_prime_linear'_def, wp, simp)[1]
  apply (case_tac "n = 1")
   apply (clarsimp simp: is_prime_linear'_def, wp, simp)[1]
  apply (unfold is_prime_linear'_def)
  apply (subst whileLoopE_add_inv [
      where I="\<lambda>r s. is_prime_linear_inv n r s"
                  and M="(\<lambda>(r, s). n - r)"])
  apply (wp, auto simp: mod_to_dvd [simplified])
  done

lemma not_prime:
    "\<lbrakk> \<not> prime (a :: nat); a > 1 \<rbrakk> \<Longrightarrow> \<exists>x y. x * y = a \<and> 1 < x \<and> 1 < y \<and> x * x \<le> a"
  apply (clarsimp simp: prime_nat_iff dvd_def)
  apply (case_tac "m > k")
   apply (metis Suc_lessD Suc_lessI less_imp_le_nat mult.commute nat_0_less_mult_iff nat_mult_less_cancel_disj)
  apply fastforce
  done

lemma sqrt_prime:
  "\<lbrakk> a * a > n; \<forall>x<a. (x dvd n) = (x = Suc 0 \<or> x = n); 1 < n \<rbrakk> \<Longrightarrow> prime n"
  apply (rule ccontr)
  apply (drule not_prime)
   apply clarsimp
  apply (metis dvd_triv_right less_le_trans mult.commute mult_le_cancel2
           One_nat_def less_eq_nat.simps(1) less_not_refl2
           mult_eq_self_implies_10 not_less)
  done

lemma partial_prime_sqr:
     "\<lbrakk> n * n > p \<rbrakk> \<Longrightarrow> partial_prime p n = prime p"
  apply (case_tac "n \<ge> p")
   apply clarsimp
  apply (case_tac "partial_prime p n")
   apply clarsimp
   apply (erule sqrt_prime)
    apply (clarsimp simp: partial_prime_def)
    apply (case_tac "x = 0", simp)
    apply (case_tac "x = 1", simp)
    apply (frule_tac x=x in bspec)
     apply (clarsimp simp: min_def)
    apply clarsimp
   apply (clarsimp simp: not_le partial_prime_def)
  apply (case_tac "p = 0", simp)
  apply (case_tac "p = 1", simp)
  apply (auto simp: not_le partial_prime_def min_def prime_nat_iff')
  done

definition "SQRT_UINT_MAX \<equiv> 65536 :: nat"

lemma uint_max_factor [simp]:
  "UINT_MAX = SQRT_UINT_MAX * SQRT_UINT_MAX - 1"
  by (clarsimp simp: UINT_MAX_def SQRT_UINT_MAX_def)

lemma prime_dvd:
    "\<lbrakk> prime (p::nat) \<rbrakk> \<Longrightarrow> (r dvd p) = (r = 1 \<or> r = p)"
  by (fastforce simp: prime_nat_iff)

definition is_prime_inv
  where [simp]: "is_prime_inv n i s \<equiv> (1 < i \<and> i \<le> n \<and> i \<le> SQRT_UINT_MAX \<and> i * i \<le> SQRT_UINT_MAX * SQRT_UINT_MAX \<and> partial_prime n i)"

lemma nat_leE: "\<lbrakk> (a::nat) \<le> b; a < b \<Longrightarrow> R; a = b \<Longrightarrow> R \<rbrakk> \<Longrightarrow> R"
  apply atomize_elim
    apply clarsimp
  done

lemma sqr_less_mono [simp]:
    "((i::nat) * i < j * j) = (i < j)"
  by (metis (full_types) le0 less_not_refl3 linorder_neqE_nat
        mult_strict_mono' order.strict_trans)

declare mult_le_mono [intro]

lemma sqr_le_sqr_minus_1 [simp]:
    "\<lbrakk> b \<noteq> 0 \<rbrakk> \<Longrightarrow> (a * a \<le> b * b - Suc 0) = (a < b)"
  by (metis gr0I is_prime.sqr_less_mono nat_0_less_mult_iff nat_le_Suc_less)

theorem is_prime_faster_correct:
  notes times_nat.simps(2) [simp del] mult_Suc_right [simp del]
  shows "\<lbrace> \<lambda>s. n \<le> UINT_MAX \<rbrace> is_prime' n \<lbrace> \<lambda>r s. (r \<noteq> 0) \<longleftrightarrow> prime n \<rbrace>!"
  apply (rule validNF_assume_pre)
  apply (case_tac "n = 0")
   apply (clarsimp simp: is_prime'_def, wp, simp)[1]
  apply (case_tac "n = 1")
   apply (clarsimp simp: is_prime'_def, wp, simp)[1]
  apply (unfold is_prime'_def dvd_eq_mod_eq_0 [symmetric] SQRT_UINT_MAX_def [symmetric])
  apply (subst whileLoopE_add_inv [
      where I="\<lambda>r s. is_prime_inv n r s"
      and M="(\<lambda>(r, s). (Suc n) * (Suc n) - r * r)"])
   apply wp
    apply clarsimp
    apply (metis One_nat_def Suc_leI Suc_lessD nat_leE prime_dvd leD mult_le_mono n_less_n_mult_m)
   apply (fastforce elim: nat_leE simp: partial_prime_sqr)
  apply (clarsimp simp: SQRT_UINT_MAX_def)
  done

end

end


(*  Title:      HOL/Nonstandard_Analysis/CStar.thy
    Author:     Jacques D. Fleuriot
    Copyright:  2001 University of Edinburgh
*)

section\<open>Star-transforms in NSA, Extending Sets of Complex Numbers
      and Complex Functions\<close>

theory CStar
imports NSCA
begin

subsection\<open>Properties of the *-Transform Applied to Sets of Reals\<close>

lemma STARC_hcomplex_of_complex_Int:
     "*s* X Int SComplex = hcomplex_of_complex ` X"
by (auto simp add: Standard_def)

lemma lemma_not_hcomplexA:
     "x \<notin> hcomplex_of_complex ` A ==> \<forall>y \<in> A. x \<noteq> hcomplex_of_complex y"
by auto

subsection\<open>Theorems about Nonstandard Extensions of Functions\<close>

lemma starfunC_hcpow: "!!Z. ( *f* (%z. z ^ n)) Z = Z pow hypnat_of_nat n"
by transfer (rule refl)

lemma starfunCR_cmod: "*f* cmod = hcmod"
by transfer (rule refl)

subsection\<open>Internal Functions - Some Redundancy With *f* Now\<close>

(** subtraction: ( *fn) - ( *gn) = *(fn - gn) **)
(*
lemma starfun_n_diff:
   "( *fn* f) z - ( *fn* g) z = ( *fn* (%i x. f i x - g i x)) z"
apply (cases z)
apply (simp add: starfun_n star_n_diff)
done
*)
(** composition: ( *fn) o ( *gn) = *(fn o gn) **)

lemma starfun_Re: "( *f* (\<lambda>x. Re (f x))) = (\<lambda>x. hRe (( *f* f) x))"
by transfer (rule refl)

lemma starfun_Im: "( *f* (\<lambda>x. Im (f x))) = (\<lambda>x. hIm (( *f* f) x))"
by transfer (rule refl)

lemma starfunC_eq_Re_Im_iff:
    "(( *f* f) x = z) = ((( *f* (%x. Re(f x))) x = hRe (z)) &
                          (( *f* (%x. Im(f x))) x = hIm (z)))"
by (simp add: hcomplex_hRe_hIm_cancel_iff starfun_Re starfun_Im)

lemma starfunC_approx_Re_Im_iff:
    "(( *f* f) x \<approx> z) = ((( *f* (%x. Re(f x))) x \<approx> hRe (z)) &
                            (( *f* (%x. Im(f x))) x \<approx> hIm (z)))"
by (simp add: hcomplex_approx_iff starfun_Re starfun_Im)

end


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

datatype Nat = Z | S "Nat"

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

theorem property0 :
  "((t2 (t2 (S m) n) (S k)) = (t2 (t2 m n) k))"
  oops

end


section \<open> Alphabet Scene Spaces \<close>

theory Alphabet_Scene_Spaces
  imports Frames Lens_Instances
  keywords "alphabet_scene_space" :: "thy_defn"
begin

text \<open> The scene space for an alphabet is constructed using the set of scenes corresponding to
  each lens, the base lens, and the more lens, to allow for extension. \<close>

definition alpha_scene_space :: "'s scene list \<Rightarrow> ('b::scene_space \<Longrightarrow> 's) \<Rightarrow> 's scene list" where
"alpha_scene_space xs m\<^sub>L = xs @ map (\<lambda> x. x ;\<^sub>S m\<^sub>L) Vars"

definition alpha_scene_space' :: "'s scene list \<Rightarrow> ('b::scene_space \<Longrightarrow> 's) \<Rightarrow> ('c \<Longrightarrow> 's) \<Rightarrow> 'c scene list" where
"alpha_scene_space' xs m\<^sub>L p\<^sub>L = alpha_scene_space (map (\<lambda> x. x /\<^sub>S p\<^sub>L) xs) (m\<^sub>L /\<^sub>L p\<^sub>L)"

lemma mem_alpha_scene_space_iff [simp]:
  "x \<in> set (alpha_scene_space xs m\<^sub>L) \<longleftrightarrow> (x \<in> set xs \<or> x \<in> (\<lambda> x. x ;\<^sub>S m\<^sub>L) ` set Vars)"
  by (simp add: alpha_scene_space_def)

lemma alpha_scene_space_class_intro:
  assumes
    "\<forall> x\<in>set xs. idem_scene x"
    "scene_indeps (set xs)"
    "vwb_lens m\<^sub>L" \<comment> \<open> The more lens \<close>
    "\<forall> x\<in>set xs. x \<bowtie>\<^sub>S \<lbrakk>m\<^sub>L\<rbrakk>\<^sub>\<sim>"
    "(foldr (\<squnion>\<^sub>S) xs \<lbrakk>m\<^sub>L\<rbrakk>\<^sub>\<sim>) = \<top>\<^sub>S"
  shows "class.scene_space (alpha_scene_space xs m\<^sub>L)"
proof (simp add: alpha_scene_space_def, unfold_locales)
  show "\<And>x. x \<in> set (xs @ map (\<lambda>x. x ;\<^sub>S m\<^sub>L) Vars) \<Longrightarrow> idem_scene x"
    using assms(1) idem_scene_Vars by fastforce
  show "scene_indeps (set (xs @ map (\<lambda>x. x ;\<^sub>S m\<^sub>L) Vars))"
    apply (auto simp add: scene_indeps_def pairwise_def)
    apply (metis assms(2) pairwiseD scene_indeps_def)
    using assms(1) assms(4) idem_scene_Vars scene_comp_pres_indep apply blast
    using assms(1) assms(4) idem_scene_Vars scene_comp_pres_indep scene_indep_sym apply blast
    apply (metis indep_Vars pairwiseD scene_comp_indep scene_indeps_def)
    done
  show "scene_span (xs @ map (\<lambda>x. x ;\<^sub>S m\<^sub>L) Vars)"
    apply (simp add: scene_span_def)
    apply (subst foldr_compat_dist)
    apply (simp)
    apply (metis assms(3) assms(5) scene_comp_top_scene scene_span_def span_Vars)
    done
qed

lemma alpha_scene_space_class_intro':
  assumes
    "\<forall> x\<in>set xs. idem_scene x"
    "scene_indeps (set xs)"
    "vwb_lens m\<^sub>L" \<comment> \<open> The more lens \<close>
    "vwb_lens p\<^sub>L" \<comment> \<open> The parent more lens \<close>
    "m\<^sub>L \<subseteq>\<^sub>L p\<^sub>L"
    "\<forall>a\<in>set xs. a \<subseteq>\<^sub>S \<lbrakk>p\<^sub>L\<rbrakk>\<^sub>\<sim>"
    "\<forall> x\<in>set xs. x \<bowtie>\<^sub>S \<lbrakk>m\<^sub>L\<rbrakk>\<^sub>\<sim>"
    "foldr (\<squnion>\<^sub>S) xs \<lbrakk>m\<^sub>L\<rbrakk>\<^sub>\<sim> = \<lbrakk>p\<^sub>L\<rbrakk>\<^sub>\<sim>"
  shows "class.scene_space (alpha_scene_space' xs m\<^sub>L p\<^sub>L)"
  unfolding alpha_scene_space'_def
  apply (rule alpha_scene_space_class_intro)
      apply (simp_all add: assms scene_quotient_idem)
  apply (simp add: scene_indeps_def pairwise_def )
  apply (metis assms(2) pairwiseD scene_indeps_def scene_quotient_indep)
  using assms(3) assms(4) assms(5) lens_quotient_vwb apply blast
   apply (simp add: assms lens_scene_quotient scene_quotient_indep)
  apply (subst foldr_scene_union_add_tail[THEN sym])
  apply (simp)
  apply (metis (mono_tags, lifting) assms(2) pairwiseD pairwise_imageI scene_indep_compat scene_indeps_def scene_quotient_indep)
  apply (simp add: assms(4) assms(5) assms(7) lens_scene_quotient scene_quotient_indep)
  apply (subst foldr_compat_quotient_dist)
  apply (metis assms(2) pairwise_alt scene_indep_compat scene_indeps_def)
  using assms(6) apply blast
  apply (simp add: lens_scene_quotient assms)
  apply (subst scene_union_quotient[THEN sym])
  apply (metis assms(2) assms(3) assms(4) assms(5) assms(7) assms(8) bot_idem_scene empty_iff foldr.simps(1) foldr_scene_union_add_tail id_apply list.set(1) order_eq_refl pairwise_compat_foldr pairwise_empty pairwise_mono scene_bot_least scene_indep_compat scene_indeps_def scene_union_incompat sublens'_implies_subscene sublens_implies_sublens' subscene_antisym)
  apply (metis assms(2) assms(6) foldr_scene_indep pairwise_def scene_indep_compat scene_indep_sym scene_indeps_def scene_le_iff_indep_inv)
  apply (simp add: assms(3) assms(4) assms(5) sublens'_implies_subscene sublens_implies_sublens')
  apply (subst foldr_scene_union_add_tail)
  apply (metis assms(2) pairwiseD pairwiseI scene_indep_compat scene_indeps_def)
  using assms(7) scene_indep_compat apply blast
  apply (simp add: assms(8))
  apply (metis assms(4) scene_comp_quotient scene_comp_top_scene)
  done

lemma alpha_scene_space_class_intro'':
  assumes
    "\<forall> x\<in>set (concat xs). idem_scene x"
    "scene_indeps (set (concat xs))"
    "vwb_lens m\<^sub>L" \<comment> \<open> The more lens \<close>
    "vwb_lens p\<^sub>L" \<comment> \<open> The parent more lens \<close>
    "m\<^sub>L \<subseteq>\<^sub>L p\<^sub>L"
    "\<forall>a\<in>set (concat xs). a \<subseteq>\<^sub>S \<lbrakk>p\<^sub>L\<rbrakk>\<^sub>\<sim>"
    "\<forall> x\<in>set (concat xs). x \<bowtie>\<^sub>S \<lbrakk>m\<^sub>L\<rbrakk>\<^sub>\<sim>"
    "\<Squnion>\<^sub>S (map \<Squnion>\<^sub>S xs @ [\<lbrakk>m\<^sub>L\<rbrakk>\<^sub>\<sim>]) = \<lbrakk>p\<^sub>L\<rbrakk>\<^sub>\<sim>"
  shows "class.scene_space (alpha_scene_space' (concat xs) m\<^sub>L p\<^sub>L)"
proof -
  have p1: "pairwise (##\<^sub>S) (set (concat xs))"
    by (metis assms(2) pairwise_def scene_indep_compat scene_indeps_def)
  have p2: "pairwise (##\<^sub>S) (set (concat xs @ [\<lbrakk>m\<^sub>L\<rbrakk>\<^sub>\<sim>]))"
    by (metis (no_types, lifting) assms(7) insertE list.simps(15) p1 pairwise_def rotate1.simps(2) scene_compat_sym scene_indep_compat set_rotate1)
  have "foldr (\<squnion>\<^sub>S) (concat xs) \<lbrakk>m\<^sub>L\<rbrakk>\<^sub>\<sim> = \<Squnion>\<^sub>S (concat (xs @ [[\<lbrakk>m\<^sub>L\<rbrakk>\<^sub>\<sim>]]))"
    by simp
  also have "... = \<Squnion>\<^sub>S (map \<Squnion>\<^sub>S (xs @ [[\<lbrakk>m\<^sub>L\<rbrakk>\<^sub>\<sim>]]))"
    by (metis append_self_conv concat.simps(2) concat_append foldr_scene_concat p2)
  also have "... = foldr (\<squnion>\<^sub>S) (map \<Squnion>\<^sub>S xs) \<lbrakk>m\<^sub>L\<rbrakk>\<^sub>\<sim>"
    by simp
  finally show ?thesis
    using assms by (rule_tac alpha_scene_space_class_intro', simp_all)
qed

definition more_frame :: "('a::scene_space \<Longrightarrow> 'b::scene_space) \<Rightarrow> 'b frame" where
"more_frame m\<^sub>L = \<Union>\<^sub>F ((\<lambda>x. [x ;\<^sub>S m\<^sub>L]\<^sub>F) ` set Vars)"

lemma more_frame_unit [simp]: "more_frame (m\<^sub>L :: unit \<Longrightarrow> 'b::scene_space) = \<lbrace>\<rbrace>\<^sub>F"
  by (simp add: more_frame_def)

named_theorems scene_space_defs

lemmas scene_space_lemmas =
   lens_plus_scene[THEN sym] lens_equiv_scene[THEN sym] lens_equiv_sym
   lens_scene_comp[THEN sym] lens_quotient_vwb lens_quotient_comp
   comp_vwb_lens lens_comp_assoc[THEN sym] sublens_iff_subscene[THEN sym]
   lens_scene_quotient[THEN sym] sublens_greatest lens_quotient_id_denom
   scene_comp_assoc lens_quotient_indep lens_quotient_plus[THEN sym] lens_quotient_bij
   plus_pred_sublens lens_scene_top_iff_bij_lens lens_indep_scene[THEN sym]
   lens_indep_left_ext lens_indep_right_ext

method basis_lens uses defs =
  (rule basis_lens_intro, simp_all add: scene_space_defs alpha_scene_space_def alpha_scene_space'_def scene_space_lemmas)

method composite_lens =
  (rule composite_lens.intro, simp, rule composite_lens_axioms.intro
  ,simp add: scene_space_defs alpha_scene_space_def alpha_scene_space'_def scene_space_lemmas image_comp)

method more_frame =
  ((simp add: frame_scene_top frame_scene_foldr)?
  ,(simp_all add: frame_scene_top frame_scene_foldr alpha_scene_space'_def alpha_scene_space_def scene_space_lemmas more_frame_def scene_space_defs image_comp))

method alpha_scene_space =
  (rule scene_space_class.intro
  ,(intro_classes)[1]
  ,simp add: scene_space_defs lens_scene_quotient
  ,rule alpha_scene_space_class_intro alpha_scene_space_class_intro'
  ,simp_all add: scene_indeps_def pairwise_def scene_space_lemmas)

ML_file \<open>Alphabet_Scene_Spaces.ML\<close>

ML \<open>

val _ =
  Outer_Syntax.command @{command_keyword alphabet_scene_space} "define a scene space for an alphabet"
    (Parse.name
    >> (fn n =>
        Toplevel.theory (Alphabet_Scene_Spaces.mk_alpha_scene_space n)));

\<close>

end


(*  Author:     Tobias Nipkow, 2007  *)

header{* Linear real arithmetic *}

theory LinArith
imports QE "~~/src/HOL/Library/ListVector" Complex_Main
begin

declare iprod_assoc[simp]

subsection{*Basics*}

subsubsection{*Syntax and Semantics*}

datatype atom = Less real "real list" | Eq real "real list"

fun is_Less :: "atom \<Rightarrow> bool" where
"is_Less (Less r rs) = True" |
"is_Less f = False"

abbreviation "is_Eq \<equiv> Not o is_Less"

lemma is_Less_iff: "is_Less f = (\<exists>r rs. f = Less r rs)"
by(induct f) auto

lemma is_Eq_iff: "(\<forall>i j. a \<noteq> Less i j) = (\<exists>i j. a = Eq i j)"
by(cases a) auto

fun neg\<^sub>R :: "atom \<Rightarrow> atom fm" where
"neg\<^sub>R (Less r t) = Or (Atom(Less (-r) (-t))) (Atom(Eq r t))" |
"neg\<^sub>R (Eq r t) = Or (Atom(Less r t)) (Atom(Less (-r) (-t)))"

fun hd_coeff :: "atom \<Rightarrow> real" where
"hd_coeff (Less r cs) = (case cs of [] \<Rightarrow> 0 | c#_ \<Rightarrow> c)" |
"hd_coeff (Eq r cs) = (case cs of [] \<Rightarrow> 0 | c#_ \<Rightarrow> c)"

definition "depends\<^sub>R a = (hd_coeff a \<noteq> 0)"

fun decr\<^sub>R :: "atom \<Rightarrow> atom" where
"decr\<^sub>R (Less r rs) = Less r (tl rs)" |
"decr\<^sub>R (Eq r rs) = Eq r (tl rs)"

fun I\<^sub>R :: "atom \<Rightarrow> real list \<Rightarrow> bool" where
"I\<^sub>R (Less r cs) xs = (r < \<langle>cs,xs\<rangle>)" |
"I\<^sub>R (Eq r cs) xs = (r = \<langle>cs,xs\<rangle>)"

definition "atoms\<^sub>0 = ATOM.atoms\<^sub>0 depends\<^sub>R"
(* FIXME !!! (incl: display should hide params)*)

interpretation R!: ATOM neg\<^sub>R "(\<lambda>a. True)" I\<^sub>R depends\<^sub>R decr\<^sub>R
  where "ATOM.atoms\<^sub>0 depends\<^sub>R = atoms\<^sub>0"
proof -
  case goal1
  thus ?case
    apply(unfold_locales)
        apply(case_tac a)
         apply simp_all
     apply(case_tac a)
      apply simp_all
      apply arith
     apply arith
    apply(case_tac a)
    apply(simp_all add:depends\<^sub>R_def split:list.splits)
    done
next
  case goal2
  thus ?case by(simp add:atoms\<^sub>0_def)
qed

setup {* Sign.revert_abbrev "" @{const_abbrev R.I} *}
setup {* Sign.revert_abbrev "" @{const_abbrev R.lift_nnf_qe} *}

subsubsection{*Shared constructions*}

fun combine :: "(real * real list) \<Rightarrow> (real * real list) \<Rightarrow> atom" where
"combine (r\<^sub>1,cs\<^sub>1) (r\<^sub>2,cs\<^sub>2) = Less (r\<^sub>1-r\<^sub>2) (cs\<^sub>2 - cs\<^sub>1)"

(* More efficient combination than rhs of combine_conv below; unused
lemma combine_code:
  "combine (r1,c1,cs1) (r2,c2,cs2) =
  Less (c1*r2-c2*r1) (zipwith0 (%x y. c1*y-c2*x) cs1 cs2)"
apply(rule sym)
apply(simp)
apply(induct cs1 arbitrary:cs2)
 apply simp
apply(case_tac cs2)
 apply simp
apply simp
done*)

definition "lbounds as = [(r/c, (-1/c) *\<^sub>s cs). Less r (c#cs) \<leftarrow> as, c>0]"
definition "ubounds as = [(r/c, (-1/c) *\<^sub>s cs). Less r (c#cs) \<leftarrow> as, c<0]"
definition "ebounds as = [(r/c, (-1/c) *\<^sub>s cs). Eq r (c#cs) \<leftarrow> as, c\<noteq>0]"

lemma set_lbounds:
 "set(lbounds as) = {(r/c, (-1/c) *\<^sub>s cs)|r c cs. Less r (c#cs) : set as \<and> c>0}"
by(force simp: lbounds_def split:list.splits atom.splits if_splits)
lemma set_ubounds:
 "set(ubounds as) = {(r/c, (-1/c) *\<^sub>s cs)|r c cs. Less r (c#cs) : set as \<and> c<0}"
by(force simp: ubounds_def split:list.splits atom.splits if_splits)
lemma set_ebounds:
  "set(ebounds as) = {(r/c, (-1/c) *\<^sub>s cs)|r c cs. Eq r (c#cs) : set as \<and> c\<noteq>0}"
by(force simp: ebounds_def split:list.splits atom.splits if_splits)

abbreviation EQ where
"EQ f xs \<equiv> {(r - \<langle>cs,xs\<rangle>)/c|r c cs. Eq r (c#cs) : set(R.atoms\<^sub>0 f) \<and> c\<noteq>0}"
abbreviation LB where
"LB f xs \<equiv> {(r - \<langle>cs,xs\<rangle>)/c|r c cs. Less r (c#cs) : set(R.atoms\<^sub>0 f) \<and> c>0}"
abbreviation UB where
"UB f xs \<equiv> {(r - \<langle>cs,xs\<rangle>)/c|r c cs. Less r (c#cs) : set(R.atoms\<^sub>0 f) \<and> c<0}"

fun asubst :: "real * real list \<Rightarrow> atom \<Rightarrow> atom" where
"asubst (r,cs) (Less s (d#ds)) = Less (s - d*r) (d *\<^sub>s cs + ds)" |
"asubst (r,cs) (Eq s (d#ds)) = Eq (s - d*r) (d *\<^sub>s cs + ds)" |
"asubst (r,cs) (Less s []) = Less s []" |
"asubst (r,cs) (Eq s []) = Eq s []"

abbreviation "subst \<phi> rcs \<equiv> map\<^bsub>fm\<^esub> (asubst rcs) \<phi>"

definition eval :: "real * real list \<Rightarrow> real list \<Rightarrow> real" where
"eval rcs xs = fst rcs + \<langle>snd rcs,xs\<rangle>"

lemma I_asubst:
 "I\<^sub>R (asubst t a) xs = I\<^sub>R a (eval t xs # xs)"
proof(cases a)
  case (Less r cs)
  thus ?thesis by(cases t, cases cs,
    simp_all add:eval_def distrib_left iprod_left_add_distrib)
    arith
next
  case (Eq r cs)
  thus ?thesis
    by(cases t, cases cs, simp_all add:eval_def distrib_left iprod_left_add_distrib)
      arith
qed

lemma I_subst:
  "qfree \<phi> \<Longrightarrow> R.I (subst \<phi> t) xs = R.I \<phi> (eval t xs # xs)"
by(induct \<phi>)(simp_all add:I_asubst)
lemma I_subst_pretty:
  "qfree \<phi> \<Longrightarrow> R.I (subst \<phi> (r,cs)) xs = R.I \<phi> ((r + \<langle>cs,xs\<rangle>) # xs)"
by(simp add:I_subst eval_def)

fun min_inf :: "atom fm \<Rightarrow> atom fm" ("inf\<^sub>-") where
"inf\<^sub>- (And \<phi>\<^sub>1 \<phi>\<^sub>2) = and (inf\<^sub>- \<phi>\<^sub>1) (inf\<^sub>- \<phi>\<^sub>2)" |
"inf\<^sub>- (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = or (inf\<^sub>- \<phi>\<^sub>1) (inf\<^sub>- \<phi>\<^sub>2)" |
"inf\<^sub>- (Atom(Less r (c#cs))) =
  (if c<0 then TrueF else if c>0 then FalseF else Atom(Less r cs))" |
"inf\<^sub>- (Atom(Eq r (c#cs))) = (if c=0 then Atom(Eq r cs) else FalseF)" |
"inf\<^sub>- \<phi> = \<phi>"

fun plus_inf :: "atom fm \<Rightarrow> atom fm" ("inf\<^sub>+") where
"inf\<^sub>+ (And \<phi>\<^sub>1 \<phi>\<^sub>2) = and (inf\<^sub>+ \<phi>\<^sub>1) (inf\<^sub>+ \<phi>\<^sub>2)" |
"inf\<^sub>+ (Or \<phi>\<^sub>1 \<phi>\<^sub>2) = or (inf\<^sub>+ \<phi>\<^sub>1) (inf\<^sub>+ \<phi>\<^sub>2)" |
"inf\<^sub>+ (Atom(Less r (c#cs))) =
  (if c>0 then TrueF else if c<0 then FalseF else Atom(Less r cs))" |
"inf\<^sub>+ (Atom(Eq r (c#cs))) = (if c=0 then Atom(Eq r cs) else FalseF)" |
"inf\<^sub>+ \<phi> = \<phi>"

lemma qfree_min_inf: "qfree \<phi> \<Longrightarrow> qfree(inf\<^sub>- \<phi>)"
by(induct \<phi> rule:min_inf.induct) simp_all

lemma qfree_plus_inf: "qfree \<phi> \<Longrightarrow> qfree(inf\<^sub>+ \<phi>)"
by(induct \<phi> rule:plus_inf.induct) simp_all

lemma min_inf:
  "nqfree f \<Longrightarrow> \<exists>x. \<forall>y\<le>x. R.I (inf\<^sub>- f) xs = R.I f (y # xs)"
  (is "_ \<Longrightarrow> \<exists>x. ?P f x")
proof(induct f)
  case (Atom a)
  show ?case
  proof (cases a)
    case (Less r cs)
    show ?thesis
    proof(cases cs)
      case Nil thus ?thesis using Less by simp
    next
      case (Cons c cs)
      { assume "c=0" hence ?thesis using Less Cons by simp }
      moreover
      { assume "c<0"
        hence "?P (Atom a) ((r - \<langle>cs,xs\<rangle> + 1)/c)" using Less Cons
          by(auto simp add: field_simps)
        hence ?thesis .. }
      moreover
      { assume "c>0"
        hence "?P (Atom a) ((r - \<langle>cs,xs\<rangle> - 1)/c)" using Less Cons
          by(auto simp add: field_simps)
        hence ?thesis .. }
      ultimately show ?thesis by force
    qed
  next
    case (Eq r cs)
    show ?thesis
    proof(cases cs)
      case Nil thus ?thesis using Eq by simp
    next
      case (Cons c cs)
      { assume "c=0" hence ?thesis using Eq Cons by simp }
      moreover
      { assume "c<0"
        hence "?P (Atom a) ((r - \<langle>cs,xs\<rangle> + 1)/c)" using Eq Cons
          by(auto simp add: field_simps)
        hence ?thesis .. }
      moreover
      { assume "c>0"
        hence "?P (Atom a) ((r - \<langle>cs,xs\<rangle> - 1)/c)" using Eq Cons
          by(auto simp add: field_simps)
        hence ?thesis .. }
      ultimately show ?thesis by force
    qed
  qed
next
  case (And f1 f2)
  then obtain x1 x2 where "?P f1 x1" "?P f2 x2" by fastforce+
  hence "?P (And f1 f2) (min x1 x2)" by(force simp:and_def)
  thus ?case ..
next
  case (Or f1 f2)
  then obtain x1 x2 where "?P f1 x1" "?P f2 x2" by fastforce+
  hence "?P (Or f1 f2) (min x1 x2)" by(force simp:or_def)
  thus ?case ..
qed simp_all

lemma plus_inf:
  "nqfree f \<Longrightarrow> \<exists>x. \<forall>y\<ge>x. R.I (inf\<^sub>+ f) xs = R.I f (y # xs)"
  (is "_ \<Longrightarrow> \<exists>x. ?P f x")
proof(induct f)
  case (Atom a)
  show ?case
  proof (cases a)
    case (Less r cs)
    show ?thesis
    proof(cases cs)
      case Nil thus ?thesis using Less by simp
    next
      case (Cons c cs)
      { assume "c=0" hence ?thesis using Less Cons by simp }
      moreover
      { assume "c<0"
        hence "?P (Atom a) ((r - \<langle>cs,xs\<rangle> - 1)/c)" using Less Cons
          by(auto simp add: field_simps)
        hence ?thesis .. }
      moreover
      { assume "c>0"
        hence "?P (Atom a) ((r - \<langle>cs,xs\<rangle> + 1)/c)" using Less Cons
          by(auto simp add: field_simps)
        hence ?thesis .. }
      ultimately show ?thesis by force
    qed
  next
    case (Eq r cs)
    show ?thesis
    proof(cases cs)
      case Nil thus ?thesis using Eq by simp
    next
      case (Cons c cs)
      { assume "c=0" hence ?thesis using Eq Cons by simp }
      moreover
      { assume "c<0"
        hence "?P (Atom a) ((r - \<langle>cs,xs\<rangle> - 1)/c)" using Eq Cons
          by(auto simp add: field_simps)
        hence ?thesis .. }
      moreover
      { assume "c>0"
        hence "?P (Atom a) ((r - \<langle>cs,xs\<rangle> + 1)/c)" using Eq Cons
          by(auto simp add: field_simps)
        hence ?thesis .. }
      ultimately show ?thesis by force
    qed
  qed
next
  case (And f1 f2)
  then obtain x1 x2 where "?P f1 x1" "?P f2 x2" by fastforce+
  hence "?P (And f1 f2) (max x1 x2)" by(force simp:and_def)
  thus ?case ..
next
  case (Or f1 f2)
  then obtain x1 x2 where "?P f1 x1" "?P f2 x2" by fastforce+
  hence "?P (Or f1 f2) (max x1 x2)" by(force simp:or_def)
  thus ?case ..
qed simp_all

declare [[simp_depth_limit = 4]]

lemma LBex:
 "\<lbrakk> nqfree f; R.I f (x#xs); \<not>R.I (inf\<^sub>- f) xs; x \<notin> EQ f xs \<rbrakk>
  \<Longrightarrow> \<exists>l\<in> LB f xs. l < x"
apply(induct f)
apply simp
apply simp
apply(rename_tac a)
apply(case_tac a)
apply(auto simp add: depends\<^sub>R_def field_simps split:if_splits list.splits)
apply fastforce+
done

lemma UBex:
 "\<lbrakk> nqfree f; R.I f (x#xs); \<not>R.I (inf\<^sub>+ f) xs; x \<notin> EQ f xs \<rbrakk>
  \<Longrightarrow> \<exists>u\<in> UB f xs. x < u"
apply(induct f)
apply simp
apply simp
apply(rename_tac a)
apply(case_tac a)
apply(auto simp add: depends\<^sub>R_def field_simps split:if_splits list.splits)
apply fastforce+
done

declare [[simp_depth_limit = 50]]

lemma finite_LB: "finite(LB f xs)"
proof -
  have "LB f xs = (\<lambda>(r,cs). r + \<langle>cs,xs\<rangle>) ` set(lbounds(R.atoms\<^sub>0 f))"
    by (force simp:set_lbounds image_def field_simps)
  thus ?thesis by simp
qed

lemma finite_UB: "finite(UB f xs)"
proof -
  have "UB f xs = (\<lambda>(r,cs). r + \<langle>cs,xs\<rangle>) ` set(ubounds(R.atoms\<^sub>0 f))"
    by (force simp:set_ubounds image_def field_simps)
  thus ?thesis by simp
qed

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}. 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}. 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}. 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}. sign (poly q y)" using 3 by linarith
  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}. sign (poly q y) \<equiv> (\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x > 0}.sign (poly q y)) + (\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x < 0}.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}.sign (poly q y)) + (\<Sum>y\<in>{x. poly p x = 0 \<and> poly q x < 0}.sign(poly q y))" using 12 by linarith
  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. 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 sign assignments *)
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 sign assignment.
  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 sign vector of the qs  is the ith entry of 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 sign vectors consist of 1 and -1's, z returns 1 or -1
  when applied to a consistent 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, hide_lams) 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


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

(*<*)
theory Chapter3_HoareHeap
imports "AutoCorres.AutoCorres"
begin

external_file "swap.c"
(*>*)

subsection \<open>\texttt{swap}\<close>

text \<open>

  Here, we use AutoCorres to verify a C program that reads and writes to the heap.
  Our C function, \texttt{swap}, swaps two words in memory:

\lstinputlisting[language=C, firstline=15]{../../swap.c}

  Again, we translate the program using the C parser and AutoCorres.
\<close>

install_C_file "swap.c"
autocorres [heap_abs_syntax, ts_rules = nondet] "swap.c"
(*<*)
context swap begin
(*>*)

text \<open>
  Most heap operations in C programs consist of accessing a pointer.
  AutoCorres abstracts the global C heap by creating one heap for
  each type. (In our simple \texttt{swap} example, it creates only
  a @{typ word32} heap.) This makes verification easier as long as
  the program does not access the same memory as two different types.

  There are other operations that are relevant to program verification,
  such as changing the type that occupies a given region of memory.
  AutoCorres will not abstract any functions that use these operations,
  so verifying them will be more complicated (but still possible).
\<close>

text \<open>
  The C parser expresses \texttt{swap} like this:
\<close>

thm swap_body_def
text \<open>@{thm [display] swap_body_def}\<close>

text \<open>
  AutoCorres abstracts the function to this:
\<close>

thm swap'_def
text \<open>@{thm [display] swap'_def }\<close>

text \<open>
  There are some things to note:

  The function contains guards (assertions) that the pointers
  \texttt{a} and \texttt{b} are valid. We need to prove that
  these guards never fail when verifying \texttt{swap}.
  Conversely, when verifying any function that calls
  \texttt{swap}, we need to show that the arguments are
  valid pointers.

  We saw a monadic program in the previous section, but here
  the monad is actually being used to carry the program heap.
\<close>

(* FIXME: something about heap syntax here. *)

text \<open>
  Now we prove that \texttt{swap} is correct. We use @{term x}
  and @{term y} to ``remember'' the initial values so that we can
  talk about them in the postcondition.
\<close>
lemma "\<lbrace> \<lambda>s. is_valid_w32 s a \<and> s[a] = x \<and> is_valid_w32 s b \<and> s[b] = y \<rbrace>
         swap' a b
       \<lbrace> \<lambda>_ s. s[a] = y \<and> s[b] = x \<rbrace>!"
  apply (unfold swap'_def)
  apply wp
  apply clarsimp
  txt \<open>
    The C parser and AutoCorres both model the C heap using functions,
    which takes a pointer to some object in memory. Heap updates are
    modelled using the functional update @{term fun_upd}:

      @{thm [display] fun_upd_def}

    To reason about functional updates, we use the rule fun\_upd\_apply.
\<close>
  apply (simp add: fun_upd_apply)
  done

text \<open>
  Note that we have ``only'' proved that the function swaps its
  arguments. We have not proved that it does \emph{not} change
  any other state. This is a typical \emph{frame problem} with
  pointer reasoning. We can prove a more complete specification
  of \texttt{swap}:
\<close>
lemma "(\<And>x y s. P (s[a := x][b := y]) = P s) \<Longrightarrow>
       \<lbrace> \<lambda>s. is_valid_w32 s a \<and> s[a] = x \<and> is_valid_w32 s b \<and> s[b] = y \<and> P s \<rbrace>
         swap' a b
       \<lbrace> \<lambda>_ s. s[a] = y \<and> s[b] = x \<and> P s \<rbrace>!"
  apply (unfold swap'_def)
  apply wp
  apply (clarsimp simp: fun_upd_apply)
  done

text \<open>
  In other words, if predicate @{term P} does not depend on the
  inputs to \texttt{swap}, it will continue to hold.

  \emph{Separation logic} provides a more structured approach
  to this problem.
\<close>

(*<*)
end
end
(*>*)


theory Homework6_1
imports "../IMP/Big_Step"
begin

  (*
    ISSUED: Wednesday, October 25
    DUE: Wednesday, November 1, 11:59pm
    POINTS: 5
  *)

section \<open>Derivation Trees\<close>

(*
  Consider the following program, that will compute
  1+...+n, and return the result in a
*)

abbreviation (input) w where "w\<equiv>
  WHILE Less (N 0) (V ''n'') DO (
    ''a'' ::= Plus (V ''a'') (V ''n'');;
    ''n'' ::= Plus (V ''n'') (N (-1))
  )
"

abbreviation (input) "gauss \<equiv>
  ''a'' ::= N 0;;
  w
"

(*
  Do a forward derivation of a big-step execution,
  for program gauss and start state <''n'':=2>
*)

lemmas fwd_gauss = Seq[where c\<^sub>1="''a'' ::= N 0" and c\<^sub>2=w and s\<^sub>1="<''n'':=2>", OF
  Assign
  _ (* Insert rest of derivation tree here! *),
  simplified
]

(* Test: Your lemma should solve the following goal: *)
schematic_goal "(gauss,<''n'':=2>) \<Rightarrow> ?s"
  apply (rule fwd_gauss)
  done oops

(* Do a backward derivation. Do not use BigSteps, nor the fwd_gauss rule,
    but apply only
      rule Seq, rule Assign, rule WhileTrue, rule WhileFalse, and simp!
*)
schematic_goal "(gauss,<''n'':=2>) \<Rightarrow> ?s"
  apply (rule Seq)
   apply (rule Assign)
  apply simp
  oops (* Finish the backwards derivation! *)

section \<open>Quotient, Rounded Down\<close>

(* Write a program that returns the quotient, rounded down, of two positive
  numbers x and y, in variable q.

  Note: Due to the limited operations available, in particular no Minus,
    finding the simplest program may require a little thought. You may need an auxiliary variable.
  Hint: You only need a single WHILE loop, and no IF.
  Hint: It might be a good idea to sketch the program in pseudocode or C first,
    before you write it down in IMP syntax.

*)

abbreviation "IMP_div \<equiv> SKIP" (* Replace by your program! *)

(* Test your program for different test cases!
  In particular, make sure that rounding down is correct, e.g.,
    5 div 3 = 1
    6 div 3 = 2
    7 div 3 = 2

*)
schematic_goal [simplified]: "(IMP_div,<''x'' := 3, ''y'' := 2>) \<Rightarrow> ?s"
  by BigSteps

end