(* This file includes proofs for the multivariate
  matrix equation construction from Hybrid_Multiv_Matrix.thy.
*)

theory Hybrid_Multiv_Matrix_Proofs
  imports
    "BenOr_Kozen_Reif.Matrix_Equation_Construction"
    Multiv_Tarski_Query
    "BenOr_Kozen_Reif.Renegar_Proofs"
    Hybrid_Multiv_Matrix
    Hybrid_Multiv_Algorithm
    Renegar_Modified

begin

hide_const "BKR_Decision.And"
hide_const "BKR_Decision.Or"

hide_const "UnivPoly.eval"

subsection "Connect multivariate Tarski queries to univariate"
lemma pull_out_pairs_length:
  shows "length (pull_out_pairs qs Is) = length Is"
  using pull_out_pairs.simps by force

lemma construct_NofI_M_subset_prop:
  assumes "(assumps, tq) \<in> set (construct_NofI_M p init_assumps qs1 qs2)"
  shows "set init_assumps \<subseteq> set assumps"
proof -
  have "(assumps, tq) \<in> set (map construct_NofI_single_M (construct_NofI_R_spmods p init_assumps qs1 qs2))"
    using assms
    by auto
  then obtain mid_assumps tq_list where tuple_prop2: "(assumps, tq) = construct_NofI_single_M (mid_assumps, tq_list)"
    "(mid_assumps, tq_list) \<in> set (construct_NofI_R_spmods p init_assumps qs1 qs2)"
    by force
  have s1: "mid_assumps = assumps"
    using tuple_prop2(1)
    by simp
  have s2: "set init_assumps \<subseteq> set mid_assumps"
    using tuple_prop2(2) spmods_multiv_assum_acc
    by (metis construct_NofI_R_spmods_def)
  then show "set init_assumps \<subseteq> set assumps"
    using s1 s2
    by blast
qed

subsection "Connect multivariate RHS vector to univariate"

lemma construct_rhs_vector_rec_M_subset_prop_len1:
  assumes "(assumps, rhs_list) \<in> set (construct_rhs_vector_rec_M p init_assumps [a])"
  shows "set init_assumps \<subseteq> set assumps"
proof -
  obtain qs1 qs2 where a_prop: "a = (qs1, qs2)"
    using prod.exhaust by blast
  have tuple_prop: "(assumps, rhs_list) \<in> set (map (\<lambda>(new_assumps, tq). (new_assumps, [tq])) (construct_NofI_M p init_assumps qs1 qs2))"
    using a_prop assms by auto
  then obtain tq where tq_prop: "rhs_list = [tq]"
    by auto
  let ?ell = "( map (\<lambda>(new_assumps, tq). (new_assumps, [tq])) (construct_NofI_M p init_assumps qs1 qs2))"
  have tuple_in_list: "(assumps, rhs_list) \<in> set ?ell"
    using tuple_prop
    by auto
  then have "(assumps, tq) \<in> set (construct_NofI_M p init_assumps qs1 qs2)"
    using tq_prop
    by (smt (verit, best) imageE list.inject list.set_map old.prod.case old.prod.simps(1) prod.collapse)
  then have "(assumps, tq) \<in> set (construct_NofI_M p init_assumps qs1 qs2)"
    using tq_prop
    by metis
  then have "(assumps, tq) \<in> set(map construct_NofI_single_M
      (construct_NofI_R_spmods p init_assumps qs1 qs2))"
    by force
  then have "(assumps, tq) \<in> set (construct_NofI_M p init_assumps qs1 qs2)"
    using \<open>(assumps, tq) \<in> set (construct_NofI_M p init_assumps qs1 qs2)\<close> by force
  then show ?thesis using construct_NofI_M_subset_prop
    by blast
qed

lemma construct_rhs_vector_rec_M_subset_prop:
  assumes "(assumps, rhs_list) \<in> set (construct_rhs_vector_rec_M p init_assumps qs_list)"
  shows "set init_assumps \<subseteq> set assumps"
  using assms
proof (induct qs_list  arbitrary: assumps rhs_list init_assumps)
  case Nil
  then show ?case
    using construct_rhs_vector_rec_M.simps by auto
