theory IHT_Dynamic_Array
  imports "../SepLogicTime/SLTC_Main" IHT_Arrays
begin

datatype 'a dynamic_array = Dyn_Array (alen: nat) (aref: "'a array")
setup \<open>add_simple_datatype "dynamic_array"\<close>

section \<open>Raw assertion and basic operations\<close>

fun dyn_array_raw :: "'a::heap list \<times> nat \<Rightarrow> 'a dynamic_array \<Rightarrow> assn" where
  "dyn_array_raw (xs, n) (Dyn_Array m a) = (a \<mapsto>\<^sub>a xs * \<up>(m = n))"
setup \<open>add_rewrite_ent_rule @{thm dyn_array_raw.simps}\<close>

definition dyn_array_new :: "'a::{zero,heap} dynamic_array Heap" where
  "dyn_array_new = do {
     p \<leftarrow> Array_Time.new 5 0;
     return (Dyn_Array 0 p)
   }"

lemma dyn_array_new_raw_rule [hoare_triple]:
  "<$7>
   dyn_array_new
   <dyn_array_raw (replicate 5 0, 0)>" by auto2

definition double_length :: "'a::{heap,zero} dynamic_array \<Rightarrow> 'a dynamic_array Heap" where
  "double_length d = (case d of Dyn_Array al ar \<Rightarrow> do {
      am \<leftarrow> Array_Time.len ar;
      p \<leftarrow> Array_Time.new (2 * am + 1) 0;
      array_copy ar p am;
      return (Dyn_Array am p)
    })"

fun double_length_fun :: "'a::{heap,zero} list \<times> nat \<Rightarrow> 'a list \<times> nat" where
  "double_length_fun (xs, n) =
    (Arrays_Ex.array_copy xs (replicate (2 * n + 1) 0) n, n)"
setup \<open>add_rewrite_rule @{thm double_length_fun.simps}\<close>

lemma double_length_raw_rule [hoare_triple]:
  "length xs = n \<Longrightarrow>
   <dyn_array_raw (xs, n) p * $(5*n + 5)>
   double_length p
   <dyn_array_raw (double_length_fun (xs, n))>\<^sub>t" by auto2

definition push_array_basic :: "'a \<Rightarrow> 'a::heap dynamic_array \<Rightarrow> 'a dynamic_array Heap" where
  "push_array_basic x p = do {
    Array_Time.upd (alen p) x (aref p);
    return (Dyn_Array (alen p + 1) (aref p))
   }"

fun push_array_basic_fun :: "'a \<Rightarrow> 'a::heap list \<times> nat \<Rightarrow> 'a list \<times> nat" where
  "push_array_basic_fun x (xs, n) = (list_update xs n x, n + 1)"
setup \<open>add_rewrite_rule @{thm push_array_basic_fun.simps}\<close>

lemma push_array_basic_raw_rule [hoare_triple]:
  "n < length xs \<Longrightarrow>
   <dyn_array_raw (xs, n) p * $2>
    push_array_basic x p
   <dyn_array_raw (push_array_basic_fun x (xs, n))>" by auto2

section \<open>Potential function\<close>

lemma arith1 [rewrite]: "10*(n::nat) - 5*(2*n+1) = 0" by simp
lemma arith2 [backward]: "a \<le> b \<Longrightarrow> c > 0 \<Longrightarrow> a + c - b \<le> (c::nat)" by auto

lemma arith2' [resolve]: "10*(a::nat) - 5*b + 12 \<ge> 10*(a+1) - 5*b + 2"
@proof
  @case "10*a \<ge> 5*b"
  @have "10*a - 5*b + 12 = 12" @with  (* lhs *)
    @have "10*a - 5*b = 0"
  @end
  @case "10*(a+1) < 5*b"
  @have "10*a + 10 \<ge> 5 * b"
  @have "10*(a+1) - 5*b + 2 = 10*a + 12 - 5*b"
@qed

fun dyn_array_P :: "'a::heap list \<times> nat \<Rightarrow> nat" where
  "dyn_array_P (xs, n) = 10 * n - 5 * length xs"
setup \<open>add_rewrite_rule @{thm dyn_array_P.simps}\<close>

lemma dyn_array_new_P [rewrite]:
  "dyn_array_P (replicate 5 0, 0) = 0" by auto2

lemma double_length_fun_P [resolve]:
  "length xs = n \<Longrightarrow>
   dyn_array_P (xs, n) + 4 \<ge> dyn_array_P (double_length_fun (xs, n)) + (5*n+4)" by auto2

lemma push_array_fun_P [resolve]:
  "n \<le> length xs \<Longrightarrow>
   dyn_array_P (xs, n) + 12 \<ge> dyn_array_P (push_array_basic_fun x (xs, n)) + 2" by auto2

lemma update_P [rewrite]:
  "i < n \<Longrightarrow> dyn_array_P (list_update xs i x, n) = dyn_array_P (xs, n)" by auto2

setup \<open>del_prfstep_thm @{thm dyn_array_P.simps}\<close>

section \<open>Refined assertion\<close>

definition dyn_array' :: "'a::heap list \<times> nat \<Rightarrow> 'a dynamic_array \<Rightarrow> assn" where [rewrite_ent]:
  "dyn_array' p r = dyn_array_raw p r * $(dyn_array_P p)"

definition array_length :: "'a::heap dynamic_array \<Rightarrow> nat Heap" where
  "array_length d = return (alen d)"

lemma array_length_rule' [hoare_triple]:
  "<dyn_array' (xs, n) p * $1>
   array_length p
   <\<lambda>r. dyn_array' (xs, n) p * \<up>(r = n)>" by auto2