next
  case (Cons a qs_list)
  obtain qs1 qs2 where a_prop: "a = (qs1, qs2)"
    using Cons.prems Cons.hyps prod.exhaust
    by fastforce
  { assume *: "qs_list = []"
    then have "set init_assumps \<subseteq> set assumps" using construct_rhs_vector_rec_M_subset_prop_len1
        Cons.prems
      by blast
  }
  moreover   { assume *: "length qs_list \<ge> 1"
    then obtain v va where qs_list_prop: "qs_list = v # va"
      by (metis One_nat_def Suc_le_length_iff)
    let ?TQ_list = "construct_NofI_M p init_assumps qs1 qs2"
    have "(assumps, rhs_list) \<in> set (construct_rhs_vector_rec_M p init_assumps ((qs1, qs2)#qs_list))"
      using Cons.prems(1) * a_prop by auto
    then have "(assumps, rhs_list) \<in> set (concat ((map (\<lambda>(new_assumps, tq).
    (let rec = construct_rhs_vector_rec_M p new_assumps qs_list in
     map (\<lambda>r. (fst r,  tq#snd r)) rec)) ?TQ_list)))"
      using * a_prop qs_list_prop
      by (simp add: split_def)
    then obtain new_assumps tq where tq_prop: "(new_assumps,tq) \<in> set (?TQ_list)"
      "(assumps, rhs_list) \<in> set (let rec = construct_rhs_vector_rec_M p new_assumps qs_list in
     map (\<lambda>r. (fst r,  tq#snd r)) rec)"
      by auto
    then obtain rhs_rest where rhs_list_prop: "rhs_list = tq#rhs_rest"
      "(assumps, rhs_rest) \<in> set (construct_rhs_vector_rec_M p new_assumps qs_list)"
      by auto
    then have s1: "set new_assumps \<subseteq> set assumps"
      using Cons.hyps
      by auto
    have s2: "set init_assumps \<subseteq> set new_assumps"
      using construct_NofI_M_subset_prop tq_prop(1)
      by auto
    have "set init_assumps \<subseteq> set assumps"
      using s1 s2
      by auto
  }
  ultimately  show ?case
    using Cons.prems
    by (metis length_0_conv less_one linorder_neqE_nat nat_less_le rel_simps(47))
qed

lemma construct_rhs_vector_rec_M_univariate:
  (* Intuitively, assumps really contains all of the assumptions that we care about *)
  assumes rhs_list_is: "(assumps, rhs_list) \<in> set(construct_rhs_vector_rec_M p init_assumps qs_list)"
  assumes val: "\<And>p n. (p,n) \<in> set assumps \<Longrightarrow> satisfies_evaluation val p n"
  shows "rhs_list = map (\<lambda>(qs1,qs2).
    (construct_NofI_R (eval_mpoly_poly val p) (eval_mpoly_poly_list val qs1) (eval_mpoly_poly_list val qs2))) qs_list"
  using assms
proof (induct qs_list arbitrary: assumps rhs_list init_assumps)
  case Nil
  then show ?case
    using construct_rhs_vector_rec_M.simps
    by auto
next
  case (Cons a qs_list)
  obtain qs1 qs2 where a_prop: "a = (qs1, qs2)"
    using Cons.prems Cons.hyps
    using prod.exhaust by blast
  { assume *: "qs_list = []"
    let ?tq = "construct_NofI_R (eval_mpoly_poly val p) (eval_mpoly_poly_list val qs1) (eval_mpoly_poly_list val qs2)"
    have " (assumps, rhs_list) \<in> set (construct_rhs_vector_rec_M p init_assumps [(qs1, qs2)])"
      using Cons.prems(1) * a_prop by auto
    then have
      "(assumps, rhs_list) \<in> set (let TQ_list = construct_NofI_M p init_assumps qs1 qs2 in
    map (\<lambda>(new_assumps, tq). (new_assumps, [tq])) TQ_list)"
      by (metis construct_rhs_vector_rec_M.simps(2))
    then have tuple_prop:
      "(assumps, rhs_list) \<in> set ( map (\<lambda>(new_assumps, tq). (new_assumps, [tq])) (construct_NofI_M p init_assumps qs1 qs2))"
      by auto
    then obtain tq where tq_prop: "rhs_list = [tq]"
      by auto
    let ?ell = "( map (\<lambda>(new_assumps, tq). (new_assumps, [tq])) (construct_NofI_M p init_assumps qs1 qs2))"
    have tuple_in_list: "(assumps, rhs_list) \<in> set ?ell"
      using tuple_prop
      by auto
    then have "(assumps, tq) \<in> set (construct_NofI_M p init_assumps qs1 qs2)"
      using tq_prop
      by (smt (verit, best) imageE list.inject list.set_map old.prod.case old.prod.simps(1) prod.collapse)
    then have "(assumps, tq) \<in> set (construct_NofI_M p init_assumps qs1 qs2)"
      using tq_prop
      by metis
    then have "rhs_list = [construct_NofI_R (eval_mpoly_poly val p) (eval_mpoly_poly_list val qs1) (eval_mpoly_poly_list val qs2)]"
      using construct_NofI_M_univariate_tarski_query[of assumps tq p init_assumps qs1 qs2 val]
        Cons.prems(2) tq_prop
      by auto
    then have "rhs_list =
       map (\<lambda>(qs1, qs2).
               construct_NofI_R (eval_mpoly_poly val p) (eval_mpoly_poly_list val qs1)
                (eval_mpoly_poly_list val qs2))
        [(qs1, qs2)]"
      by auto
    then have "rhs_list =
       map (\<lambda>(qs1, qs2).
               construct_NofI_R (eval_mpoly_poly val p) (eval_mpoly_poly_list val qs1)
                (eval_mpoly_poly_list val qs2))
        (a # qs_list)"
      using * a_prop by auto
  }
  moreover {
    assume *: "qs_list \<noteq> []"
    then obtain v va where qs_list_prop: "qs_list = v # va"
      by (meson neq_Nil_conv)
    let ?tq = "construct_NofI_R (eval_mpoly_poly val p) (eval_mpoly_poly_list val qs1) (eval_mpoly_poly_list val qs2)"
    let ?TQ_list = "construct_NofI_M p init_assumps qs1 qs2"
    have "(assumps, rhs_list) \<in> set (construct_rhs_vector_rec_M p init_assumps ((qs1, qs2)#qs_list))"
      using Cons.prems(1) * a_prop by auto
    then have "(assumps, rhs_list) \<in> set (concat ((map (\<lambda>(new_assumps, tq).
    (let rec = construct_rhs_vector_rec_M p new_assumps qs_list in
     map (\<lambda>r. (fst r,  tq#snd r)) rec)) ?TQ_list)))"
      using * a_prop qs_list_prop
      by (simp add: split_def)
    then obtain new_assumps tq where tq_prop: "(new_assumps,tq) \<in> set (?TQ_list)"
      "(assumps, rhs_list) \<in> set (let rec = construct_rhs_vector_rec_M p new_assumps qs_list in
     map (\<lambda>r. (fst r,  tq#snd r)) rec)"
      by auto
    then obtain rhs_rest where rhs_list_prop: "rhs_list = tq#rhs_rest"
      "(assumps, rhs_rest) \<in> set (construct_rhs_vector_rec_M p new_assumps qs_list)"
      by auto
    then have subset: "set new_assumps \<subseteq> set assumps" using
        construct_rhs_vector_rec_M_subset_prop[of assumps rhs_rest p new_assumps qs_list]
      by auto
    then have val_2: "\<And> p n. (p, n) \<in> set new_assumps \<Longrightarrow> satisfies_evaluation val p n"
      using val
      by (meson Set.basic_monos(7) local.Cons(3))
    have tq_is: "tq = ?tq"
      using construct_NofI_M_univariate_tarski_query[of new_assumps tq p init_assumps qs1 qs2 val]
        tq_prop(1) Cons.prems(2) subset
      by blast
    have ih: "rhs_rest =
           map (\<lambda>(qs1, qs2).
                   construct_NofI_R (eval_mpoly_poly val p) (eval_mpoly_poly_list val qs1)
                    (eval_mpoly_poly_list val qs2))
            qs_list"
      using rhs_list_prop Cons.prems(2) val_2
      by (simp add: local.Cons(1))
    then have "rhs_list =
       map (\<lambda>(qs1, qs2).
               construct_NofI_R (eval_mpoly_poly val p) (eval_mpoly_poly_list val qs1)
                (eval_mpoly_poly_list val qs2))
        (a # qs_list)"
      using a_prop tq_is ih rhs_list_prop
      by simp
  }
  ultimately have "rhs_list =
       map (\<lambda>(qs1, qs2).
               construct_NofI_R (eval_mpoly_poly val p) (eval_mpoly_poly_list val qs1)
                (eval_mpoly_poly_list val qs2))
        (a # qs_list)"
    by blast
  then show ?case
    by blast
qed

lemma retrieve_polys_prop:
  assumes "\<And>x. x \<in> set ns \<Longrightarrow> x < length qs"
  shows "(eval_mpoly_poly_list val (retrieve_polys qs ns)) = (retrieve_polys (map (eval_mpoly_poly val) qs) ns)"
  using assms unfolding eval_mpoly_poly_list_def retrieve_polys_def by auto

(* Intuitively, with the assumptions we have, we'll get a unique RHS vector
 i.e. the output of construct_NofI_M gives uniqueness (and matches the univariate
 case) *)
lemma construct_rhs_vector_M_univariate:
  (* Intuitively, assumps really contains all of the assumptions that we care about *)
  assumes rhs_vec_is: "(assumps, rhs_vec) \<in> set(construct_rhs_vector_M p init_assumps qs Is)"
  assumes "\<And>p n. (p,n) \<in> set assumps \<Longrightarrow> satisfies_evaluation val p n"
  assumes well_def_subsets:  "\<And> Is1 Is2 n. (Is1, Is2) \<in> set Is \<Longrightarrow>
    (n \<in> set Is1 \<or> n \<in> set Is2) \<Longrightarrow> n < length qs"
  shows "rhs_vec = construct_rhs_vector_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) qs) Is"
proof  -
  have "(assumps, rhs_vec) \<in> set (map (\<lambda>res. (fst res, vec_of_list (snd res))) (construct_rhs_vector_rec_M p init_assumps (pull_out_pairs qs Is)))"
    using rhs_vec_is unfolding construct_rhs_vector_M_def by auto
  then have "\<exists>rhs_list. rhs_vec = vec_of_list rhs_list \<and> (assumps, rhs_list) \<in> set (map (\<lambda>res. (fst res, snd res)) (construct_rhs_vector_rec_M p init_assumps (pull_out_pairs qs Is)))"
    by auto
  then obtain rhs_list where rhs_list_prop: "rhs_vec = vec_of_list rhs_list \<and> (assumps, rhs_list) \<in> set (map (\<lambda>res. (fst res, snd res)) (construct_rhs_vector_rec_M p init_assumps (pull_out_pairs qs Is)))"
    by auto
  then have rhs_list_char: "rhs_list = map (\<lambda>(qs1,qs2).
    (construct_NofI_R (eval_mpoly_poly val p) (eval_mpoly_poly_list val qs1) (eval_mpoly_poly_list val qs2))) (pull_out_pairs qs Is)"
    using assms construct_rhs_vector_rec_M_univariate
      (* Takes a couple seconds to load*)
    by (smt (verit, del_insts) case_prod_beta map_eq_conv map_idI prod.exhaust_sel)
  have lov_1: "list_of_vec (map_vec
     (\<lambda>(I1, I2).
         construct_NofI_R (eval_mpoly_poly val p) (retrieve_polys (map (eval_mpoly_poly val) qs) I1)
          (retrieve_polys (map (eval_mpoly_poly val) qs) I2))
     (vec_of_list Is)) = map (\<lambda>(I1, I2).
         construct_NofI_R (eval_mpoly_poly val p) (retrieve_polys (map (eval_mpoly_poly val) qs) I1)
          (retrieve_polys (map (eval_mpoly_poly val) qs) I2)) Is"
    by (metis list_vec vec_of_list_map)
  have lov_2: "list_of_vec rhs_vec = rhs_list"
    using rhs_list_prop
    using list_vec by blast
  let ?rhs_list_var = "map (\<lambda>(I1, I2).
         construct_NofI_R (eval_mpoly_poly val p) (retrieve_polys (map (eval_mpoly_poly val) qs) I1)
          (retrieve_polys (map (eval_mpoly_poly val) qs) I2)) Is"
  have rhs_list_is: "rhs_list = ?rhs_list_var"
  proof -
    have len_is1: "length (pull_out_pairs qs Is) = length Is"
      by simp
    then have "length rhs_list = length Is"
      using rhs_list_char
      by auto
    have len_is2: "length ?rhs_list_var = length Is"
      by auto
    have "\<And>n. n  < length Is \<Longrightarrow> rhs_list ! n = ?rhs_list_var ! n"
    proof -
      fix n
      assume *: "n  < length Is"
      then obtain Is1 Is2 where Is_prop: "Is ! n = (Is1, Is2)"
        by fastforce
      then have "(pull_out_pairs qs Is) ! n = ((retrieve_polys qs Is1), (retrieve_polys qs Is2))"
        using "*" by force
      then have nth_1: "rhs_list ! n =  construct_NofI_R (eval_mpoly_poly val p) (eval_mpoly_poly_list val (retrieve_polys qs Is1)) (eval_mpoly_poly_list val (retrieve_polys qs Is2))"
        using rhs_list_char
        by (simp add: "*" len_is1)
      have nth_2: "map (\<lambda>(I1, I2).
            construct_NofI_R (eval_mpoly_poly val p) (retrieve_polys (map (eval_mpoly_poly val) qs) I1)
             (retrieve_polys (map (eval_mpoly_poly val) qs) I2)) Is ! n
      = construct_NofI_R (eval_mpoly_poly val p) (retrieve_polys (map (eval_mpoly_poly val) qs) Is1)
             (retrieve_polys (map (eval_mpoly_poly val) qs) Is2)"
        using Is_prop
        by (simp add: "*")
      have ret_poly1: "(eval_mpoly_poly_list val (retrieve_polys qs Is1)) = (retrieve_polys (map (eval_mpoly_poly val) qs) Is1)"
        unfolding retrieve_polys_def eval_mpoly_poly_list_def
        using well_def_subsets retrieve_polys_prop Is_prop
        by (metis "*" eval_mpoly_poly_list_def in_set_conv_nth retrieve_polys_def)
      have ret_poly2: "(eval_mpoly_poly_list val (retrieve_polys qs Is2)) = (retrieve_polys (map (eval_mpoly_poly val) qs) Is2)"
        unfolding retrieve_polys_def eval_mpoly_poly_list_def
        using well_def_subsets retrieve_polys_prop Is_prop
        by (metis "*" eval_mpoly_poly_list_def in_set_conv_nth retrieve_polys_def)
      have "construct_NofI_R (eval_mpoly_poly val p) (eval_mpoly_poly_list val (retrieve_polys qs Is1)) (eval_mpoly_poly_list val (retrieve_polys qs Is2))
        = construct_NofI_R (eval_mpoly_poly val p) (retrieve_polys (map (eval_mpoly_poly val) qs) Is1)
             (retrieve_polys (map (eval_mpoly_poly val) qs) Is2)"
        using ret_poly1 ret_poly2
        by auto
      then show "rhs_list ! n = ?rhs_list_var ! n"
        using nth_1 nth_2 by auto
    qed
    then show ?thesis
      using len_is1 len_is2
      by (metis \<open>length rhs_list = length Is\<close> nth_equalityI)
  qed
  then show ?thesis
    using rhs_list_is lov_2 lov_1
    unfolding construct_rhs_vector_R_def
    using rhs_list_prop by force
qed

subsection "Connect multivariate LHS vector to univariate"

lemma solve_for_lhs_vector_M_univariate:
  assumes lhs_in: "(assumps, lhs_vec) \<in> set (solve_for_lhs_M p init_assumps qs subsets matr)"
  assumes val: "\<And>p n. (p,n) \<in> set assumps \<Longrightarrow> satisfies_evaluation val p n"
  assumes well_def_subsets:  "\<And> Is1 Is2 n. (Is1, Is2) \<in> set subsets \<Longrightarrow>
    (n \<in> set Is1 \<or> n \<in> set Is2) \<Longrightarrow> n < length qs"
  shows "lhs_vec = solve_for_lhs_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) qs) subsets matr"
proof -
  let ?lhs_univ = "solve_for_lhs_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) qs) subsets matr"
  have "(assumps, lhs_vec) \<in> set(map (\<lambda>rhs. (fst rhs, solve_for_lhs_single_M p qs subsets matr (snd rhs))) (construct_rhs_vector_M p init_assumps qs subsets))"
    using lhs_in
    using solve_for_lhs_M_def by auto
  then obtain rhs where rhs_prop: "rhs \<in> set(construct_rhs_vector_M p init_assumps qs subsets)"
    "(assumps, lhs_vec) = (fst rhs, solve_for_lhs_single_M p qs subsets matr (snd rhs))"
    by auto
  then have snd_is: "snd rhs = construct_rhs_vector_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) qs) subsets"
    using construct_rhs_vector_M_univariate
    by (metis assms(2) fst_conv prod.collapse well_def_subsets)
  have "fst rhs = assumps" using rhs_prop
    by force
  have "?lhs_univ = mult_mat_vec (matr_option (dim_row matr) (mat_inverse_var matr)) (snd rhs)"
    using snd_is
    by (simp add: solve_for_lhs_R_def)
  then show ?thesis
    using rhs_prop(2) unfolding solve_for_lhs_single_M_def
    by auto
qed

subsection "Connect multivariate reduction step to univariate"

lemma reduce_system_single_M_univariate:
  assumes inset: "(assumps, mat_eq) \<in> set(reduce_system_single_M p qs (init_assumps, init_mat_eq))"
  assumes val: "\<And>p n. (p,n) \<in> set assumps \<Longrightarrow> satisfies_evaluation val p n"
  assumes init: "init_mat_eq = (m, (subs, signs))"
  assumes well_def_subsets:  "\<And> Is1 Is2 n. (Is1, Is2) \<in> set subs \<Longrightarrow>
    (n \<in> set Is1 \<or> n \<in> set Is2) \<Longrightarrow> n < length qs"
  shows "mat_eq = reduce_system_R (eval_mpoly_poly val p) ((map (eval_mpoly_poly val) qs), init_mat_eq)"
proof -
  have "(assumps, mat_eq) \<in> set (map (\<lambda>lhs. (fst lhs, reduction_step_R m signs subs (snd lhs))) (solve_for_lhs_M p init_assumps qs subs m))"
    using inset
    using assms(3)
    by force
  then obtain lhs where lhs_prop: "lhs \<in> set (solve_for_lhs_M p init_assumps qs subs m)"
    "(assumps, mat_eq) = (fst lhs, reduction_step_R m signs subs (snd lhs))"
    by auto
  then have "snd lhs = solve_for_lhs_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) qs) subs m"
    using solve_for_lhs_vector_M_univariate assms
    by (smt (verit, best) prod.exhaust_sel prod.simps(1))
  then have "mat_eq = reduction_step_R m signs subs (solve_for_lhs_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) qs) subs m)"
    using lhs_prop
    by force
  then show ?thesis
    using init
    using reduce_system_R.simps by presburger
qed

lemma reduce_system_M_univariate:
  assumes "(assumps, mat_eq) \<in> set(reduce_system_M p qs input_list)"
  assumes val: "\<And>p n. (p,n) \<in> set assumps \<Longrightarrow> satisfies_evaluation val p n"
  assumes val_qs: "val_qs = (map (eval_mpoly_poly val) qs)"
  assumes all_subsets_well_def:  "\<And> init_assumps init_mat_eq Is1 Is2 n subs m signs.
   (init_assumps, (m, (subs, signs))) \<in> set input_list \<Longrightarrow>
   (Is1, Is2) \<in> set subs \<Longrightarrow> (n \<in> set Is1 \<or> n \<in> set Is2) \<Longrightarrow> n < length qs"
  obtains acc mss where
    "(acc,mss) \<in> set (input_list)"
    "mat_eq = reduce_system_R (eval_mpoly_poly val p) (val_qs,mss)"
proof -
  have "(assumps, mat_eq) \<in> set(concat (map (reduce_system_single_M p qs) input_list))"
    by (metis assms(1) reduce_system_M.simps)
  then obtain init_assumps init_m init_subs init_signs where
    mat_eq_prop:
    "(init_assumps, (init_m, (init_subs, init_signs))) \<in> set input_list"
    "(assumps, mat_eq) \<in> set (reduce_system_single_M p qs (init_assumps, (init_m, (init_subs, init_signs))))"
    by auto
  then have well_def_subsets:  "\<And> Is1 Is2 n. (Is1, Is2) \<in> set init_subs \<Longrightarrow>
    (n \<in> set Is1 \<or> n \<in> set Is2) \<Longrightarrow> n < length qs"
    using all_subsets_well_def
    by blast
  then have mat_eq_is: "mat_eq = reduce_system_R (eval_mpoly_poly val p) ((map (eval_mpoly_poly val) qs), (init_m, (init_subs, init_signs)))"
    using reduce_system_single_M_univariate mat_eq_prop assms(2) by blast
  then show ?thesis using mat_eq_prop
    using assms(3) that by blast
qed

lemma base_case_info_M_well_def:
  assumes "(init_assumps, (m, (subs, signs))) \<in> set base_case_info_M"
  assumes "(Is1, Is2) \<in> set subs"
  assumes "n \<in> set Is1 \<or> n \<in> set Is2"
  shows "n < 1"
proof -
  have "(m, (subs, signs)) = base_case_info_R" using assms(1)
    unfolding base_case_info_M_def using Renegar_Algorithm.base_case_info_R_def Renegar_Algorithm.base_case_info_R_def
    by simp
  then have s: "subs = [([], []),([0], []),([], [0])]" unfolding base_case_info_R_def
    by auto
  have "(n \<in> set Is1 \<or> n \<in> set Is2)" using assms(3)
    by (simp add: in_set_member)
  thus ?thesis using assms(2) unfolding s by auto
qed

subsection "Connect multivariate combining systems to univariate"

(* Well-definedness property to satisfy induction hypothesis *)
lemma base_case_with_assumps_info_M_well_def:
  assumes "(init_assumps, (m, (subs, signs))) \<in> set (base_case_info_M_assumps a)"
  assumes "(Is1, Is2) \<in> set subs"
  assumes "n \<in> set Is1 \<or> n \<in> set Is2"
  shows "n < 1"
proof -
  have "(m, (subs, signs)) = base_case_info_R" using assms(1)
    unfolding base_case_info_M_assumps_def
    using Renegar_Algorithm.base_case_info_R_def Renegar_Algorithm.base_case_info_R_def
    by auto
  then have s: "subs = [([], []),([0], []),([], [0])]" unfolding base_case_info_R_def
    by auto
  have "(n \<in> set Is1 \<or> n \<in> set Is2)" using assms(3)
    by (simp add: in_set_member)
  thus ?thesis using assms(2) unfolding s by auto
qed

lemma concat_map_in_set:
  assumes "x \<in> set (concat (map f ls))"
  shows "\<exists>i < length ls. x \<in> set (f (ls ! i))"
  using assms
  by (smt (verit, best) in_set_conv_nth length_map map_nth_eq_conv nth_concat_split)

lemma combine_systems_R_snd:
  assumes "length qs1 = length new_qs1"
  shows "snd (combine_systems_R p (qs1, sys1) (qs2, sys2)) =
    snd (combine_systems_R new_p (new_qs1, sys1) (new_qs2, sys2))"
proof -
  obtain  m1 sub1 sgn1 where sys1: "sys1 = (m1, sub1, sgn1)"
    using prod_cases3 by blast
  obtain  m2 sub2 sgn2 where sys2: "sys2 = (m2, sub2, sgn2)"
    using prod_cases3 by blast
  have h1: "snd (combine_systems_R p (qs1, sys1) (qs2, sys2)) =
    snd (smash_systems_R p qs1 qs2 sub1 sub2 sgn1 sgn2 m1 m2)"
    using sys1 sys2 by auto
  have h2: "snd (combine_systems_R new_p (new_qs1, sys1) (new_qs2, sys2)) =
    snd (smash_systems_R new_p new_qs1 new_qs2 sub1 sub2 sgn1 sgn2 m1 m2)"
    using sys1 sys2 by auto
  show ?thesis
    using h1 h2 assms unfolding smash_systems_R_def by auto
qed

subsection "Subset Properties"

lemma construct_rhs_vector_M_subset_prop:
  assumes "(assumps, rhs_vec) \<in> set (construct_rhs_vector_M p init_assumps qs subsets)"
  shows "set init_assumps \<subseteq> set assumps"
proof -
  obtain rhs_list where "(assumps, rhs_list) \<in> set  (construct_rhs_vector_rec_M p init_assumps (pull_out_pairs qs subsets))"
    "rhs_vec = vec_of_list rhs_list"
    using assms unfolding construct_rhs_vector_M_def by auto
  then show ?thesis
    using construct_rhs_vector_rec_M_subset_prop by auto
qed

lemma construct_lhs_vector_rec_M_subset_prop:
  assumes "(assumps, lhs_list) \<in> set (solve_for_lhs_M p init_assumps qs subsets matr)"
  shows "set init_assumps \<subseteq> set assumps"
proof -
  obtain rhs_vec where "(assumps, rhs_vec) \<in> set (construct_rhs_vector_M p init_assumps qs subsets)"
    "lhs_list = matr_option (dim_row matr) (mat_inverse_var matr) *\<^sub>v rhs_vec "
    using assms unfolding solve_for_lhs_M_def solve_for_lhs_single_M_def
    by auto
  then show ?thesis
    using construct_rhs_vector_M_subset_prop[of assumps] by auto
qed

lemma reduce_system_single_M_subset_prop:
  assumes "(assumps, mat_eq) \<in> set (reduce_system_single_M p qs (init_assumps, (m,subs,signs)))"
  shows "set init_assumps \<subseteq> set assumps"
proof -
  obtain lhs_vec where "(assumps, lhs_vec) \<in> set (solve_for_lhs_M p init_assumps qs subs m)"
    "mat_eq = reduction_step_R m signs subs lhs_vec"
    using assms
    by (auto)
  then show ?thesis
    using construct_lhs_vector_rec_M_subset_prop[of assumps]
    by auto
qed

lemma calculate_data_assumps_M_subset:
  assumes "(assumps, mat_eq) \<in> set (calculate_data_assumps_M p qs init_assumps)"
  shows "set init_assumps \<subseteq> set assumps"
  using assms
proof (induction "length qs" arbitrary: qs assumps mat_eq rule: less_induct)
  case less
  {assume *: "length qs = 0"
    then have "(assumps, mat_eq) \<in> set (map (\<lambda>(assumps,(a,(b,c))). (assumps, (a,b,map (drop 1) c))) (reduce_system_M p [1] (base_case_info_M_assumps init_assumps)))"
      using less.prems by auto
    then obtain a b c where "(assumps, (a, (b, c))) \<in> set (reduce_system_M p [1] (base_case_info_M_assumps init_assumps))"
      by auto
    then have "(assumps, (a, (b, c))) \<in> set (concat (map (reduce_system_single_M p [1]) [(init_assumps, base_case_info_R)]))"
      unfolding base_case_info_M_assumps_def
      using Renegar_Algorithm.base_case_info_R_def Renegar_Algorithm.base_case_info_R_def
      by (auto)
    then have "(assumps, (a, (b, c))) \<in> set( reduce_system_single_M p [1] (init_assumps, base_case_info_R))"
      by auto
    then have "set init_assumps \<subseteq> set assumps"
      unfolding base_case_info_R_def
      using reduce_system_single_M_subset_prop[of assumps "(a, (b, c))" p "[1]" init_assumps]
      by auto
  }
  moreover {assume *: "length qs = 1"
    then have "(assumps, mat_eq) \<in> set (reduce_system_M p qs (base_case_info_M_assumps init_assumps))"
      using less.prems by auto
    then obtain a b c where "(assumps, (a, (b, c))) \<in> set (reduce_system_M p qs (base_case_info_M_assumps init_assumps))"
      by (smt (verit) prod.sel(2) prod_cases4)
    then have "(assumps, (a, (b, c))) \<in> set (concat (map (reduce_system_single_M p qs) [(init_assumps, base_case_info_R)]))"
      unfolding base_case_info_M_assumps_def
      using Renegar_Algorithm.base_case_info_R_def Renegar_Algorithm.base_case_info_R_def
      by (auto)
    then have "(assumps, (a, (b, c))) \<in> set( reduce_system_single_M p qs (init_assumps, base_case_info_R))"
      by auto
    then have "set init_assumps \<subseteq> set assumps"
      unfolding base_case_info_R_def
      using reduce_system_single_M_subset_prop[of assumps "(a, (b, c))" p qs init_assumps]
      by auto
  }
  moreover {assume *: "length qs > 1"
    let ?len = "length qs"
    let ?q1 = "take (?len div 2) qs"
    let ?left = "calculate_data_assumps_M p ?q1 init_assumps"
    let ?q2 = "drop (?len div 2) qs"
    let ?right = "calculate_data_assumps_M p ?q2 init_assumps"
    let ?comb = "combine_systems_M p ?q1 ?left ?q2 ?right"
    have len_q1_less: "length ?q1 < length qs"
      using * by auto
    have inset_red: "(assumps, mat_eq) \<in> set(reduce_system_M p (fst ?comb) (snd ?comb))"
      using * less.prems
      by (smt (verit, best) calculate_data_assumps_M.simps less_one nat_less_le not_one_less_zero)
    have "fst ?comb = qs"
      by auto
    then have "(assumps, mat_eq) \<in> set(reduce_system_M p qs (snd ?comb))"
      using inset_red
      by auto
    then obtain assm_pre m_pre subs_pre signs_pre where assumps_reduce:
      "(assm_pre, (m_pre, subs_pre, signs_pre)) \<in> set (snd ?comb)"
      "(assumps, mat_eq) \<in> set(reduce_system_single_M p qs (assm_pre, (m_pre, subs_pre, signs_pre)))"
      by (metis concat_map_in_set find_consistent_signs_at_roots_single_M.cases nth_mem reduce_system_M.simps)
    then obtain meq1 meq2 assm1 assm2 where subsystems:
      "(assm1, meq1) \<in> set (calculate_data_assumps_M p ?q1 init_assumps)"
      "(assm2, meq2) \<in> set (calculate_data_assumps_M p ?q2 init_assumps)"
      "(assm_pre, (m_pre, subs_pre, signs_pre)) = combine_systems_single_M p ?q1 (assm1, meq1) ?q2 (assm2, meq2)"
      by auto (* Takes a second to load *)
    then have assm_pre: "assm_pre = assm1@assm2"
      by auto
    have "set init_assumps \<subseteq> set assm1"
      using less.hyps[of ?q1] less.prems subsystems(1) len_q1_less
      by auto (* Takes a second to load *)
    then have "set init_assumps \<subseteq> set assm_pre"
      using assm_pre by auto
    then have "set init_assumps \<subseteq> set assumps"
      using assumps_reduce(2) reduce_system_single_M_subset_prop[of assumps mat_eq p qs assm_pre m_pre subs_pre signs_pre]
      by auto
  }
  ultimately show ?case
    by (meson less_one linorder_neqE_nat)
qed

lemma extract_signs_M_subset:
  assumes "(assumps, signs) \<in> set (extract_signs (calculate_data_assumps_M p qs init_assumps))"
  shows "set init_assumps \<subseteq> set assumps"
proof -
  obtain mat_eq where
    "(assumps, mat_eq) \<in> set (calculate_data_assumps_M p qs init_assumps)"
    "signs = snd (snd mat_eq)"
    using assms by auto
  then show ?thesis
    using calculate_data_assumps_M_subset[of assumps mat_eq p qs init_assumps]
    by auto
qed

subsection "Top-level Results: Connect calculate data methods to univariate"

(* Well-definedness property to satisfy induction hypothesis *)
lemma all_list_constr_R_matches_well_def:
  assumes welldef: "all_list_constr_R subs (length q)"
  shows "(Is1, Is2) \<in> set (subs) \<Longrightarrow> n \<in> set Is1 \<or> n \<in> set Is2 \<Longrightarrow> n < length q"
proof -
  assume inset: "(Is1, Is2) \<in> set (subs)"
  assume inlist: "n \<in> set Is1 \<or> n \<in> set Is2"
  have welldef_var: "\<forall>x. x \<in> set subs \<longrightarrow>
        list_constr (fst x) (length q) \<and> list_constr (snd x) (length q)"
    using welldef  unfolding all_list_constr_R_def
    by (simp add: in_set_member)
  have "(Is1, Is2) \<in> set subs"
    using inset by auto
  then have "(\<forall>x\<in>set Is1. x < length q) \<and> (\<forall>x\<in>set Is2. x < length q)"
    using welldef_var
    by (simp add: Ball_set list_constr_def)
  then show "n < length q"
    using inlist
    by metis
qed

lemma calculate_data_M_univariate:
  assumes mat_eq: "(assumps, mat_eq) \<in> set (calculate_data_M p qs)"
  assumes "\<And>p n. (p,n) \<in> set assumps \<Longrightarrow> satisfies_evaluation val p n"
  assumes p_nonzero: "eval_mpoly_poly val p \<noteq> 0"
  shows "calculate_data_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) qs) = mat_eq"
  using assms
proof (induct "length qs" arbitrary: val p mat_eq assumps qs rule: less_induct)
  case (less qs val p mat_eq assumps)
  have "length qs = 0 \<or> length qs = 1 \<or> length qs > 1"
    by (meson less_one nat_neq_iff)
  moreover {assume *: "length qs = 0"
    let ?m = "(mat_of_rows_list 3 [[1,1,1], [0,1,0], [1,0,-1]])"
    let ?subs = "[([], []),([0], []),([], [0])]"
    let ?signs = "[[1],[0],[-1]]"
    let ?eval_p = "eval_mpoly_poly val p"
    have mat_eq_in: "(assumps, mat_eq) \<in> set (calculate_data_M p [])"
      using * less.prems(1) by auto
    let ?map_base = "map (\<lambda>(assumps,(a,(b,c))). (assumps, (a,b,map (drop 1) c))) (reduce_system_M p [1] base_case_info_M)"
    have "(assumps, mat_eq) \<in> set ?map_base"
      using mat_eq_in
      by auto
    then obtain a1 b1 c1 where a1b1c1_prop:
      "(assumps, (a1, (b1, c1))) \<in> set (reduce_system_M p [1] base_case_info_M)"
      "mat_eq = (a1, (b1, map (drop 1) c1))"
      by auto
    have base_case_well_def: "\<And>init_assumps init_mat_eq Is1 Is2 n subs m signs.
        (init_assumps, m, subs, signs) \<in> set base_case_info_M \<Longrightarrow>
        (Is1, Is2) \<in> set subs \<Longrightarrow> n \<in> set Is1 \<or> n \<in> set Is2 \<Longrightarrow> n < length [1]"
      using base_case_info_M_well_def by auto
    have map_is: "[1] = map (eval_mpoly_poly val) [1] "
      unfolding eval_mpoly_poly_def eval_mpoly_def
      by auto
   then have "\<exists>acc mss. (acc,mss) \<in> set (base_case_info_M) \<and> (a1, (b1, c1)) = reduce_system_R (eval_mpoly_poly val p) ([1],mss)"
      using reduce_system_M_univariate[of "assumps" "(a1, b1, c1)" p "[1]" base_case_info_M val "[1]"]
        a1b1c1_prop less(3) base_case_well_def
      apply (auto)
      by metis
    then obtain acc mss where a1b1c1_connect:
      "(acc,mss) \<in> set (base_case_info_M)"
      "(a1, (b1, c1)) = reduce_system_R (eval_mpoly_poly val p) ([1],mss)"
      by auto
    then have mss_is: "mss = base_case_info_R"
      unfolding base_case_info_M_def
      by auto
    obtain a b c where abc_prop: "(a, b, c) = reduction_step_R ?m ?signs ?subs (solve_for_lhs_R ?eval_p [1] ?subs ?m)"
      by (metis reduction_step_R.simps)
    then have "(a, b, c) = (a1, b1, c1)"
      using abc_prop a1b1c1_prop
      by (metis a1b1c1_connect(2) base_case_info_R_def mss_is reduce_system_R.simps)
    then have mat_eq_is: "(a, b, map (drop (Suc 0)) c) = mat_eq"
      using a1b1c1_prop(2) by (auto)
    have "qs = [] \<Longrightarrow> mat_eq = (a, b, map (drop (Suc 0)) c) \<Longrightarrow>
      (case reduce_system_R (eval_mpoly_poly val p) ([1], base_case_info_R) of
      (a, b, c) \<Rightarrow> (a, b, map (drop (Suc 0)) c)) = (a, b, map (drop (Suc 0)) c) "
      using abc_prop unfolding base_case_info_R_def
      using  old.prod.case reduce_system_R.simps
      by (smt (verit, ccfv_SIG))
    then have "calculate_data_R ?eval_p (map (eval_mpoly_poly val) qs)= mat_eq"
      using * mat_eq_is
      by simp
  }
  moreover {assume *: "length qs = 1"
    have meq: "(assumps, mat_eq) \<in> set (reduce_system_M p qs base_case_info_M)"
      using "*" le_eq_less_or_eq less(2) one_neq_zero by auto
    have **: "\<And>init_assumps init_mat_eq Is1 Is2 n subs m signs.
      (init_assumps, m, subs, signs) \<in> set base_case_info_M \<Longrightarrow>
      (Is1, Is2) \<in> set subs \<Longrightarrow>
      n \<in> set Is1 \<or> n \<in> set Is2 \<Longrightarrow>
      n < length qs" unfolding *
      using base_case_info_M_well_def
      by meson
    from reduce_system_M_univariate[OF meq less(3), of " map (eval_mpoly_poly val)
   qs"]
    obtain acc mss where ams: "(acc,mss) \<in> set base_case_info_M"
      "mat_eq = reduce_system_R (eval_mpoly_poly val p)
      (map (eval_mpoly_poly val) qs, mss)"
      using "**" by blast
    then have "mss = base_case_info_R" unfolding base_case_info_M_def
      by auto
    then have "calculate_data_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) qs) = mat_eq"
      using ams * by simp
  }
    (* Inductive case: progress by breaking down, using IH, then piecing back together.
      It's the reduction of a combination of two smaller matrix equation pieces. *)
  moreover {assume *: "length qs  > 1"
    have inset: "(assumps, mat_eq) \<in> set (calculate_data_M p qs)"
      using less.prems(1) by auto
    let ?len = "length qs"
    let ?q1 = "take (?len div 2) qs"
    let ?q2 = "drop (?len div 2) qs"
    let ?left = "calculate_data_M p ?q1"
    let ?right = "calculate_data_M p ?q2"
    let ?comb = "combine_systems_M p ?q1 ?left ?q2 ?right"
    let ?eval_p = "(eval_mpoly_poly val p)"
    let ?eval_q1 = "(map (eval_mpoly_poly val) ?q1)"
    let ?eval_q2 = "(map (eval_mpoly_poly val) ?q2)"
    have map_q1: "map (eval_mpoly_poly val) ?q1 =
      (take (length (map (eval_mpoly_poly val) qs) div 2) (map (eval_mpoly_poly val) qs))"
      by (auto simp add: take_map)
    have map_q2: "map (eval_mpoly_poly val) ?q2 =
      (drop (length (map (eval_mpoly_poly val) qs) div 2) (map (eval_mpoly_poly val) qs))"
      by (auto simp add: drop_map)
    have "fst ?comb = qs"
      by auto
    then have "(assumps, mat_eq) \<in> set (reduce_system_M p qs (snd ?comb))"
      using inset *
      by (smt (verit) calculate_data_M.simps less_numeral_extra(2) less_one nat_less_le)
    then have "(assumps, mat_eq) \<in> set (concat (map (reduce_system_single_M p qs) (snd ?comb)))"
      by (metis reduce_system_M.simps)
    then have "\<exists>sys. sys \<in> set (snd ?comb) \<and> (assumps, mat_eq) \<in> set(reduce_system_single_M p qs sys)"
      using concat_map_in_set in_set_member
      by (metis nth_mem)
    then obtain a_pre me_pre  where reduce_prop: "(a_pre, me_pre) \<in> set (snd ?comb)"
      "(assumps, mat_eq) \<in> set(reduce_system_single_M p qs (a_pre, me_pre))"
      by fastforce
    then obtain a1 me1 a2 me2 where mes_prop: "(a1, me1) \<in> set ?left"
      "(a2, me2) \<in> set ?right"
      "(a_pre, me_pre) = combine_systems_single_M p ?q1 (a1, me1) ?q2 (a2, me2)"
      by auto
    then have a_pre: "a_pre = a1@a2"
      by auto
    have lengt: "length qs div 2 \<ge> 1"
      using * by auto
    then have len_q1: "length ?q1 < length qs"
      by auto
    have len_q2: "length ?q2 < length qs"
      using lengt by auto
    obtain mat_pre subs_pre signs_pre where me_decomp:
      "me_pre = (mat_pre,subs_pre,signs_pre)"
      using mes_prop
      using prod_cases3 by blast
    then have "assumps \<in> set (map fst (solve_for_lhs_M p a_pre qs subs_pre mat_pre))"
      using reduce_prop(2) by auto
    then have "assumps \<in> set (map fst (construct_rhs_vector_M p a_pre qs subs_pre))"
      unfolding solve_for_lhs_M_def by auto
    then obtain a_rhs_list where "(assumps, a_rhs_list)
    \<in> set (construct_rhs_vector_rec_M p a_pre (pull_out_pairs qs subs_pre))"
      unfolding construct_rhs_vector_M_def by auto
    then have a_pre_subset: "set a_pre \<subseteq> set assumps"
      using construct_rhs_vector_rec_M_subset_prop[of assumps _ p a_pre "(pull_out_pairs qs subs_pre)"]
      by auto
    have set_a1: "set a1 \<subseteq> set assumps"
      using a_pre_subset a_pre by auto
    then have a1_satisfies: "(\<And>p n. (p, n) \<in> set a1 \<Longrightarrow> satisfies_evaluation val p n)"
      using less(3) by blast
    from less.hyps[of ?q1 a1 me1, OF len_q1 mes_prop(1) a1_satisfies]
    have me1_ind: "calculate_data_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) ?q1) = me1"
      using less(4) by blast
    have set_a2: "set a2 \<subseteq> set assumps"
      using a_pre_subset a_pre by auto
    then have a2_satisfies: "(\<And>p n. (p, n) \<in> set a2 \<Longrightarrow> satisfies_evaluation val p n)"
      using less(3) by blast
    from less.hyps[of ?q2 a2 me2, OF len_q2 mes_prop(2) a2_satisfies]
    have me2_ind: "calculate_data_R ?eval_p (map (eval_mpoly_poly val) ?q2) = me2"
      using less(4) by blast
    have "a_pre = a1 @ a2 \<Longrightarrow> me_pre =
      snd (combine_systems_R p (take (length qs div 2) qs, me1)
            (drop (length qs div 2) qs, me2)) \<Longrightarrow>
      snd (combine_systems_R p (take (length qs div 2) qs, me1)
            (drop (length qs div 2) qs, me2)) =
      snd (combine_systems_R (eval_mpoly_poly val p)
            (map (eval_mpoly_poly val) (take (length qs div 2) qs), me1)
            (map (eval_mpoly_poly val) (drop (length qs div 2) qs), me2))"
      using combine_systems_R_snd
      by (metis length_map)
    then have me_pre: "me_pre = snd (combine_systems_R (eval_mpoly_poly val p) ((map (eval_mpoly_poly val) ?q1), me1) ((map (eval_mpoly_poly val) ?q2), me2))"
      using mes_prop(3)
      by (auto)
    obtain mat_pre1 subs_pre1 signs_pre1 where me1_decomp:
      "me1 = (mat_pre1,subs_pre1,signs_pre1)"
      using prod_cases3 by blast
    obtain mat_pre2 subs_pre2 signs_pre2 where me2_decomp:
      "me2 = (mat_pre2,subs_pre2,signs_pre2)"
      using prod_cases3 by blast
    have fst_comb: "fst (combine_systems_R ?eval_p ((map (eval_mpoly_poly val) ?q1), me1) ((map (eval_mpoly_poly val) ?q2), me2)) = (map (eval_mpoly_poly val) ?q1) @ (map (eval_mpoly_poly val) ?q2)"
    proof -
      have "fst (combine_systems_R (eval_mpoly_poly val p) ((map (eval_mpoly_poly val) ?q1), me1) ((map (eval_mpoly_poly val) ?q2), me2)) =
        fst (smash_systems_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) ?q1) (map (eval_mpoly_poly val) ?q2) subs_pre1 subs_pre2 signs_pre1 signs_pre2 mat_pre1 mat_pre2)"
        using combining_to_smash_R me1_decomp me2_decomp by force
      then show ?thesis
        unfolding smash_systems_R_def by auto
    qed
    then have "map (eval_mpoly_poly val) qs = fst (combine_systems_R (eval_mpoly_poly val p) ((map (eval_mpoly_poly val) ?q1), me1) ((map (eval_mpoly_poly val) ?q2), me2))"
      by (metis append_take_drop_id map_append)
    then have me_pre_var:  "(map (eval_mpoly_poly val) qs, me_pre) = (combine_systems_R (eval_mpoly_poly val p) ((map (eval_mpoly_poly val) ?q1), me1) ((map (eval_mpoly_poly val) ?q2), me2))"
      using me_pre by auto
    have len_hyp: "length (map (eval_mpoly_poly val) qs) > 1"
      using * by auto
    have len_eq: "length (map (eval_mpoly_poly val) qs) = length qs"
      by simp
    have len_q1_gt0: "length (map (eval_mpoly_poly val) ?q1) > 0"
      using len_hyp len_eq by auto
    have len_q2_gt0: "length (map (eval_mpoly_poly val) ?q2) > 0"
      using len_hyp len_eq by auto
    let ?uni_sys_q1 = "calculate_data_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) ?q1)"
    have sat_props_q1_univ: "satisfies_properties_R ?eval_p (map (eval_mpoly_poly val) ?q1) (get_subsets_R ?uni_sys_q1) (get_signs_R ?uni_sys_q1) (get_matrix_R ?uni_sys_q1)"
      using calculate_data_satisfies_properties_R[of "?eval_p" "(map (eval_mpoly_poly val) (take (length qs div 2) qs))"]
        len_q1_gt0  using less.prems(3) by auto
    let ?uni_sys_q2 = "calculate_data_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) ?q2)"
    have sat_props_q2_univ: "satisfies_properties_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) ?q2) (get_subsets_R ?uni_sys_q2) (get_signs_R ?uni_sys_q2) (get_matrix_R ?uni_sys_q2)"
      using calculate_data_satisfies_properties_R[of "(eval_mpoly_poly val p)" "(map (eval_mpoly_poly val) (drop (length qs div 2) qs))"]
        len_q2_gt0  using less.prems(3)  by auto
    have comb_satisfies: "satisfies_properties_R ?eval_p (?eval_q1@(map (eval_mpoly_poly val) ?q2))
  (get_subsets_R (snd ((combine_systems_R ?eval_p (?eval_q1,?uni_sys_q1) (?eval_q2,?uni_sys_q2)))))
  (get_signs_R (snd ((combine_systems_R ?eval_p (?eval_q1,?uni_sys_q1) (?eval_q2,?uni_sys_q2)))))
  (get_matrix_R (snd ((combine_systems_R ?eval_p (?eval_q1,?uni_sys_q1) (?eval_q2,?uni_sys_q2)))))"
      using combining_sys_satisfies_properties_R[of ?eval_p ?eval_q1 ?eval_q2] len_q1_gt0 len_q2_gt0 less.prems(3)
        sat_props_q2_univ sat_props_q1_univ
      by auto (* takes a second to load *)
    then have well_def_subs_pre: "all_list_constr_R (get_subsets_R (snd ((combine_systems_R ?eval_p (?eval_q1,?uni_sys_q1) (?eval_q2,?uni_sys_q2))))) (length (?eval_q1@?eval_q2))"
      unfolding satisfies_properties_R_def by auto
    have get_subs_pre: "(get_subsets_R (snd ((combine_systems_R ?eval_p (?eval_q1,?uni_sys_q1) (?eval_q2,?uni_sys_q2))))) = subs_pre"
      using me_decomp unfolding get_subsets_R_def
      by (metis fst_conv me1_ind me2_ind me_pre_var snd_conv)
    have well_def: "(\<And>Is1 Is2 n. (Is1, Is2) \<in> set (fst (snd me_pre)) \<Longrightarrow> n \<in> set Is1 \<or> n \<in> set Is2 \<Longrightarrow> n < length qs)"
      using well_def_subs_pre get_subs_pre
        all_list_constr_R_matches_well_def[of subs_pre]
      by (smt (verit, ccfv_SIG) fst_comb fst_conv get_subsets_R_def length_map me1_ind me2_ind me_pre_var snd_conv)
    then have reduce_mat_eq: "mat_eq = reduce_system_R (eval_mpoly_poly val p) ((map (eval_mpoly_poly val) qs), me_pre)"
      using reduce_system_single_M_univariate[OF reduce_prop(2) less.prems(2)]
      by (metis prod.exhaust_sel)
    let ?eval_qs = "(map (eval_mpoly_poly val) qs)"
    have "calculate_data_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) qs) =
     (let q1 = take ((length ?eval_qs) div 2) ?eval_qs; left = calculate_data_R ?eval_p q1;
         q2 = drop ((length ?eval_qs) div 2) ?eval_qs; right = calculate_data_R ?eval_p q2;
         comb = combine_systems_R ?eval_p (q1,left) (q2,right) in
         reduce_system_R ?eval_p comb)"
      using len_hyp
      by (smt (z3) calculate_data_R.simps less_one nat_less_le semiring_norm(136))
    moreover have "... = (let q1 =(map (eval_mpoly_poly val) ?q1);
         left = calculate_data_R (eval_mpoly_poly val p) q1;
         q2 = (map (eval_mpoly_poly val) ?q2);
         right = calculate_data_R (eval_mpoly_poly val p) q2
     in Let (combine_systems_R (eval_mpoly_poly val p) (q1, left) (q2, right))
         (reduce_system_R (eval_mpoly_poly val p))) "
      using map_q1 map_q2 by auto
    moreover have "... = (let q1 =(map (eval_mpoly_poly val) ?q1); left = me1;
      q2 = (map (eval_mpoly_poly val) ?q2); right = me2 in
      Let (combine_systems_R (eval_mpoly_poly val p) (q1, left) (q2, right))
         (reduce_system_R (eval_mpoly_poly val p)))"
      unfolding Let_def me1_ind me2_ind by auto
    moreover have "... = mat_eq"
      unfolding Let_def reduce_mat_eq me_pre_var by auto
    ultimately have "calculate_data_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) qs) = mat_eq"
      by auto (* Can take a second to load *)
  }
  ultimately show ?case by blast
qed

lemma calculate_data_M_assumps_univariate:
  assumes mat_eq: "(assumps, mat_eq) \<in> set (calculate_data_assumps_M p qs init_assumps)"
  assumes "\<And>p n. (p,n) \<in> set assumps \<Longrightarrow> satisfies_evaluation val p n"
  assumes p_nonzero: "eval_mpoly_poly val p \<noteq> 0"
  shows "calculate_data_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) qs) = mat_eq"
  using assms
proof (induct "length qs" arbitrary: val p mat_eq assumps qs rule: less_induct)
  case (less qs val p mat_eq assumps)
  have "length qs = 0 \<or> length qs = 1 \<or> length qs > 1"
    by (meson less_one nat_neq_iff)
  moreover {assume *: "length qs = 0"
    let ?m = "(mat_of_rows_list 3 [[1,1,1], [0,1,0], [1,0,-1]])"
    let ?subs = "[([], []),([0], []),([], [0])]"
    let ?signs = "[[1],[0],[-1]]"
    let ?eval_p = "eval_mpoly_poly val p"
    have mat_eq_in: "(assumps, mat_eq) \<in> set (calculate_data_assumps_M p [] init_assumps)"
      using * less.prems(1) by auto
    let ?map_base = "map (\<lambda>(assumps,(a,(b,c))). (assumps, (a,b,map (drop 1) c))) (reduce_system_M p [1] (base_case_info_M_assumps init_assumps))"
    have "(assumps, mat_eq) \<in> set ?map_base"
      using mat_eq_in
      by auto
    then obtain a1 b1 c1 where a1b1c1_prop:
      "(assumps, (a1, (b1, c1))) \<in> set (reduce_system_M p [1] (base_case_info_M_assumps init_assumps))"
      "mat_eq = (a1, (b1, map (drop 1) c1))"
      by auto
    have base_case_well_def: "\<And>in_a init_mat_eq Is1 Is2 n subs m signs.
        (in_a, m, subs, signs) \<in> set (base_case_info_M_assumps init_assumps) \<Longrightarrow>
        (Is1, Is2) \<in> set subs \<Longrightarrow> n \<in> set Is1 \<or> n \<in> set Is2 \<Longrightarrow> n < length [1]"
      using base_case_with_assumps_info_M_well_def
      by auto
    have " [1] = map (eval_mpoly_poly val) [1] "
      unfolding eval_mpoly_poly_def eval_mpoly_def
      by auto
    then have "\<exists>acc mss. (acc,mss) \<in> set ((base_case_info_M_assumps init_assumps)) \<and> (a1, (b1, c1)) = reduce_system_R (eval_mpoly_poly val p) ([1],mss)"
      using reduce_system_M_univariate[of "assumps" "(a1, b1, c1)" p "[1]" "(base_case_info_M_assumps init_assumps)" val "[1]"]
        a1b1c1_prop less(3) base_case_well_def apply (auto)
      by metis
    then obtain acc mss where a1b1c1_connect:
      "(acc,mss) \<in>  set ((base_case_info_M_assumps init_assumps))"
      "(a1, (b1, c1)) = reduce_system_R (eval_mpoly_poly val p) ([1],mss)"
      by auto
    then have mss_is: "mss = base_case_info_R"
      unfolding base_case_info_M_assumps_def
      using Renegar_Algorithm.base_case_info_R_def Renegar_Algorithm.base_case_info_R_def
      by auto
    obtain a b c where abc_prop: "(a, b, c) = reduction_step_R ?m ?signs ?subs (solve_for_lhs_R ?eval_p [1] ?subs ?m)"
      by (metis reduction_step_R.simps)
    then have "(a, b, c) = (a1, b1, c1)"
      using abc_prop a1b1c1_prop
      by (metis a1b1c1_connect(2) base_case_info_R_def mss_is reduce_system_R.simps)
    then have mat_eq_is: "(a, b, map (drop (Suc 0)) c) = mat_eq"
      using a1b1c1_prop(2) by (auto)
    have "(a, b, c) =
  reduction_step_R (mat_of_rows_list 3 [[1, 1, 1], [0, 1, 0], [1, 0, - 1]])
   [[1], [0], [- 1]] [([], []), ([0], []), ([], [0])]
   (solve_for_lhs_R (eval_mpoly_poly val p) [1]
     [([], []), ([0], []), ([], [0])]
     (mat_of_rows_list 3 [[1, 1, 1], [0, 1, 0], [1, 0, - 1]]))"
      using abc_prop
      unfolding base_case_info_R_def
      by (smt (verit) old.prod.case reduce_system_R.simps)
    then have "calculate_data_R ?eval_p (map (eval_mpoly_poly val) qs)= mat_eq"
      using mat_eq_is *
      by (smt (z3) a1b1c1_connect(2) a1b1c1_prop(2) calculate_data_R.simps length_map mss_is split_conv)
  }
  moreover {assume *: "length qs = 1"
    have meq: "(assumps, mat_eq) \<in> set (reduce_system_M p qs (base_case_info_M_assumps init_assumps))"
      using "*" le_eq_less_or_eq less(2) one_neq_zero by auto
    have **: "\<And>init_assumps init_mat_eq Is1 Is2 n subs m signs.
      (init_assumps, m, subs, signs) \<in> set (base_case_info_M_assumps init_assumps) \<Longrightarrow>
      (Is1, Is2) \<in> set subs \<Longrightarrow>
      n \<in> set Is1 \<or> n \<in> set Is2 \<Longrightarrow>
      n < length qs" unfolding *
      using base_case_with_assumps_info_M_well_def
      by meson
    from reduce_system_M_univariate[OF meq less(3), of " map (eval_mpoly_poly val)
   qs"]
    obtain acc mss where ams: "(acc,mss) \<in> set (base_case_info_M_assumps init_assumps)"
      "mat_eq = reduce_system_R (eval_mpoly_poly val p)
      (map (eval_mpoly_poly val) qs, mss)"
      using "**"
      apply (auto)
      by (smt (z3) "*" base_case_with_assumps_info_M_well_def)
    then have "mss = base_case_info_R" unfolding base_case_info_M_assumps_def
      using Renegar_Algorithm.base_case_info_R_def Renegar_Algorithm.base_case_info_R_def
      by auto
    then have "calculate_data_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) qs) = mat_eq"
      using ams * by simp
  }
    (* Inductive case: progress by breaking down, using IH, then piecing back together.
      It's the reduction of a combination of two smaller matrix equation pieces. *)
  moreover {assume *: "length qs  > 1"
    have inset: "(assumps, mat_eq) \<in> set (calculate_data_assumps_M p qs init_assumps)"
      using less.prems(1)
      by auto
    let ?len = "length qs"
    let ?q1 = "take (?len div 2) qs"
    let ?q2 = "drop (?len div 2) qs"
    let ?left = "calculate_data_assumps_M p ?q1 init_assumps"
    let ?right = "calculate_data_assumps_M p ?q2 init_assumps"
    let ?comb = "combine_systems_M p ?q1 ?left ?q2 ?right"
    let ?eval_p = "(eval_mpoly_poly val p)"
    let ?eval_q1 = "(map (eval_mpoly_poly val) ?q1)"
    let ?eval_q2 = "(map (eval_mpoly_poly val) ?q2)"
    have map_q1: "map (eval_mpoly_poly val) ?q1 =
      (take (length (map (eval_mpoly_poly val) qs) div 2) (map (eval_mpoly_poly val) qs))"
      by (auto simp add: take_map)
    have map_q2: "map (eval_mpoly_poly val) ?q2 =
      (drop (length (map (eval_mpoly_poly val) qs) div 2) (map (eval_mpoly_poly val) qs))"
      by (auto simp add: drop_map)
    have "fst ?comb = qs"
      by auto
    then have "(assumps, mat_eq) \<in> set (reduce_system_M p qs (snd ?comb))"
      using inset *
      by (smt (z3) calculate_data_assumps_M.simps gr_implies_not0 less_one nat_less_le)
    then have "(assumps, mat_eq) \<in> set (concat (map (reduce_system_single_M p qs) (snd ?comb)))"
      by (metis reduce_system_M.simps)
    then have "\<exists>sys. sys \<in> set (snd ?comb) \<and> (assumps, mat_eq) \<in> set(reduce_system_single_M p qs sys)"
      using concat_map_in_set in_set_member
      by (metis nth_mem)
    then obtain a_pre me_pre  where reduce_prop: "(a_pre, me_pre) \<in> set (snd ?comb)"
      "(assumps, mat_eq) \<in> set(reduce_system_single_M p qs (a_pre, me_pre))"
      by fastforce
    then obtain a1 me1 a2 me2 where mes_prop: "(a1, me1) \<in> set ?left"
      "(a2, me2) \<in> set ?right"
      "(a_pre, me_pre) = combine_systems_single_M p ?q1 (a1, me1) ?q2 (a2, me2)"
      by auto
    then have a_pre: "a_pre = a1@a2"
      by auto
    have lengt: "length qs div 2 \<ge> 1"
      using * by auto
    then have len_q1: "length ?q1 < length qs"
      by auto
    have len_q2: "length ?q2 < length qs"
      using lengt by auto
    obtain mat_pre subs_pre signs_pre where me_decomp:
      "me_pre = (mat_pre,subs_pre,signs_pre)"
      using mes_prop
      using prod_cases3 by blast
    then have "assumps \<in> set (map fst (solve_for_lhs_M p a_pre qs subs_pre mat_pre))"
      using reduce_prop(2) by auto
    then have "assumps \<in> set (map fst (construct_rhs_vector_M p a_pre qs subs_pre))"
      unfolding solve_for_lhs_M_def by auto
    then obtain a_rhs_list where "(assumps, a_rhs_list)
    \<in> set (construct_rhs_vector_rec_M p a_pre (pull_out_pairs qs subs_pre))"
      unfolding construct_rhs_vector_M_def by auto
    then have a_pre_subset: "set a_pre \<subseteq> set assumps"
      using construct_rhs_vector_rec_M_subset_prop[of assumps _ p a_pre "(pull_out_pairs qs subs_pre)"]
      by auto
    have set_a1: "set a1 \<subseteq> set assumps"
      using a_pre_subset a_pre by auto
    then have a1_satisfies: "(\<And>p n. (p, n) \<in> set a1 \<Longrightarrow> satisfies_evaluation val p n)"
      using less(3) by blast
    from less.hyps[of ?q1 a1 me1, OF len_q1 mes_prop(1) a1_satisfies]
    have me1_ind: "calculate_data_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) ?q1) = me1"
      using less(4) by blast
    have set_a2: "set a2 \<subseteq> set assumps"
      using a_pre_subset a_pre by auto
    then have a2_satisfies: "(\<And>p n. (p, n) \<in> set a2 \<Longrightarrow> satisfies_evaluation val p n)"
      using less(3) by blast
    from less.hyps[of ?q2 a2 me2, OF len_q2 mes_prop(2) a2_satisfies]
    have me2_ind: "calculate_data_R ?eval_p (map (eval_mpoly_poly val) ?q2) = me2"
      using less(4) by blast
    have me_pre: "me_pre = snd (combine_systems_R (eval_mpoly_poly val p) ((map (eval_mpoly_poly val) ?q1), me1) ((map (eval_mpoly_poly val) ?q2), me2))"
      using mes_prop(3) combine_systems_R_snd length_map
      by (metis combine_systems_single_M.simps snd_conv)
    obtain mat_pre1 subs_pre1 signs_pre1 where me1_decomp:
      "me1 = (mat_pre1,subs_pre1,signs_pre1)"
      using prod_cases3 by blast
    obtain mat_pre2 subs_pre2 signs_pre2 where me2_decomp:
      "me2 = (mat_pre2,subs_pre2,signs_pre2)"
      using prod_cases3 by blast
    have fst_comb: "fst (combine_systems_R ?eval_p ((map (eval_mpoly_poly val) ?q1), me1) ((map (eval_mpoly_poly val) ?q2), me2)) = (map (eval_mpoly_poly val) ?q1) @ (map (eval_mpoly_poly val) ?q2)"
    proof -
      have "fst (combine_systems_R (eval_mpoly_poly val p) ((map (eval_mpoly_poly val) ?q1), me1) ((map (eval_mpoly_poly val) ?q2), me2)) =
        fst (smash_systems_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) ?q1) (map (eval_mpoly_poly val) ?q2) subs_pre1 subs_pre2 signs_pre1 signs_pre2 mat_pre1 mat_pre2)"
        using combining_to_smash_R me1_decomp me2_decomp by force
      then show ?thesis
        unfolding smash_systems_R_def by auto
    qed
    then have "map (eval_mpoly_poly val) qs = fst (combine_systems_R (eval_mpoly_poly val p) ((map (eval_mpoly_poly val) ?q1), me1) ((map (eval_mpoly_poly val) ?q2), me2))"
      by (metis append_take_drop_id map_append)
    then have me_pre_var:  "(map (eval_mpoly_poly val) qs, me_pre) = (combine_systems_R (eval_mpoly_poly val p) ((map (eval_mpoly_poly val) ?q1), me1) ((map (eval_mpoly_poly val) ?q2), me2))"
      using me_pre by auto
    have len_hyp: "length (map (eval_mpoly_poly val) qs) > 1"
      using * by auto
    have len_eq: "length (map (eval_mpoly_poly val) qs) = length qs"
      by simp
    have len_q1_gt0: "length (map (eval_mpoly_poly val) ?q1) > 0"
      using len_hyp len_eq by auto
    have len_q2_gt0: "length (map (eval_mpoly_poly val) ?q2) > 0"
      using len_hyp len_eq by auto
    let ?uni_sys_q1 = "calculate_data_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) ?q1)"
    have sat_props_q1_univ: "satisfies_properties_R ?eval_p (map (eval_mpoly_poly val) ?q1) (get_subsets_R ?uni_sys_q1) (get_signs_R ?uni_sys_q1) (get_matrix_R ?uni_sys_q1)"
      using calculate_data_satisfies_properties_R[of "?eval_p" "(map (eval_mpoly_poly val) (take (length qs div 2) qs))"]
        len_q1_gt0  using less.prems(3) by auto
    let ?uni_sys_q2 = "calculate_data_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) ?q2)"
    have sat_props_q2_univ: "satisfies_properties_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) ?q2) (get_subsets_R ?uni_sys_q2) (get_signs_R ?uni_sys_q2) (get_matrix_R ?uni_sys_q2)"
      using calculate_data_satisfies_properties_R[of "(eval_mpoly_poly val p)" "(map (eval_mpoly_poly val) (drop (length qs div 2) qs))"]
        len_q2_gt0  using less.prems(3)  by auto
    have comb_satisfies: "satisfies_properties_R ?eval_p (?eval_q1@(map (eval_mpoly_poly val) ?q2))
  (get_subsets_R (snd ((combine_systems_R ?eval_p (?eval_q1,?uni_sys_q1) (?eval_q2,?uni_sys_q2)))))
  (get_signs_R (snd ((combine_systems_R ?eval_p (?eval_q1,?uni_sys_q1) (?eval_q2,?uni_sys_q2)))))
  (get_matrix_R (snd ((combine_systems_R ?eval_p (?eval_q1,?uni_sys_q1) (?eval_q2,?uni_sys_q2)))))"
      using combining_sys_satisfies_properties_R[of ?eval_p ?eval_q1 ?eval_q2] len_q1_gt0 len_q2_gt0 less.prems(3)
        sat_props_q2_univ sat_props_q1_univ
      by auto  (* takes a second to load *)
    then have well_def_subs_pre: "all_list_constr_R (get_subsets_R (snd ((combine_systems_R ?eval_p (?eval_q1,?uni_sys_q1) (?eval_q2,?uni_sys_q2))))) (length (?eval_q1@?eval_q2))"
      unfolding satisfies_properties_R_def by auto
    have get_subs_pre: "(get_subsets_R (snd ((combine_systems_R ?eval_p (?eval_q1,?uni_sys_q1) (?eval_q2,?uni_sys_q2))))) = subs_pre"
      using me_decomp unfolding get_subsets_R_def
      by (metis fst_conv me1_ind me2_ind me_pre_var snd_conv)
    have well_def: "(\<And>Is1 Is2 n. (Is1, Is2) \<in> set (fst (snd me_pre)) \<Longrightarrow> n \<in> set Is1 \<or> n \<in> set Is2 \<Longrightarrow> n < length qs)"
      using well_def_subs_pre get_subs_pre
        all_list_constr_R_matches_well_def[of subs_pre]
      by (smt (verit, ccfv_SIG) fst_comb fst_conv get_subsets_R_def length_map me1_ind me2_ind me_pre_var snd_conv)
    then have reduce_mat_eq: "mat_eq =  reduce_system_R (eval_mpoly_poly val p) ((map (eval_mpoly_poly val) qs), me_pre)"
      using reduce_system_single_M_univariate[OF reduce_prop(2) less.prems(2)]
      by (metis prod.exhaust_sel)
    let ?eval_qs = "(map (eval_mpoly_poly val) qs)"
    have "calculate_data_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) qs) =
     (let q1 = take ((length ?eval_qs) div 2) ?eval_qs; left = calculate_data_R ?eval_p q1;
         q2 = drop ((length ?eval_qs) div 2) ?eval_qs; right = calculate_data_R ?eval_p q2;
         comb = combine_systems_R ?eval_p (q1,left) (q2,right) in
         reduce_system_R ?eval_p comb)"
      using len_hyp
      by (smt (z3) calculate_data_R.simps less_one nat_less_le semiring_norm(136))
    moreover have "... = (let q1 =(map (eval_mpoly_poly val) ?q1);
         left = calculate_data_R (eval_mpoly_poly val p) q1;
         q2 = (map (eval_mpoly_poly val) ?q2);
         right = calculate_data_R (eval_mpoly_poly val p) q2
     in Let (combine_systems_R (eval_mpoly_poly val p) (q1, left) (q2, right))
         (reduce_system_R (eval_mpoly_poly val p))) "
      using map_q1 map_q2 by auto
    moreover have "... = (let q1 =(map (eval_mpoly_poly val) ?q1); left = me1;
      q2 = (map (eval_mpoly_poly val) ?q2); right = me2 in
      Let (combine_systems_R (eval_mpoly_poly val p) (q1, left) (q2, right))
         (reduce_system_R (eval_mpoly_poly val p)))"
      unfolding Let_def me1_ind me2_ind by auto
    moreover have "... = mat_eq"
      unfolding Let_def reduce_mat_eq me_pre_var by auto
    ultimately have "calculate_data_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) qs) = mat_eq"
      by auto
  }
  ultimately show ?case by blast
qed

lemma calculate_data_gives_signs_at_roots:
  assumes "(assumps, signs) \<in> set (calculate_data_to_signs (calculate_data_M p qs))"
  assumes "\<And>p n. (p,n) \<in> set assumps \<Longrightarrow> satisfies_evaluation val p n"
  assumes "eval_mpoly_poly val p \<noteq> 0"
  shows "signs = find_consistent_signs_at_roots_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) qs)"
  using assms calculate_data_M_univariate
  unfolding find_consistent_signs_at_roots_R_def by auto

lemma calculate_data_gives_noncomp_signs_at_roots:
  assumes "(assumps, signs) \<in> set (calculate_data_to_signs (calculate_data_M p qs))"
  assumes "\<And>p n. (p,n) \<in> set assumps \<Longrightarrow> satisfies_evaluation val p n"
  assumes "eval_mpoly_poly val p \<noteq> 0"
  shows "set signs = set (characterize_consistent_signs_at_roots (eval_mpoly_poly val p) (map (eval_mpoly_poly val) qs))"
  using assms find_consistent_signs_at_roots_R calculate_data_gives_signs_at_roots
  by metis

lemma calculate_data_assumps_gives_signs_at_roots:
  assumes "(assumps, signs) \<in> set (calculate_data_to_signs (calculate_data_assumps_M p qs init_assumps))"
  assumes "\<And>p n. (p,n) \<in> set assumps \<Longrightarrow> satisfies_evaluation val p n"
  assumes "eval_mpoly_poly val p \<noteq> 0"
  shows "signs = find_consistent_signs_at_roots_R (eval_mpoly_poly val p) (map (eval_mpoly_poly val) qs)"
  using assms calculate_data_M_assumps_univariate
  unfolding find_consistent_signs_at_roots_R_def
  by auto

lemma calculate_data_assumps_gives_noncomp_signs_at_roots:
  assumes "(assumps, signs) \<in> set (calculate_data_to_signs (calculate_data_assumps_M p qs init_assumps))"
  assumes "\<And>p n. (p,n) \<in> set assumps \<Longrightarrow> satisfies_evaluation val p n"
  assumes "eval_mpoly_poly val p \<noteq> 0"
  shows "set signs = set (characterize_consistent_signs_at_roots (eval_mpoly_poly val p) (map (eval_mpoly_poly val) qs))"
  using assms find_consistent_signs_at_roots_R calculate_data_assumps_gives_signs_at_roots
  by metis

end


(*  Title:      JinjaThreads/Common/TypeRel.thy
    Author:     Tobias Nipkow, Andreas Lochbihler

    Based on the Jinja theory Common/Type.thy by Tobias Nipkow

*)

header {* \isaheader{Relations between Jinja Types} *}

theory TypeRel
imports
  Decl
begin

subsection{* The subclass relations *}

inductive subcls1 :: "'m prog \<Rightarrow> cname \<Rightarrow> cname \<Rightarrow> bool" ("_ \<turnstile> _ \<prec>\<^sup>1 _" [71, 71, 71] 70)
  for P :: "'m prog"
where subcls1I: "\<lbrakk> class P C = Some (D, rest); C \<noteq> Object \<rbrakk> \<Longrightarrow> P \<turnstile> C \<prec>\<^sup>1 D"

abbreviation subcls :: "'m prog \<Rightarrow> cname \<Rightarrow> cname \<Rightarrow> bool" ("_ \<turnstile> _ \<preceq>\<^sup>* _"  [71,71,71] 70)
where "P \<turnstile> C \<preceq>\<^sup>* D \<equiv> (subcls1 P)\<^sup>*\<^sup>* C D"

lemma subcls1D:
  "P \<turnstile> C \<prec>\<^sup>1 D \<Longrightarrow> C \<noteq> Object \<and> (\<exists>fs ms. class P C = Some (D,fs,ms))"
by(auto elim: subcls1.cases)

lemma Object_subcls1 [iff]: "\<not> P \<turnstile> Object \<prec>\<^sup>1 C"
by(simp add: subcls1.simps)

lemma Object_subcls_conv [iff]: "(P \<turnstile> Object \<preceq>\<^sup>* C) = (C = Object)"
by(auto elim: converse_rtranclpE)

lemma finite_subcls1: "finite {(C, D). P \<turnstile> C \<prec>\<^sup>1 D}"
proof -
  let ?A = "SIGMA C:{C. is_class P C}. {D. C\<noteq>Object \<and> fst (the (class P C))=D}"
  have "finite ?A" by(rule finite_SigmaI [OF finite_is_class]) auto
  also have "?A = {(C, D). P \<turnstile> C \<prec>\<^sup>1 D}"
    by(fastforce simp:is_class_def dest: subcls1D elim: subcls1I)
  finally show ?thesis .
qed

lemma finite_subcls1':
  "finite ({(D, C). P \<turnstile> C \<prec>\<^sup>1 D})"
by(subst finite_converse[symmetric])
  (simp add: converse_unfold finite_subcls1 del: finite_converse)

lemma subcls_is_class: "(subcls1 P)\<^sup>+\<^sup>+ C D \<Longrightarrow> is_class P C"
by(auto elim: converse_tranclpE dest!: subcls1D simp add: is_class_def)

lemma subcls_is_class1: "\<lbrakk> P \<turnstile> C \<preceq>\<^sup>* D; is_class P D \<rbrakk> \<Longrightarrow> is_class P C"
by(auto elim: converse_rtranclpE dest!: subcls1D simp add: is_class_def)

subsection{* The subtype relations *}

inductive widen :: "'m prog \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> _ \<le> _"   [71,71,71] 70)
  for P :: "'m prog"
where
  widen_refl[iff]: "P \<turnstile> T \<le> T"
| widen_subcls: "P \<turnstile> C \<preceq>\<^sup>* D  \<Longrightarrow>  P \<turnstile> Class C \<le> Class D"
| widen_null[iff]: "P \<turnstile> NT \<le> Class C"
| widen_null_array[iff]: "P \<turnstile> NT \<le> Array A"
| widen_array_object: "P \<turnstile> Array A \<le> Class Object"
| widen_array_array: "P \<turnstile> A \<le> B \<Longrightarrow> P \<turnstile> Array A \<le> Array B"

abbreviation
  widens :: "'m prog \<Rightarrow> ty list \<Rightarrow> ty list \<Rightarrow> bool" ("_ \<turnstile> _ [\<le>] _" [71,71,71] 70)
where
  "P \<turnstile> Ts [\<le>] Ts' == list_all2 (widen P) Ts Ts'"

lemma [iff]: "(P \<turnstile> T \<le> Boolean) = (T = Boolean)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> T \<le> Integer) = (T = Integer)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> Void \<le> T) = (T = Void)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> Boolean \<le> T) = (T = Boolean)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma [iff]: "(P \<turnstile> Integer \<le> T) = (T = Integer)"
(*<*)by (auto elim: widen.cases)(*>*)

lemma Class_widen: "P \<turnstile> Class C \<le> T  \<Longrightarrow>  \<exists>D. T = Class D"
by(erule widen.cases, auto)

lemma Array_Array_widen:
  "P \<turnstile> Array T \<le> Array U \<Longrightarrow> P \<turnstile> T \<le> U"
by(auto elim: widen.cases)

lemma widen_Array: "(P \<turnstile> T \<le> U\<lfloor>\<rceil>) \<longleftrightarrow> (T = NT \<or> (\<exists>V. T = V\<lfloor>\<rceil> \<and> P \<turnstile> V \<le> U))"
by(induct T)(auto dest: Array_Array_widen elim: widen.cases intro: widen_array_array)

lemma Array_widen: "P \<turnstile> Array A \<le> T \<Longrightarrow> (\<exists>B. T = Array B \<and> P \<turnstile> A \<le> B) \<or> T = Class Object"
by(auto elim: widen.cases)

lemma [iff]: "(P \<turnstile> T \<le> NT) = (T = NT)"
by(induct T)(auto dest:Class_widen Array_widen)

lemma Class_widen_Class [iff]: "(P \<turnstile> Class C \<le> Class D) = (P \<turnstile> C \<preceq>\<^sup>* D)"
by (auto elim: widen_subcls widen.cases)

lemma widen_Class: "(P \<turnstile> T \<le> Class C) = (T = NT \<or> (\<exists>D. T = Class D \<and> P \<turnstile> D \<preceq>\<^sup>* C) \<or> (C = Object \<and> (\<exists>A. T = Array A)))"
by(induct T)(auto dest: Array_widen intro: widen_array_object)

lemma NT_widen:
  "P \<turnstile> NT \<le> T = (T = NT \<or> (\<exists>C. T = Class C) \<or> (\<exists>U. T = U\<lfloor>\<rceil>))"
by(cases T) auto

lemma Class_widen2: "P \<turnstile> Class C \<le> T = (\<exists>D. T = Class D \<and> P \<turnstile> C \<preceq>\<^sup>* D)"
by (cases T, auto elim: widen.cases)

lemma Object_widen: "P \<turnstile> Class Object \<le> T \<Longrightarrow> T = Class Object"
by(cases T, auto elim: widen.cases)

lemma NT_Array_widen_Object:
  "is_NT_Array T \<Longrightarrow>  P \<turnstile> T \<le> Class Object"
by(induct T, auto intro: widen_array_object)

lemma widen_trans[trans]:
  assumes "P \<turnstile> S \<le> U" "P \<turnstile> U \<le> T"
  shows "P \<turnstile> S \<le> T"
using assms
proof(induct arbitrary: T)
  case (widen_refl T T') thus "P \<turnstile> T \<le> T'" .
next
  case (widen_subcls C D T)
  then obtain E where "T = Class E" by (blast dest: Class_widen)
  with widen_subcls show "P \<turnstile> Class C \<le> T" by (auto elim: rtrancl_trans)
next
  case (widen_null C RT)
  then obtain D where "RT = Class D" by (blast dest: Class_widen)
  thus "P \<turnstile> NT \<le> RT" by auto
next
  case widen_null_array thus ?case by(auto dest: Array_widen)
next
  case (widen_array_object A T)
  hence "T = Class Object" by(rule Object_widen)
  with widen_array_object show "P \<turnstile> A\<lfloor>\<rceil> \<le> T"
    by(auto intro: widen.widen_array_object)
next
  case widen_array_array thus ?case
    by(auto dest!: Array_widen intro: widen.widen_array_array widen_array_object)
qed

lemma widens_trans: "\<lbrakk>P \<turnstile> Ss [\<le>] Ts; P \<turnstile> Ts [\<le>] Us\<rbrakk> \<Longrightarrow> P \<turnstile> Ss [\<le>] Us"
by (rule list_all2_trans)(rule widen_trans)

lemma class_type_of'_widenD:
  "class_type_of' T = \<lfloor>C\<rfloor> \<Longrightarrow> P \<turnstile> T \<le> Class C"
by(cases T)(auto intro: widen_array_object)

lemma widen_is_class_type_of:
  assumes "class_type_of' T = \<lfloor>C\<rfloor>" "P \<turnstile> T' \<le> T" "T' \<noteq> NT"
  obtains C' where "class_type_of' T' = \<lfloor>C'\<rfloor>" "P \<turnstile> C' \<preceq>\<^sup>* C"
using assms by(cases T)(auto simp add: widen_Class widen_Array)

lemma widens_refl: "P \<turnstile> Ts [\<le>] Ts"
by(rule list_all2_refl[OF widen_refl])

lemma widen_append1:
  "P \<turnstile> (xs @ ys) [\<le>] Ts = (\<exists>Ts1 Ts2. Ts = Ts1 @ Ts2 \<and> length xs = length Ts1 \<and> length ys = length Ts2 \<and> P \<turnstile> xs [\<le>] Ts1 \<and> P \<turnstile> ys [\<le>] Ts2)"
unfolding list_all2_append1 by fastforce

lemmas widens_Cons [iff] = list_all2_Cons1 [of "widen P"] for P

lemma widens_lengthD:
  "P \<turnstile> xs [\<le>] ys \<Longrightarrow> length xs = length ys"
by(rule list_all2_lengthD)

lemma widen_refT: "\<lbrakk> is_refT T; P \<turnstile> U \<le> T \<rbrakk> \<Longrightarrow> is_refT U"
by(erule refTE)(auto simp add: widen_Class widen_Array)

lemma refT_widen: "\<lbrakk> is_refT T; P \<turnstile> T \<le> U \<rbrakk> \<Longrightarrow> is_refT U"
by(erule widen.cases) auto

inductive is_lub :: "'m prog \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> ty \<Rightarrow> bool" ("_ \<turnstile> lub'((_,/ _)') = _" [51,51,51,51] 50)
for P :: "'m prog" and U :: ty and V :: ty and T ::  ty
where
  "\<lbrakk> P \<turnstile> U \<le> T; P \<turnstile> V \<le> T;
     \<And>T'. \<lbrakk> P \<turnstile> U \<le> T'; P \<turnstile> V \<le> T' \<rbrakk> \<Longrightarrow> P \<turnstile> T \<le> T' \<rbrakk>
  \<Longrightarrow> P \<turnstile> lub(U, V) = T"

lemma is_lub_upper:
  "P \<turnstile> lub(U, V) = T \<Longrightarrow> P \<turnstile> U \<le> T \<and> P \<turnstile> V \<le> T"
by(auto elim: is_lub.cases)

lemma is_lub_least:
  "\<lbrakk> P \<turnstile> lub(U, V) = T; P \<turnstile> U \<le> T'; P \<turnstile> V \<le> T' \<rbrakk> \<Longrightarrow> P \<turnstile> T \<le> T'"
by(auto elim: is_lub.cases)

lemma is_lub_Void [iff]:
  "P \<turnstile> lub(Void, Void) = T \<longleftrightarrow> T = Void"
by(auto intro: is_lub.intros elim: is_lub.cases)

lemma is_lubI [code_pred_intro]:
  "\<lbrakk>P \<turnstile> U \<le> T; P \<turnstile> V \<le> T; \<forall>T'. P \<turnstile> U \<le> T' \<longrightarrow> P \<turnstile> V \<le> T' \<longrightarrow> P \<turnstile> T \<le> T'\<rbrakk> \<Longrightarrow> P \<turnstile> lub(U, V) = T"
by(blast intro: is_lub.intros)

subsection{* Method lookup *}

inductive Methods :: "'m prog \<Rightarrow> cname \<Rightarrow> (mname \<rightharpoonup> (ty list \<times> ty \<times> 'm option) \<times> cname) \<Rightarrow> bool"
  ("_ \<turnstile> _ sees'_methods _" [51,51,51] 50)
  for P :: "'m prog"
where
sees_methods_Object:
 "\<lbrakk> class P Object = Some(D,fs,ms); Mm = map_option (\<lambda>m. (m,Object)) \<circ> map_of ms \<rbrakk>
  \<Longrightarrow> P \<turnstile> Object sees_methods Mm"
| sees_methods_rec:
 "\<lbrakk> class P C = Some(D,fs,ms); C \<noteq> Object; P \<turnstile> D sees_methods Mm;
    Mm' = Mm ++ (map_option (\<lambda>m. (m,C)) \<circ> map_of ms) \<rbrakk>
  \<Longrightarrow> P \<turnstile> C sees_methods Mm'"

lemma sees_methods_fun:
  assumes "P \<turnstile> C sees_methods Mm"
  shows "P \<turnstile> C sees_methods Mm' \<Longrightarrow> Mm' = Mm"
using assms
proof(induction arbitrary: Mm')
  case sees_methods_Object thus ?case by(auto elim: Methods.cases)
next
  case (sees_methods_rec C D fs ms Dres Cres Cres')
  from `P \<turnstile> C sees_methods Cres'` `C \<noteq> Object` `class P C = \<lfloor>(D, fs, ms)\<rfloor>`
  obtain Dres' where Dmethods': "P \<turnstile> D sees_methods Dres'"
    and Cres': "Cres' = Dres' ++ (map_option (\<lambda>m. (m,C)) \<circ> map_of ms)"
    by cases auto
  from sees_methods_rec.IH[OF Dmethods'] `Cres = Dres ++ (map_option (\<lambda>m. (m,C)) \<circ> map_of ms)` Cres'
  show ?case by simp
qed

lemma visible_methods_exist:
  "P \<turnstile> C sees_methods Mm \<Longrightarrow> Mm M = Some(m,D) \<Longrightarrow>
   (\<exists>D' fs ms. class P D = Some(D',fs,ms) \<and> map_of ms M = Some m)"
by(induct rule:Methods.induct) auto

lemma sees_methods_decl_above:
  assumes "P \<turnstile> C sees_methods Mm"
  shows "Mm M = Some(m,D) \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
using assms
by induct(auto elim: converse_rtranclp_into_rtranclp[where r = "subcls1 P", OF subcls1I])

lemma sees_methods_idemp:
  assumes "P \<turnstile> C sees_methods Mm" and "Mm M = Some(m,D)"
  shows "\<exists>Mm'. (P \<turnstile> D sees_methods Mm') \<and> Mm' M = Some(m,D)"
using assms
by(induct arbitrary: m D)(fastforce dest: Methods.intros)+

lemma sees_methods_decl_mono:
  assumes sub: "P \<turnstile> C' \<preceq>\<^sup>* C" and "P \<turnstile> C sees_methods Mm"
  shows "\<exists>Mm' Mm\<^sub>2. P \<turnstile> C' sees_methods Mm' \<and> Mm' = Mm ++ Mm\<^sub>2 \<and> (\<forall>M m D. Mm\<^sub>2 M = Some(m,D) \<longrightarrow> P \<turnstile> D \<preceq>\<^sup>* C)"
      (is "\<exists>Mm' Mm2. ?Q C' C Mm' Mm2")
using assms
proof (induction rule: converse_rtranclp_induct)
  case base
  hence "?Q C C Mm empty" by simp
  thus "\<exists>Mm' Mm2. ?Q C C Mm' Mm2" by blast
next
  case (step C'' C')
  note sub1 = `P \<turnstile> C'' \<prec>\<^sup>1 C'` and sub = `P \<turnstile> C' \<preceq>\<^sup>* C`
    and Csees = `P \<turnstile> C sees_methods Mm`
  from step.IH[OF Csees] obtain Mm' Mm2 where C'sees: "P \<turnstile> C' sees_methods Mm'"
    and Mm': "Mm' = Mm ++ Mm2"
    and subC: "\<forall>M m D. Mm2 M = Some(m,D) \<longrightarrow> P \<turnstile> D \<preceq>\<^sup>* C" by blast
  obtain fs ms where "class": "class P C'' = Some(C',fs,ms)" "C'' \<noteq> Object"
    using subcls1D[OF sub1] by blast
  let ?Mm3 = "map_option (\<lambda>m. (m,C'')) \<circ> map_of ms"
  have "P \<turnstile> C'' sees_methods (Mm ++ Mm2) ++ ?Mm3"
    using sees_methods_rec[OF "class" C'sees refl] Mm' by simp
  hence "?Q C'' C ((Mm ++ Mm2) ++ ?Mm3) (Mm2++?Mm3)"
    using converse_rtranclp_into_rtranclp[OF sub1 sub]
    by simp (simp add:map_add_def subC split:option.split)
  thus "\<exists>Mm' Mm2. ?Q C'' C Mm' Mm2" by blast
qed

definition Method :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> 'm option \<Rightarrow> cname \<Rightarrow> bool"
            ("_ \<turnstile> _ sees _: _\<rightarrow>_ = _ in _" [51,51,51,51,51,51,51] 50)
where
  "P \<turnstile> C sees M: Ts\<rightarrow>T = m in D  \<equiv>
  \<exists>Mm. P \<turnstile> C sees_methods Mm \<and> Mm M = Some((Ts,T,m),D)"

text {*
  Output translation to replace @{term "None"} with its notation @{text "Native"}
  when used as method body in @{term "Method"}.
*}
abbreviation (output)
  Method_native :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> ty list \<Rightarrow> ty \<Rightarrow> cname \<Rightarrow> bool"
  ("_ \<turnstile> _ sees _: _\<rightarrow>_ = Native in _" [51,51,51,51,51,51] 50)
where "Method_native P C M Ts T D \<equiv> Method P C M Ts T Native D"

definition has_method :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> bool" ("_ \<turnstile> _ has _" [51,0,51] 50)
where
  "P \<turnstile> C has M \<equiv> \<exists>Ts T m D. P \<turnstile> C sees M:Ts\<rightarrow>T = m in D"

lemma has_methodI:
  "P \<turnstile> C sees M:Ts\<rightarrow>T = m in D \<Longrightarrow> P \<turnstile> C has M"
  by (unfold has_method_def) blast

lemma sees_method_fun:
  "\<lbrakk>P \<turnstile> C sees M:TS\<rightarrow>T = m in D; P \<turnstile> C sees M:TS'\<rightarrow>T' = m' in D' \<rbrakk>
   \<Longrightarrow> TS' = TS \<and> T' = T \<and> m' = m \<and> D' = D"
 (*<*)by(fastforce dest: sees_methods_fun simp:Method_def)(*>*)

lemma sees_method_decl_above:
  "P \<turnstile> C sees M:Ts\<rightarrow>T = m in D \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
 (*<*)by(clarsimp simp:Method_def sees_methods_decl_above)(*>*)

lemma visible_method_exists:
  "P \<turnstile> C sees M:Ts\<rightarrow>T = m in D \<Longrightarrow>
  \<exists>D' fs ms. class P D = Some(D',fs,ms) \<and> map_of ms M = Some(Ts,T,m)"
(*<*)by(fastforce simp:Method_def dest!: visible_methods_exist)(*>*)

lemma sees_method_idemp:
  "P \<turnstile> C sees M:Ts\<rightarrow>T=m in D \<Longrightarrow> P \<turnstile> D sees M:Ts\<rightarrow>T=m in D"
 (*<*)by(fastforce simp: Method_def intro:sees_methods_idemp)(*>*)

lemma sees_method_decl_mono:
  "\<lbrakk> P \<turnstile> C' \<preceq>\<^sup>* C; P \<turnstile> C sees M:Ts\<rightarrow>T = m in D;
     P \<turnstile> C' sees M:Ts'\<rightarrow>T' = m' in D' \<rbrakk> \<Longrightarrow> P \<turnstile> D' \<preceq>\<^sup>* D"
apply(frule sees_method_decl_above)
apply(unfold Method_def)
apply clarsimp
apply(drule (1) sees_methods_decl_mono)
apply clarsimp
apply(drule (1) sees_methods_fun)
apply clarsimp
apply(blast intro:rtranclp_trans)
done

lemma sees_method_is_class:
  "P \<turnstile> C sees M:Ts\<rightarrow>T = m in D \<Longrightarrow> is_class P C"
by (auto simp add: is_class_def Method_def elim: Methods.cases)

subsection{* Field lookup *}

inductive Fields :: "'m prog \<Rightarrow> cname \<Rightarrow> ((vname \<times> cname) \<times> (ty \<times> fmod)) list \<Rightarrow> bool"
  ("_ \<turnstile> _ has'_fields _" [51,51,51] 50)
  for P :: "'m prog"
where
  has_fields_rec:
  "\<lbrakk> class P C = Some(D,fs,ms); C \<noteq> Object; P \<turnstile> D has_fields FDTs;
     FDTs' = map (\<lambda>(F,Tm). ((F,C),Tm)) fs @ FDTs \<rbrakk>
   \<Longrightarrow> P \<turnstile> C has_fields FDTs'"

| has_fields_Object:
  "\<lbrakk> class P Object = Some(D,fs,ms); FDTs = map (\<lambda>(F,T). ((F,Object),T)) fs \<rbrakk>
   \<Longrightarrow> P \<turnstile> Object has_fields FDTs"

lemma has_fields_fun:
  assumes "P \<turnstile> C has_fields FDTs" and "P \<turnstile> C has_fields FDTs'"
  shows "FDTs' = FDTs"
using assms
proof(induction arbitrary: FDTs')
  case has_fields_Object thus ?case by(auto elim: Fields.cases)
next
  case (has_fields_rec C D fs ms Dres Cres Cres')
  from `P \<turnstile> C has_fields Cres'` `C \<noteq> Object` `class P C = Some (D, fs, ms)`
  obtain Dres' where DFields': "P \<turnstile> D has_fields Dres'"
    and Cres': "Cres' = map (\<lambda>(F,Tm). ((F,C),Tm)) fs @ Dres'"
    by cases auto
  from has_fields_rec.IH[OF DFields'] `Cres = map (\<lambda>(F,Tm). ((F,C),Tm)) fs @ Dres` Cres'
  show ?case by simp
qed

lemma all_fields_in_has_fields:
  assumes "P \<turnstile> C has_fields FDTs"
  and "P \<turnstile> C \<preceq>\<^sup>* D" "class P D = Some(D',fs,ms)" "(F,Tm) \<in> set fs"
  shows "((F,D),Tm) \<in> set FDTs"
using assms
by induct (auto 4 3 elim: converse_rtranclpE dest: subcls1D)

lemma has_fields_decl_above:
  assumes "P \<turnstile> C has_fields FDTs" "((F,D),Tm) \<in> set FDTs"
  shows "P \<turnstile> C \<preceq>\<^sup>* D"
using assms
by induct (auto intro: converse_rtranclp_into_rtranclp subcls1I)

lemma subcls_notin_has_fields:
  assumes "P \<turnstile> C has_fields FDTs" "((F,D),Tm) \<in> set FDTs"
  shows "\<not> (subcls1 P)\<^sup>+\<^sup>+ D C"
using assms apply(induct)
 prefer 2 apply(fastforce dest: tranclpD)
apply clarsimp
apply(erule disjE)
 apply(clarsimp simp add:image_def)
 apply(drule tranclpD)
 apply clarify
 apply(frule subcls1D)
 apply(fastforce dest:tranclpD all_fields_in_has_fields)
apply(blast dest:subcls1I tranclp.trancl_into_trancl)
done

lemma has_fields_mono_lem:
  assumes "P \<turnstile> D \<preceq>\<^sup>* C" "P \<turnstile> C has_fields FDTs"
  shows "\<exists>pre. P \<turnstile> D has_fields pre@FDTs \<and> dom(map_of pre) \<inter> dom(map_of FDTs) = {}"
using assms
apply(induct rule:converse_rtranclp_induct)
 apply(rule_tac x = "[]" in exI)
 apply simp
apply clarsimp
apply(rename_tac D' D pre)
apply(subgoal_tac "(subcls1 P)^++ D' C")
 prefer 2 apply(erule (1) rtranclp_into_tranclp2)
apply(drule subcls1D)
apply clarsimp
apply(rename_tac fs ms)
apply(drule (2) has_fields_rec)
 apply(rule refl)
apply(rule_tac x = "map (\<lambda>(F,Tm). ((F,D'),Tm)) fs @ pre" in exI)
apply simp
apply(simp add:Int_Un_distrib2)
apply(rule equals0I)
apply(auto dest: subcls_notin_has_fields simp:dom_map_of_conv_image_fst image_def)
done

lemma has_fields_is_class:
  "P \<turnstile> C has_fields FDTs \<Longrightarrow> is_class P C"
by (auto simp add: is_class_def elim: Fields.cases)

lemma Object_has_fields_Object:
  assumes "P \<turnstile> Object has_fields FDTs"
  shows "snd ` fst ` set FDTs \<subseteq> {Object}"
using assms by cases auto

definition
  has_field :: "'m prog \<Rightarrow> cname \<Rightarrow> vname \<Rightarrow> ty \<Rightarrow> fmod \<Rightarrow> cname \<Rightarrow> bool"
                   ("_ \<turnstile> _ has _:_ '(_') in _" [51,51,51,51,51,51] 50)
where
  "P \<turnstile> C has F:T (fm) in D  \<equiv>
  \<exists>FDTs. P \<turnstile> C has_fields FDTs \<and> map_of FDTs (F,D) = Some (T, fm)"

lemma has_field_mono:
  "\<lbrakk> P \<turnstile> C has F:T (fm) in D; P \<turnstile> C' \<preceq>\<^sup>* C \<rbrakk> \<Longrightarrow> P \<turnstile> C' has F:T (fm) in D"
by(fastforce simp:has_field_def map_add_def dest: has_fields_mono_lem)

lemma has_field_is_class:
  "P \<turnstile> C has M:T (fm) in D \<Longrightarrow> is_class P C"
by (auto simp add: is_class_def has_field_def elim: Fields.cases)

lemma has_field_decl_above:
  "P \<turnstile> C has F:T (fm) in D \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
unfolding has_field_def
by(auto dest: map_of_SomeD has_fields_decl_above)

lemma has_field_fun:
  "\<lbrakk>P \<turnstile> C has F:T (fm) in D; P \<turnstile> C has F:T' (fm') in D\<rbrakk> \<Longrightarrow> T' = T \<and> fm = fm'"
by(auto simp:has_field_def dest:has_fields_fun)

definition
  sees_field :: "'m prog \<Rightarrow> cname \<Rightarrow> vname \<Rightarrow> ty \<Rightarrow> fmod \<Rightarrow> cname \<Rightarrow> bool"
                  ("_ \<turnstile> _ sees _:_ '(_') in _" [51,51,51,51,51,51] 50)
where
  "P \<turnstile> C sees F:T (fm) in D  \<equiv>
  \<exists>FDTs. P \<turnstile> C has_fields FDTs \<and>
            map_of (map (\<lambda>((F,D),Tm). (F,(D,Tm))) FDTs) F = Some(D,T,fm)"

lemma map_of_remap_SomeD:
  "map_of (map (\<lambda>((k,k'),x). (k,(k',x))) t) k = Some (k',x) \<Longrightarrow> map_of t (k, k') = Some x"
by (induct t) (auto simp:fun_upd_apply split: split_if_asm)

lemma has_visible_field:
  "P \<turnstile> C sees F:T (fm) in D \<Longrightarrow> P \<turnstile> C has F:T (fm) in D"
by(auto simp add:has_field_def sees_field_def map_of_remap_SomeD)

lemma sees_field_fun:
  "\<lbrakk>P \<turnstile> C sees F:T (fm) in D; P \<turnstile> C sees F:T' (fm') in D'\<rbrakk> \<Longrightarrow> T' = T \<and> D' = D \<and> fm = fm'"
by(fastforce simp:sees_field_def dest:has_fields_fun)

lemma sees_field_decl_above:
  "P \<turnstile> C sees F:T (fm) in D \<Longrightarrow> P \<turnstile> C \<preceq>\<^sup>* D"
by(clarsimp simp add: sees_field_def)
  (blast intro: has_fields_decl_above map_of_SomeD map_of_remap_SomeD)

lemma sees_field_idemp:
  assumes "P \<turnstile> C sees F:T (fm) in D"
  shows "P \<turnstile> D sees F:T (fm) in D"
proof -
  from assms obtain FDTs where has: "P \<turnstile> C has_fields FDTs"
    and F: "map_of (map (\<lambda>((F, D), Tm). (F, D, Tm)) FDTs) F = \<lfloor>(D, T, fm)\<rfloor>"
    unfolding sees_field_def by blast
  thus ?thesis
  proof induct
    case has_fields_rec thus ?case unfolding sees_field_def
      by(auto)(fastforce dest: map_of_SomeD intro!: exI intro: Fields.has_fields_rec)
  next
    case has_fields_Object thus ?case unfolding sees_field_def
      by(fastforce dest: map_of_SomeD intro: Fields.has_fields_Object intro!: exI)
  qed
qed

subsection "Functional lookup"

definition method :: "'m prog \<Rightarrow> cname \<Rightarrow> mname \<Rightarrow> cname \<times> ty list \<times> ty \<times> 'm option"
where "method P C M  \<equiv>  THE (D,Ts,T,m). P \<turnstile> C sees M:Ts \<rightarrow> T = m in D"

definition field  :: "'m prog \<Rightarrow> cname \<Rightarrow> vname \<Rightarrow> cname \<times> ty \<times> fmod"
where "field P C F  \<equiv>  THE (D,T,fm). P \<turnstile> C sees F:T (fm) in D"

definition fields :: "'m prog \<Rightarrow> cname \<Rightarrow> ((vname \<times> cname) \<times> (ty \<times> fmod)) list"
where "fields P C  \<equiv>  THE FDTs. P \<turnstile> C has_fields FDTs"

lemma field_def2 [simp]: "P \<turnstile> C sees F:T (fm) in D \<Longrightarrow> field P C F = (D,T,fm)"
(*<*)by (unfold field_def) (auto dest: sees_field_fun)(*>*)

lemma method_def2 [simp]: "P \<turnstile> C sees M: Ts\<rightarrow>T = m in D \<Longrightarrow> method P C M = (D,Ts,T,m)"
(*<*)by (unfold method_def) (auto dest: sees_method_fun)(*>*)

lemma has_fields_b_fields:
  "P \<turnstile> C has_fields FDTs \<Longrightarrow> fields P C = FDTs"
unfolding fields_def
by (blast intro: the_equality has_fields_fun)

lemma has_field_map_of_fields [simp]:
  "P \<turnstile> C has F:T (fm) in D \<Longrightarrow> map_of (fields P C) (F, D) = \<lfloor>(T, fm)\<rfloor>"
by(auto simp add: has_field_def)

subsection {* Code generation *}

text {* New introduction rules for subcls1 *}

code_pred
  -- {* Disallow mode @{text "i_o_o"} to force @{text code_pred} in subsequent predicates not to use this inefficient mode *}
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  subcls1
.

text {*
  Introduce proper constant @{text "subcls'"} for @{term "subcls"}
  and generate executable equation for @{text "subcls'"}
*}

definition subcls' where "subcls' = subcls"

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  [inductify]
  subcls'
.

lemma subcls_conv_subcls' [code_unfold]:
  "(subcls1 P)^** = subcls' P"
by(simp add: subcls'_def)

text {*
  Change rule @{thm widen_array_object} such that predicate compiler
  tests on class @{term Object} first. Otherwise @{text "widen_i_o_i"} never terminates.
*}

lemmas [code_pred_intro] =
  widen_refl widen_subcls widen_null widen_null_array widen_array_object_code widen_array_array
code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  widen
by(erule widen.cases) auto

text {*
  Readjust the code equations for @{term widen} such that @{term widen_i_i_i} is guaranteed to
  contain @{term "()"} at most once (even in the code representation!). This is important
  for the scheduler and the small-step semantics because of the weaker code equations
  for @{term "the"}.

  A similar problem cannot hit the subclass relation because, for acyclic subclass hierarchies,
  the paths in the hieararchy are unique and cycle-free.
*}

definition widen_i_i_i' where "widen_i_i_i' = widen_i_i_i"

declare widen.equation [code del]
lemmas widen_i_i_i'_equation [code] = widen.equation[folded widen_i_i_i'_def]

lemma widen_i_i_i_code [code]:
  "widen_i_i_i P T T' = (if P \<turnstile> T \<le> T' then Predicate.single () else bot)"
by(auto intro!: pred_eqI intro: widen_i_i_iI elim: widen_i_i_iE)

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  Methods
.

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool)
  [inductify]
  Method
.

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> bool)
  [inductify]
  has_method
.

(* FIXME: Necessary only because of bug in code_pred *)
declare fun_upd_def [code_pred_inline]

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> bool)
  Fields
.

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool)
  [inductify, skip_proof]
  has_field
.

code_pred
  (modes: i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> o \<Rightarrow> bool, i \<Rightarrow> i \<Rightarrow> i \<Rightarrow> o \<Rightarrow> o \<Rightarrow> i \<Rightarrow> bool)
  [inductify, skip_proof]
  sees_field
.

lemma eval_Method_i_i_i_o_o_o_o_conv:
  "Predicate.eval (Method_i_i_i_o_o_o_o P C M) = (\<lambda>(Ts, T, m, D). P \<turnstile> C sees M:Ts\<rightarrow>T=m in D)"
by(auto intro: Method_i_i_i_o_o_o_oI elim: Method_i_i_i_o_o_o_oE intro!: ext)

lemma method_code [code]:
  "method P C M =
  Predicate.the (Predicate.bind (Method_i_i_i_o_o_o_o P C M) (\<lambda>(Ts, T, m, D). Predicate.single (D, Ts, T, m)))"
apply (rule sym, rule the_eqI)
apply (simp add: method_def eval_Method_i_i_i_o_o_o_o_conv)
apply (rule arg_cong [where f=The])
apply (auto simp add: SUP_def Sup_fun_def Sup_bool_def fun_eq_iff)
done

lemma eval_sees_field_i_i_i_o_o_o_conv:
  "Predicate.eval (sees_field_i_i_i_o_o_o P C F) = (\<lambda>(T, fm, D). P \<turnstile> C sees F:T (fm) in D)"
by(auto intro!: ext intro: sees_field_i_i_i_o_o_oI elim: sees_field_i_i_i_o_o_oE)

lemma eval_sees_field_i_i_i_o_i_conv:
  "Predicate.eval (sees_field_i_i_i_o_o_i P C F D) = (\<lambda>(T, fm). P \<turnstile> C sees F:T (fm) in D)"
by(auto intro!: ext intro: sees_field_i_i_i_o_o_iI elim: sees_field_i_i_i_o_o_iE)

lemma field_code [code]:
  "field P C F = Predicate.the (Predicate.bind (sees_field_i_i_i_o_o_o P C F) (\<lambda>(T, fm, D). Predicate.single (D, T, fm)))"
apply (rule sym, rule the_eqI)
apply (simp add: field_def eval_sees_field_i_i_i_o_o_o_conv)
apply (rule arg_cong [where f=The])
apply (auto simp add: SUP_def Sup_fun_def Sup_bool_def fun_eq_iff)
done

lemma eval_Fields_conv:
  "Predicate.eval (Fields_i_i_o P C) = (\<lambda>FDTs. P \<turnstile> C has_fields FDTs)"
by(auto intro: Fields_i_i_oI elim: Fields_i_i_oE intro!: ext)

lemma fields_code [code]:
  "fields P C = Predicate.the (Fields_i_i_o P C)"
by(simp add: fields_def Predicate.the_def eval_Fields_conv)

code_identifier
  code_module TypeRel \<rightharpoonup>
    (SML) TypeRel and (Haskell) TypeRel and (OCaml) TypeRel
| code_module Decl \<rightharpoonup>
    (SML) TypeRel and (Haskell) TypeRel and (OCaml) TypeRel

end