definition array_max :: "'a::heap dynamic_array \<Rightarrow> nat Heap" where
  "array_max d = Array_Time.len (aref d)"

lemma array_max_rule' [hoare_triple]:
  "<dyn_array' (xs, n) p * $1>
   array_max p
   <\<lambda>r. dyn_array' (xs, n) p * \<up>(r = length xs)>" by auto2

definition array_nth :: "'a::heap dynamic_array \<Rightarrow> nat \<Rightarrow> 'a Heap" where
  "array_nth d i = Array_Time.nth (aref d) i"

lemma array_nth_rule' [hoare_triple]:
  "i < n \<Longrightarrow> n \<le> length xs \<Longrightarrow>
   <dyn_array' (xs, n) p * $1>
   array_nth p i
   <\<lambda>r. dyn_array' (xs, n) p * \<up>(r = xs ! i)>" by auto2

definition array_upd :: "nat \<Rightarrow> 'a \<Rightarrow> 'a::heap dynamic_array \<Rightarrow> unit Heap" where
  "array_upd i x d = do { Array_Time.upd i x (aref d); return () }"

lemma array_upd_rule' [hoare_triple]:
  "i < n \<Longrightarrow> n \<le> length xs \<Longrightarrow>
   <dyn_array' (xs, n) p * $2>
   array_upd i x p
   <\<lambda>_. dyn_array' (list_update xs i x, n) p>" by auto2

definition destroy :: "'a::{zero,heap} dynamic_array \<Rightarrow> 'a array Heap" where
  "destroy d = (case d of Dyn_Array al ar \<Rightarrow> do {
      p \<leftarrow> Array_Time.new al 0;
      array_copy ar p al;
      return p
   })"

lemma destroy_fun_correct [rewrite]:
  "n \<le> length xs \<Longrightarrow> Arrays_Ex.array_copy xs (replicate n 0) n = take n xs"
proof -
  assume inbound: "n \<le> length xs"
  have "Arrays_Ex.array_copy xs (replicate n 0) n
      = take n (Arrays_Ex.array_copy xs (replicate n 0) n)"
    by (simp add: array_copy_length inbound)
  also have "\<dots> = take n xs"
    apply(rule array_copy_correct) apply auto by fact
  finally show ?thesis by simp
qed

lemma destroy_rule' [hoare_triple]:
  "n \<le> length xs \<Longrightarrow>
   <dyn_array' (xs, n) d * $(4 * n + 3)>
   destroy d
   <\<lambda>r. r \<mapsto>\<^sub>a take n xs>\<^sub>t" by auto2

setup \<open>del_prfstep_thm @{thm dyn_array_raw.simps}\<close>

lemma dyn_array_new_rule' [hoare_triple]:
  "<$7>
   dyn_array_new
   <dyn_array' (replicate 5 0, 0)>\<^sub>t"
@proof
  @have "7 \<ge>\<^sub>t 7 + dyn_array_P (replicate 5 0, 0)"
@qed

lemma double_length_rule' [hoare_triple]:
  "length xs = n \<Longrightarrow>
   <dyn_array' (xs, n) p * $5>
   double_length p
   <dyn_array' (double_length_fun (xs, n))>\<^sub>t"
@proof
  @have "dyn_array_P (xs, n) + 4 \<ge>\<^sub>t dyn_array_P (double_length_fun (xs, n)) + (5*n+4)"
@qed

lemma push_array_basic_rule' [hoare_triple]:
  "n < length xs \<Longrightarrow>
   <dyn_array' (xs, n) p * $12>
    push_array_basic x p
   <dyn_array' (list_update xs n x, n + 1)>\<^sub>t"
@proof
  @have "dyn_array_P (xs, n) + 12 \<ge>\<^sub>t dyn_array_P (push_array_basic_fun x (xs, n)) + 2"
@qed

definition push_array :: "'a \<Rightarrow> 'a::{zero,heap} dynamic_array \<Rightarrow> 'a dynamic_array Heap" where
  "push_array x p = do {
    m \<leftarrow> array_max p;
    l \<leftarrow> array_length p;
    if l < m then push_array_basic x p
    else do {
      u \<leftarrow> double_length p;
      push_array_basic x u
    }
  }"

fun push_array_fun :: "'a \<Rightarrow> 'a::{zero,heap} list \<times> nat \<Rightarrow> 'a list \<times> nat" where
  "push_array_fun x (xs, n) = (
     if n < length xs then push_array_basic_fun x (xs, n)
     else push_array_basic_fun x (double_length_fun (xs, n)))"
setup \<open>add_rewrite_rule @{thm push_array_fun.simps}\<close>

setup \<open>del_prfstep_thm @{thm dyn_array'_def}\<close>

end


theory T92
imports Main
begin
lemma "(
(\<forall> x::nat. \<forall> y::nat. meet(x, y) = meet(y, x)) &
(\<forall> x::nat. \<forall> y::nat. join(x, y) = join(y, x)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, meet(y, z)) = meet(meet(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(x, join(y, z)) = join(join(x, y), z)) &
(\<forall> x::nat. \<forall> y::nat. meet(x, join(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. join(x, meet(x, y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, join(y, z)) = join(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(join(x, y), z) = join(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(x, over(join(mult(x, y), z), y)) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. meet(y, undr(x, join(mult(x, y), z))) = y) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(over(x, y), y), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. join(mult(y, undr(y, x)), x) = x) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(x, meet(y, z)) = meet(mult(x, y), mult(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. mult(meet(x, y), z) = meet(mult(x, z), mult(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(join(x, y), z) = join(over(x, z), over(y, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. over(x, meet(y, z)) = join(over(x, y), over(x, z))) &
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(meet(x, y), z) = join(undr(x, z), undr(y, z))) &
(\<forall> x::nat. \<forall> y::nat. invo(join(x, y)) = meet(invo(x), invo(y))) &
(\<forall> x::nat. \<forall> y::nat. invo(meet(x, y)) = join(invo(x), invo(y))) &
(\<forall> x::nat. invo(invo(x)) = x)
) \<longrightarrow>
(\<forall> x::nat. \<forall> y::nat. \<forall> z::nat. undr(x, join(y, z)) = join(undr(x, y), undr(x, z)))
"
nitpick[card nat=8,timeout=86400]
oops
end


(*  Author:  Gertrud Bauer  *)

section \<open>Correctness of Lower Bound for Final Graphs\<close>

theory LowerBound
imports PlaneProps ScoreProps
begin

(*<*)
lemma trans1:
 "(l::nat) = a1 + a2 + (a3 + a4) \<Longrightarrow> a1 + a3 = r \<Longrightarrow> l = r + a2 + a4"
by simp

lemma trans2: "(l::nat) =  a1 + a2 + a3  \<Longrightarrow>  a1 \<le> r \<Longrightarrow> l \<le> r + a2 + a3"
by simp

lemma trans3:
 "(l::nat) \<le>  a1 + a2 + (a3 + a4) \<Longrightarrow> a2 + a3 \<le> r \<Longrightarrow> l \<le> a1 + r + a4"
by simp

lemma trans4: "(l::nat) \<le> a1 + a2 + a3 \<Longrightarrow> a3 \<le> r \<Longrightarrow> l \<le> a1 + a2 + r"
by simp

lemma trans5: "(l::nat) \<le> a1 + a2 + a3 \<Longrightarrow> a2 + a3 = r \<Longrightarrow> l \<le> a1 + r"
by simp

lemma trans6: "(a::nat) = b1 + (b2 + b3) + b4 \<Longrightarrow> b3 = 0 \<Longrightarrow>
            a = b1 + b2 + b4" by (simp add: ac_simps)
(*>*)

(* FIXME in Tame: admissibility should be expressed via sum!
   \<rightarrow> convert a lot of listsum to sum
*)

theorem total_weight_lowerbound:
 "inv g \<Longrightarrow> final g \<Longrightarrow> tame g \<Longrightarrow> admissible w g \<Longrightarrow>
 (\<Sum>\<^bsub>f \<in> faces g\<^esub> w f) < squanderTarget \<Longrightarrow>
 squanderLowerBound g \<le> (\<Sum>\<^bsub>f \<in> faces g\<^esub> w f)"
proof -
  assume final: "final g" and tame: "tame g" and pl: "inv g"
  assume admissible: "admissible w g"
  assume w: "(\<Sum>\<^bsub>f \<in> faces g\<^esub> w f) < squanderTarget"
(*<*)
  from admissible have admissible\<^sub>1:
   "\<And>f. f \<in> set (faces g) \<Longrightarrow> \<d> |vertices f| \<le> w f"
    by (simp add: admissible_def admissible\<^sub>1_def)
(*>*) (* *)

  have "squanderLowerBound g
     = ExcessNotAt g None + faceSquanderLowerBound g"
    by (simp add: squanderLowerBound_def)

  txt \<open>We expand the definition of \<open>faceSquanderLowerBound\<close>.\<close>

  also have "faceSquanderLowerBound g = (\<Sum>\<^bsub>f \<in> faces g\<^esub> \<d> |vertices f| )" (*<*)
    by (simp add: faceSquanderLowerBound_def final) (*>*)

  txt \<open>We expand the definition of \<open>ExcessNotAt\<close>.\<close>
  also from ExcessNotAt_eq[OF pl[THEN inv_mgp] final] obtain V
    where eq: "ExcessNotAt g None = (\<Sum>\<^bsub>v \<in> V\<^esub> ExcessAt g v)"
    and pS:  "separated g (set V)"
    and V_subset: "set V \<subseteq> set(vertices g)"
    and V_distinct: "distinct V" (*<*)
    by (blast) note eq

  txt \<open>We partition V in two disjoint subsets $V1, V2$,
  where $V2$ contains all exceptional vertices, $V1$ all
  not exceptional vertices.\<close>

  also
  define V1 where "V1 = [v \<leftarrow> V. except g v = 0]"
  define V2 where "V2 = [v \<leftarrow> V. except g v \<noteq> 0]"  (*<*)
  have s: "set V1 \<subseteq> set V" by (auto simp add: V1_def)
  with pS obtain pSV1: "separated g (set V1)"
    by (auto dest: separated_subset)
  from V_distinct obtain V1_distinct: "distinct V1"
    by (unfold V1_def) (auto dest: distinct_filter)
  obtain noExV1: "noExceptionals g (set V1)"
    by (auto simp add: V1_def noExceptionals_def
      exceptionalVertex_def)
(*>*) (* *)

  have V_subset_simp: "\<And>v. v: set V \<Longrightarrow> v : \<V> g"
    using V_subset by fast

  have "(\<Sum>\<^bsub>v \<in> V\<^esub> ExcessAt g v)
    = (\<Sum>\<^bsub>v \<in> V1\<^esub> ExcessAt g v) + (\<Sum>\<^bsub>v \<in> V2\<^esub> ExcessAt g v)" (*<*)
     by (simp only: V1_def V2_def ListSum_compl) (*>*)

  txt \<open>We partition \<open>V2\<close> in two disjoint subsets,
  $V4$ contains all exceptional vertices of degree $\neq 5$
  $V3$ contains all exceptional vertices of degree $5$.
\<close>

  also
  define V4 where "V4 = [v \<leftarrow> V2. vertextype g v \<noteq> (5,0,1)]"
  define V3 where "V3 = [v \<leftarrow> V2. vertextype g v = (5,0,1)]"

(*<*)
  with pS V2_def have V3: "separated g (set V3)"
    by (rule_tac separated_subset) auto
  have "distinct V3" by(simp add:V3_def V2_def \<open>distinct V\<close>)
(*
  with V3_def V2_def obtain V3: "separated g (set V3)"
    by (simp add: vertextype_def separated_def preSeparated_def separated\<^sub>1_def
      separated\<^sub>4_def)
*)
  from V_subset obtain V3_subset: "set V3 \<subseteq> \<V> g"
    by (auto simp add: V3_def V2_def)
(*>*)

  have "(\<Sum>\<^bsub>v \<in> V2\<^esub> ExcessAt g v)
    = (\<Sum>\<^bsub>v \<in> V3\<^esub> ExcessAt g v) + (\<Sum>\<^bsub>v \<in> V4\<^esub> ExcessAt g v)" (*<*)
    by (simp add: V4_def V3_def ListSum_compl) (*>*) (* *)

  txt \<open>We partition  \<open>faces g\<close> in two disjoint subsets:
  $F1$ contains all faces that contain a vertex of $V1$,
  $F2$ the remaining faces.\<close>

  also
  define F1 where "F1 = [f \<leftarrow> faces g . \<exists> v \<in> set V1. f \<in> set (facesAt g v)]"
  define F2 where "F2 = [f \<leftarrow> faces g . \<not>(\<exists> v \<in> set V1. f \<in> set (facesAt g v))]"

  have "(\<Sum>\<^bsub>f \<in> faces g\<^esub> \<d> |vertices f| )
      = (\<Sum>\<^bsub>f \<in> F1\<^esub> \<d> |vertices f| ) + (\<Sum>\<^bsub> f \<in> F2\<^esub> \<d> |vertices f| )" (*<*)
    by (simp only: ListSum_compl F1_def F2_def) (*>*) (* *)

  txt \<open>We split up \<open>F2\<close> in two disjoint subsets:\<close>

  also
  define F3 where "F3 = [f\<leftarrow>F2. \<exists>v \<in> set V3. f \<in> set (facesAt g v)]"
  define F4 where "F4 = [f\<leftarrow>F2. \<not> (\<exists>v \<in> set V3. f \<in> set (facesAt g v))]"

  have F3: "F3 = [f\<leftarrow>faces g . \<exists>v \<in> set V3. f \<in> set (facesAt g v)]"
  proof(simp add: F3_def F2_def, intro filter_eqI iffI conjI)
     fix f assume "f \<in> set (faces g)"
     with final have fin: "final f" by (rule finalGraph_face)
     assume "\<exists>v3\<in>set V3. f \<in> set (facesAt g v3)"
     then obtain v3 where v3: "v3 \<in> set V3" "f \<in> set (facesAt g v3)"
       by auto
     show "(\<forall>v1\<in>set V1. f \<notin> set (facesAt g v1))"
     proof (intro ballI notI)
       fix v1 assume v1: "v1 \<in> set V1"
       with v3 have "v1 \<noteq> v3"
         by (auto simp add: V3_def V2_def V1_def)

       moreover assume f: "f \<in> set (facesAt g v1)"
       with v1 fin have c: "|vertices f| \<le> 4"
         by (auto simp add: V1_def except_def)

       from v1 have "v1 \<in> set V" by (simp add: V1_def)
       with f pS c have "set (vertices f) \<inter> set V = {v1}"
         by (simp add: separated_def separated\<^sub>3_def)

       moreover from v3 have "v3 \<in> set V"
         by (simp add: V3_def V2_def)
       with v3 pS c have "set (vertices f) \<inter> set V = {v3}"
         by (simp add: separated_def separated\<^sub>3_def)
       ultimately show False by auto
    qed
  qed simp

  have "(\<Sum>\<^bsub>f\<in>F2\<^esub> \<d> |vertices f| )
   = (\<Sum>\<^bsub>f\<in>F3\<^esub> \<d> |vertices f| ) + (\<Sum>\<^bsub>f\<in>F4\<^esub> \<d> |vertices f| )" (*<*)
    by (simp only: F3_def F4_def ListSum_compl) (*>*) (* *)

  text_raw \<open>\newpage\<close>
  txt \<open>($E_1$) From the definition of \<open>ExcessAt\<close> we have\<close>

  also have "(\<Sum>\<^bsub>v \<in> V1\<^esub> ExcessAt g v) + (\<Sum>\<^bsub> f \<in> F1\<^esub> \<d> |vertices f| )
      = (\<Sum>\<^bsub>v \<in> V1\<^esub> \<b> (tri g v) (quad g v))"
  proof -
    from noExV1 V_subset have "(\<Sum>\<^bsub> f \<in> F1\<^esub> \<d> |vertices f| )
      = (\<Sum>\<^bsub>v \<in> V1\<^esub> (tri g v *  \<d> 3 + quad g v * \<d> 4))"
    apply (unfold F1_def)
    apply (rule_tac squanderFace_distr2)
    apply (rule pl)
    apply (rule final)
    apply (rule noExV1)
    apply (rule pSV1)
    apply (rule V1_distinct)
    apply (unfold V1_def)
    apply auto
    done

    also have "(\<Sum>\<^bsub>v \<in> V1\<^esub> ExcessAt g v)
      + (\<Sum>\<^bsub>v \<in> V1\<^esub> (tri g v * \<d> 3 + quad g v * \<d> 4))
      = (\<Sum>\<^bsub>v \<in> V1\<^esub> (ExcessAt g v
      + tri g v * \<d> 3 + quad g v * \<d> 4))" (*<*)
      by (simp add: ListSum_add ac_simps) (*>*) (* FIXME  also takes too long *)
    also from pl final tame have "\<dots> = (\<Sum>\<^bsub>v \<in> V1\<^esub> \<b> (tri g v) (quad g v))"
      by (rule_tac ListSum_eq)
         (fastforce simp add: V1_def V_subset[THEN subsetD] intro: excess_eq1)
    finally show ?thesis .
  qed

  txt \<open>($E_2$)  For all exceptional vertices of degree $5$
  \<open>excess\<close> returns \<open>a (tri g v)\<close>.\<close>

  also (trans1)
    from pl final V_subset have
    "(\<Sum>\<^bsub>v \<in> V3\<^esub> ExcessAt g v) = (\<Sum>\<^bsub>v \<in> V3\<^esub> \<a>)" (*<*)
     apply (rule_tac ListSum_eq)
     apply (simp add: V3_def V2_def excessAtType_def ExcessAt_def degree_eq vertextype_def)
     by(blast intro: finalVertexI)
(*     apply force by(blast intro: finalVertexI)*) (*>*) (* *)

  txt \<open>($E_3$) For all exceptional vertices of degree $\neq 5$
  \<open>ExcessAt\<close> returns 0.\<close>

  also from pl final tame have "(\<Sum>\<^bsub>v \<in> V4\<^esub> ExcessAt g v) = (\<Sum>\<^bsub>v \<in> V4\<^esub> 0)" (*<*)
    by (rule_tac ListSum_eq)
       (auto simp: V2_def V4_def excessAtType_def ExcessAt_def degree_eq V_subset_simp tame_def tame12o_def) (*>*) (* *)

  also have "\<dots> = 0" (*<*) by simp   (*>*) (* *)

  txt \<open>($A_1$) We use property \<open>admissible\<^sub>2\<close>.\<close>

  also(trans6) have
  "(\<Sum>\<^bsub>v \<in> V1\<^esub> \<b> (tri g v) (quad g v)) \<le> (\<Sum>\<^bsub>v \<in> V1\<^esub> \<Sum>\<^bsub>f \<in> facesAt g v\<^esub> w f)"

  proof (rule_tac ListSum_le)
    fix v assume "v \<in> set V1"
    with V1_def V_subset have "v \<in> set (vertices g)" (*<*)  by auto (*>*) (* *)
    with admissible show "\<b> (tri g v) (quad g v) \<le> (\<Sum>\<^bsub>f \<in> facesAt g v\<^esub> w f)"
      using \<open>v \<in> set V1\<close> by (auto simp add:admissible_def admissible\<^sub>2_def V1_def)
  qed

  also(trans2) from pSV1 V1_distinct V_subset have "\<dots> = (\<Sum>\<^bsub>f \<in> F1\<^esub> w f)"
    apply (unfold F1_def)
    apply (rule ScoreProps.separated_disj_Union2)
    apply (rule pl)
    apply (rule final)
    apply (rule noExV1)
    apply (rule pSV1)
    apply (rule V1_distinct)
    apply (unfold V1_def)
    apply auto
    done

  txt \<open>($A_2$) We use property \<open>admissible\<^sub>4\<close>.\<close>

  also have "(\<Sum>\<^bsub>v\<in>V3\<^esub> \<a>) + (\<Sum>\<^bsub>f\<in>F3\<^esub> \<d> |vertices f| ) \<le> (\<Sum>\<^bsub>f \<in> F3 \<^esub>w f)" (*<*)
  proof-
    define T where "T = [f\<leftarrow>F3. triangle f]"
    define E where "E = [f\<leftarrow>F3. \<not> triangle f]"
    have "(\<Sum>\<^bsub>f\<in>F3\<^esub> \<d> |vertices f| ) =
      (\<Sum>\<^bsub>f\<in>T\<^esub> \<d> |vertices f| ) + (\<Sum>\<^bsub>f\<in>E\<^esub> \<d> |vertices f| )"
      by(simp only: T_def E_def ListSum_compl2)
    also have "(\<Sum>\<^bsub>f\<in>T\<^esub> \<d> |vertices f| ) =
          (\<Sum>\<^bsub>f \<in> [f\<leftarrow>faces g . \<exists>v \<in> set V3. f \<in> set (facesAt g v) \<inter> Collect triangle]\<^esub> \<d> |vertices f| )"
      by(rule listsum_cong[OF _ HOL.refl])
        (simp add:T_def F3 Int_def)
    also have "\<dots> = (\<Sum>\<^bsub>v \<in> V3\<^esub> \<Sum>\<^bsub>f \<in> filter triangle (facesAt g v)\<^esub> \<d> |vertices f| )"
      by(rule ListSum_V_F_eq_ListSum_F[symmetric, OF \<open>inv g\<close> V3 \<open>distinct V3\<close> \<open>set V3 \<subseteq> \<V> g\<close>])
        (simp add:Ball_def)
    also have "\<dots> = 0" by (simp add: squanderFace_def)
    finally have "(\<Sum>\<^bsub>v\<in>V3\<^esub> \<a>) + (\<Sum>\<^bsub>f\<in>F3\<^esub> \<d> |vertices f| ) =
      (\<Sum>\<^bsub>v\<in>V3\<^esub> \<a>) + (\<Sum>\<^bsub>f\<in>E\<^esub> \<d> |vertices f| )" by simp
    also have "(\<Sum>\<^bsub>f\<in>E\<^esub> \<d> |vertices f| ) \<le> (\<Sum>\<^bsub>f\<in>E\<^esub> w f )"
      using \<open>admissible w g\<close>
      by(rule_tac ListSum_le)
        (simp add: admissible_def admissible\<^sub>1_def E_def F3_def F2_def)
    also have "(\<Sum>\<^bsub>v\<in>V3\<^esub> \<a>) \<le> (\<Sum>\<^bsub>v\<in>V3\<^esub> \<Sum>\<^bsub>f\<in>filter triangle (facesAt g v)\<^esub> w(f))"
      using \<open>admissible w g\<close>
      by(rule_tac ListSum_le)
        (simp add: admissible_def admissible\<^sub>3_def V3_def V2_def V_subset_simp)
    also have "\<dots> = (\<Sum>\<^bsub>f \<in> [f\<leftarrow>faces g . \<exists>v \<in> set V3. f \<in> set (facesAt g v) \<inter> Collect triangle]\<^esub> w f)"
      by(rule ListSum_V_F_eq_ListSum_F[OF \<open>inv g\<close> V3 \<open>distinct V3\<close> \<open>set V3 \<subseteq> \<V> g\<close>])
        (simp add:Ball_def)
    also have "\<dots> = (\<Sum>\<^bsub>f\<in>T\<^esub> w f)"
      by(simp add: T_def F3 Int_def)
    also have "ListSum T w + ListSum E w = ListSum F3 w"
      by(simp add: T_def E_def ListSum_compl2)
    finally show ?thesis by simp
  qed

  text_raw \<open>\newpage\<close>
  txt \<open>($A_3$) We use property \<open>admissible\<^sub>1\<close>.\<close>

  also(trans3) have "(\<Sum>\<^bsub> f \<in> F4\<^esub> \<d> |vertices f| ) \<le> (\<Sum>\<^bsub>f \<in> F4\<^esub> w f)"
  proof (rule ListSum_le)
    fix f assume "f \<in> set F4"
    then have f: "f \<in> set (faces g)" (*<*) by (simp add: F4_def F2_def)(*>*) (* *)
    with admissible\<^sub>1 f show "\<d> |vertices f| \<le> w f" by (simp)
  qed

  txt \<open>We reunite $F3$ and $F4$.\<close>

  also(trans4) have "(\<Sum>\<^bsub> f \<in> F3\<^esub> w f) + (\<Sum>\<^bsub> f \<in> F4\<^esub> w f) = (\<Sum>\<^bsub> f \<in> F2\<^esub> w f)" (*<*)
    by (simp only: F3_def F4_def ListSum_compl) (*>*) (* *)

  txt \<open>We reunite $F1$ and $F2$.\<close>

  also(trans5) have "(\<Sum>\<^bsub> f \<in> F1\<^esub> w f) + (\<Sum>\<^bsub> f \<in> F2\<^esub> w f) = (\<Sum>\<^bsub>f \<in> faces g\<^esub> w f)" (*<*)
    by (simp only: F1_def F2_def ListSum_compl) (*>*) (* *)

  finally show "squanderLowerBound g \<le> (\<Sum>\<^bsub>f \<in> faces g\<^esub> w f)" .
qed

end


(* Author: Alexander Maletzky *)

section \<open>Computing Gr\"obner Bases by Triangularizing Macaulay Matrices\<close>

theory Groebner_Macaulay
  imports Groebner_Bases.Macaulay_Matrix Groebner_Bases.Groebner_PM Degree_Section Degree_Bound_Utils
begin

text \<open>Relationship between Gr\"obner bases and Macaulay matrices, following
  \<^cite>\<open>"Wiesinger-Widi2015"\<close>.\<close>

subsection \<open>Gr\"obner Bases\<close>

lemma (in gd_term) Macaulay_list_is_GB:
  assumes "is_Groebner_basis G" and "pmdl (set ps) = pmdl G" and "G \<subseteq> phull (set ps)"
  shows "is_Groebner_basis (set (Macaulay_list ps))"
proof (simp only: GB_alt_3_finite[OF finite_set] pmdl_Macaulay_list, intro ballI impI)
  fix f
  assume "f \<in> pmdl (set ps)"
  also from assms(2) have "\<dots> = pmdl G" .
  finally have "f \<in> pmdl G" .
  assume "f \<noteq> 0"
  with assms(1) \<open>f \<in> pmdl G\<close> obtain g where "g \<in> G" and "g \<noteq> 0" and "lt g adds\<^sub>t lt f"
    by (rule GB_adds_lt)
  from assms(3) \<open>g \<in> G\<close> have "g \<in> phull (set ps)" ..
  from this \<open>g \<noteq> 0\<close> obtain g' where "g' \<in> set (Macaulay_list ps)" and "g' \<noteq> 0" and "lt g = lt g'"
    by (rule Macaulay_list_lt)
  show "\<exists>g\<in>set (Macaulay_list ps). g \<noteq> 0 \<and> lt g adds\<^sub>t lt f"
  proof (rule, rule)
    from \<open>lt g adds\<^sub>t lt f\<close> show "lt g' adds\<^sub>t lt f" by (simp only: \<open>lt g = lt g'\<close>)
  qed fact+
qed

subsection \<open>Bounds\<close>

context pm_powerprod
begin

context
  fixes X :: "'x set"
  assumes fin_X: "finite X"
begin

definition deg_shifts :: "nat \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b) list \<Rightarrow> (('x \<Rightarrow>\<^sub>0 nat) \<Rightarrow>\<^sub>0 'b::semiring_1) list"
  where "deg_shifts d fs = concat (map (\<lambda>f. (map (\<lambda>t. punit.monom_mult 1 t f)
                                        (punit.pps_to_list (deg_le_sect X (d - poly_deg f))))) fs)"

lemma set_deg_shifts:
  "set (deg_shifts d fs) = (\<Union>f\<in>set fs. (\<lambda>t. punit.monom_mult 1 t f) ` (deg_le_sect X (d - poly_deg f)))"
proof -
  from fin_X have "finite (deg_le_sect X d0)" for d0 by (rule finite_deg_le_sect)
  thus ?thesis by (simp add: deg_shifts_def punit.set_pps_to_list)
qed

corollary set_deg_shifts_singleton:
  "set (deg_shifts d [f]) = (\<lambda>t. punit.monom_mult 1 t f) ` (deg_le_sect X (d - poly_deg f))"
  by (simp add: set_deg_shifts)

lemma deg_shifts_superset: "set fs \<subseteq> set (deg_shifts d fs)"
proof -
  have "set fs = (\<Union>f\<in>set fs. {punit.monom_mult 1 0 f})" by simp
  also have "\<dots> \<subseteq> set (deg_shifts d fs)" unfolding set_deg_shifts using subset_refl
  proof (rule UN_mono)
    fix f
    assume "f \<in> set fs"
    have "punit.monom_mult 1 0 f \<in> (\<lambda>t. punit.monom_mult 1 t f) ` deg_le_sect X (d - poly_deg f)"
      using zero_in_deg_le_sect by (rule imageI)
    thus "{punit.monom_mult 1 0 f} \<subseteq> (\<lambda>t. punit.monom_mult 1 t f) ` deg_le_sect X (d - poly_deg f)"
      by simp
  qed
  finally show ?thesis .
qed

lemma deg_shifts_mono:
  assumes "set fs \<subseteq> set gs"
  shows "set (deg_shifts d fs) \<subseteq> set (deg_shifts d gs)"
  using assms by (auto simp add: set_deg_shifts)

lemma ideal_deg_shifts [simp]: "ideal (set (deg_shifts d fs)) = ideal (set fs)"
proof
  show "ideal (set (deg_shifts d fs)) \<subseteq> ideal (set fs)"
    by (rule ideal.span_subset_spanI, simp add: set_deg_shifts UN_subset_iff,
        intro ballI image_subsetI) (metis ideal.span_scale times_monomial_left ideal.span_base)
next
  from deg_shifts_superset show "ideal (set fs) \<subseteq> ideal (set (deg_shifts d fs))"
    by (rule ideal.span_mono)
qed

lemma thm_2_3_6:
  assumes "set fs \<subseteq> P[X]" and "is_GB_cofactor_bound (set fs) b"
  shows "punit.is_Groebner_basis (set (punit.Macaulay_list (deg_shifts b fs)))"
proof -
  from assms(2) finite_set assms(1) obtain G where "punit.is_Groebner_basis G"
    and ideal_G: "ideal G = ideal (set fs)" and G_sub: "G \<subseteq> P[X]"
    and 1: "\<And>g. g \<in> G \<Longrightarrow> \<exists>q. g = (\<Sum>f\<in>set fs. q f * f) \<and> (\<forall>f. q f \<in> P[X] \<and> poly_deg (q f * f) \<le> b)"
    by (rule is_GB_cofactor_boundE_finite_Polys) blast
  from this(1) show ?thesis
  proof (rule punit.Macaulay_list_is_GB)
    show "G \<subseteq> phull (set (deg_shifts b fs))" (is "_ \<subseteq> ?H")
    proof
      fix g
      assume "g \<in> G"
      hence "\<exists>q. g = (\<Sum>f\<in>set fs. q f * f) \<and> (\<forall>f. q f \<in> P[X] \<and> poly_deg (q f * f) \<le> b)" by (rule 1)
      then obtain q where g: "g = (\<Sum>f\<in>set fs. q f * f)" and "\<And>f. q f \<in> P[X]"
        and "\<And>f. poly_deg (q f * f) \<le> b" by blast
      show "g \<in> ?H" unfolding g
      proof (rule phull.span_sum)
        fix f
        assume "f \<in> set fs"
        have "1 \<noteq> (0::'a)" by simp
        show "q f * f \<in> ?H"
        proof (cases "f = 0 \<or> q f = 0")
          case True
          thus ?thesis by (auto simp add: phull.span_zero)
        next
          case False
          hence "q f \<noteq> 0" and "f \<noteq> 0" by simp_all
          with \<open>poly_deg (q f * f) \<le> b\<close> have "poly_deg (q f) \<le> b - poly_deg f"
            by (simp add: poly_deg_times)
          with \<open>q f \<in> P[X]\<close> have "keys (q f) \<subseteq> deg_le_sect X (b - poly_deg f)"
            by (rule keys_subset_deg_le_sectI)
          with finite_deg_le_sect[OF fin_X]
          have "q f * f = (\<Sum>t\<in>deg_le_sect X (b - poly_deg f). punit.monom_mult (lookup (q f) t) t f)"
            unfolding punit.mult_scalar_sum_monomials[simplified]
            by (rule sum.mono_neutral_left) (simp add: in_keys_iff)
          also have "\<dots> = (\<Sum>t\<in>deg_le_sect X (b - poly_deg f).
                              (lookup (q f) t) \<cdot> (punit.monom_mult 1 t f))"
            by (simp add: punit.monom_mult_assoc punit.map_scale_eq_monom_mult)
          also have "\<dots> = (\<Sum>t\<in>deg_le_sect X (b - poly_deg f).
                          ((\<lambda>f0. (lookup (q f) (punit.lp f0 - punit.lp f)) \<cdot> f0) \<circ>
                          (\<lambda>t. punit.monom_mult 1 t f)) t)"
            using refl by (rule sum.cong) (simp add: punit.lt_monom_mult[OF \<open>1 \<noteq> 0\<close> \<open>f \<noteq> 0\<close>])
          also have "\<dots> = (\<Sum>f0\<in>set (deg_shifts b [f]). (lookup (q f) (punit.lp f0 - punit.lp f)) \<cdot> f0)"
            unfolding set_deg_shifts_singleton
          proof (intro sum.reindex[symmetric] inj_onI)
            fix s t
            assume "punit.monom_mult 1 s f = punit.monom_mult 1 t f"
            thus "s = t" using \<open>1 \<noteq> 0\<close> \<open>f \<noteq> 0\<close> by (rule punit.monom_mult_inj_2)
          qed
          finally have "q f * f \<in> phull (set (deg_shifts b [f]))"
            by (simp add: phull.sum_in_spanI)
          also have "\<dots> \<subseteq> ?H" by (rule phull.span_mono, rule deg_shifts_mono, simp add: \<open>f \<in> set fs\<close>)
          finally show ?thesis .
        qed
      qed
    qed
  qed (simp add: ideal_G)
qed

lemma thm_2_3_7:
  assumes "set fs \<subseteq> P[X]" and "is_GB_cofactor_bound (set fs) b"
  shows "1 \<in> ideal (set fs) \<longleftrightarrow> 1 \<in> set (punit.Macaulay_list (deg_shifts b fs))" (is "?L \<longleftrightarrow> ?R")
proof
  assume ?L
  let ?G = "set (punit.Macaulay_list (deg_shifts b fs))"
  from assms have "punit.is_Groebner_basis ?G" by (rule thm_2_3_6)
  moreover from \<open>?L\<close> have "1 \<in> ideal ?G" by (simp add: punit.pmdl_Macaulay_list[simplified])
  moreover have "1 \<noteq> (0::_ \<Rightarrow>\<^sub>0 'a)" by simp
  ultimately obtain g where "g \<in> ?G" and "g \<noteq> 0" and "punit.lt g adds punit.lt (1::_ \<Rightarrow>\<^sub>0 'a)"
    by (rule punit.GB_adds_lt[simplified])
  from this(3) have lp_g: "punit.lt g = 0" by (simp add: punit.lt_monomial adds_zero flip: single_one)
  from punit.Macaulay_list_is_monic_set \<open>g \<in> ?G\<close> \<open>g \<noteq> 0\<close> have lc_g: "punit.lc g = 1"
    by (rule punit.is_monic_setD)
  have "g = 1"
  proof (rule poly_mapping_eqI)
    fix t
    show "lookup g t = lookup 1 t"
    proof (cases "t = 0")
      case True
      thus ?thesis using lc_g by (simp add: lookup_one punit.lc_def lp_g)
    next
      case False
      with zero_min[of t] have "\<not> t \<preceq> punit.lt g" by (simp add: lp_g)
      with punit.lt_max_keys have "t \<notin> keys g" by blast
      with False show ?thesis by (simp add: lookup_one in_keys_iff)
    qed
  qed
  with \<open>g \<in> ?G\<close> show "1 \<in> ?G" by simp
next
  assume ?R
  also have "\<dots> \<subseteq> phull (set (punit.Macaulay_list (deg_shifts b fs)))"
    by (rule phull.span_superset)
  also have "\<dots> = phull (set (deg_shifts b fs))" by (fact punit.phull_Macaulay_list)
  also have "\<dots> \<subseteq> ideal (set (deg_shifts b fs))" using punit.phull_subset_module by force
  finally show ?L by simp
qed

end

lemma thm_2_3_6_indets:
  assumes "is_GB_cofactor_bound (set fs) b"
  shows "punit.is_Groebner_basis (set (punit.Macaulay_list (deg_shifts (\<Union>(indets ` (set fs))) b fs)))"
  using _ _ assms
proof (rule thm_2_3_6)
  from finite_set show "finite (\<Union>(indets ` (set fs)))" by (simp add: finite_indets)
next
  show "set fs \<subseteq> P[\<Union>(indets ` (set fs))]" by (auto simp: Polys_alt)
qed

lemma thm_2_3_7_indets:
  assumes "is_GB_cofactor_bound (set fs) b"
  shows "1 \<in> ideal (set fs) \<longleftrightarrow> 1 \<in> set (punit.Macaulay_list (deg_shifts (\<Union>(indets ` (set fs))) b fs))"
  using _ _ assms
proof (rule thm_2_3_7)
  from finite_set show "finite (\<Union>(indets ` (set fs)))" by (simp add: finite_indets)
next
  show "set fs \<subseteq> P[\<Union>(indets ` (set fs))]" by (auto simp: Polys_alt)
qed

end (* pm_powerprod *)

end (* theory *)