section \<open>Arrays with in-place updates\<close>
theory Diff_Array imports
  Assoc_List
  Automatic_Refinement.Parametricity
  "HOL-Library.Code_Target_Numeral"
begin

datatype 'a array = Array "'a list"

subsection \<open>primitive operations\<close>

definition new_array :: "'a \<Rightarrow> nat \<Rightarrow> 'a array"
where "new_array a n = Array (replicate n a)"

primrec array_length :: "'a array \<Rightarrow> nat"
where "array_length (Array a) = length a"

primrec array_get :: "'a array \<Rightarrow> nat \<Rightarrow> 'a"
where "array_get (Array a) n = a ! n"

primrec array_set :: "'a array \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a array"
where "array_set (Array A) n a = Array (A[n := a])"

definition array_of_list :: "'a list \<Rightarrow> 'a array"
where "array_of_list = Array"

  \<comment> \<open>Grows array by @{text inc} elements initialized to value @{text x}.\<close>
primrec array_grow :: "'a array \<Rightarrow> nat \<Rightarrow> 'a \<Rightarrow> 'a array"
  where "array_grow (Array A) inc x = Array (A @ replicate inc x)"

  \<comment> \<open>Shrinks array to new size @{text sz}. Undefined if @{text "sz > array_length"}\<close>
primrec array_shrink :: "'a array \<Rightarrow> nat \<Rightarrow> 'a array"
  where "array_shrink (Array A) sz = (
  if (sz > length A) then
    undefined
  else
    Array (take sz A)
  )"

subsection \<open>Derived operations\<close>

text \<open>The following operations are total versions of
  \<open>array_get\<close> and \<open>array_set\<close>, which return a default
  value in case the index is out of bounds.
  They can be efficiently implemented in the target language by catching
  exceptions.
\<close>
definition "array_get_oo x a i \<equiv>
  if i<array_length a then array_get a i else x"
definition "array_set_oo f a i v \<equiv>
  if i<array_length a then array_set a i v else f ()"

primrec list_of_array :: "'a array \<Rightarrow> 'a list"
where "list_of_array (Array a) = a"

primrec assoc_list_of_array :: "'a array \<Rightarrow> (nat \<times> 'a) list"
where "assoc_list_of_array (Array a) = zip [0..<length a] a"

function assoc_list_of_array_code :: "'a array \<Rightarrow> nat \<Rightarrow> (nat \<times> 'a) list"
where [simp del]:
  "assoc_list_of_array_code a n =
  (if array_length a \<le> n then []
   else (n, array_get a n) # assoc_list_of_array_code a (n + 1))"
by pat_completeness auto
termination assoc_list_of_array_code
by(relation "measure (\<lambda>p. (array_length (fst p) - snd p))") auto

definition array_map :: "(nat \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a array \<Rightarrow> 'b array"
where "array_map f a = array_of_list (map (\<lambda>(i, v). f i v) (assoc_list_of_array a))"

definition array_foldr :: "(nat \<Rightarrow> 'a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a array \<Rightarrow> 'b \<Rightarrow> 'b"
where "array_foldr f a b = foldr (\<lambda>(k, v). f k v) (assoc_list_of_array a) b"

definition array_foldl :: "(nat \<Rightarrow> 'b \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'b \<Rightarrow> 'a array \<Rightarrow> 'b"
where "array_foldl f b a = foldl (\<lambda>b (k, v). f k b v) b (assoc_list_of_array a)"

subsection \<open>Lemmas\<close>

lemma array_length_new_array [simp]:
  "array_length (new_array a n) = n"
by(simp add: new_array_def)

lemma array_get_array_set_same [simp]:
  "n < array_length A \<Longrightarrow> array_get (array_set A n a) n = a"
by(cases A) simp

lemma array_get_array_set_other:
  "n \<noteq> n' \<Longrightarrow> array_get (array_set A n a) n' = array_get A n'"
by(cases A) simp

lemma list_of_array_grow [simp]:
  "list_of_array (array_grow a inc x) = list_of_array a @ replicate inc x"
by (cases a) (simp)

lemma array_grow_length [simp]:
  "array_length (array_grow a inc x) = array_length a + inc"
by (cases a)(simp add: array_of_list_def)

lemma array_grow_get [simp]:
  "i < array_length a \<Longrightarrow> array_get (array_grow a inc x) i = array_get a i"
  "\<lbrakk> i \<ge> array_length a;  i < array_length a + inc\<rbrakk> \<Longrightarrow> array_get (array_grow a inc x) i = x"
by (cases a, simp add: nth_append)+

lemma list_of_array_shrink [simp]:
  "\<lbrakk> s \<le> array_length a\<rbrakk> \<Longrightarrow> list_of_array (array_shrink a s) = take s (list_of_array a)"
by (cases a) simp

lemma array_shrink_get [simp]:
  "\<lbrakk> i < s; s \<le> array_length a \<rbrakk> \<Longrightarrow> array_get (array_shrink a s) i = array_get a i"
by (cases a) (simp)

lemma list_of_array_id [simp]: "list_of_array (array_of_list l) = l"
by (cases l)(simp_all add: array_of_list_def)

lemma map_of_assoc_list_of_array:
  "map_of (assoc_list_of_array a) k = (if k < array_length a then Some (array_get a k) else None)"
by(cases a, cases "k < array_length a")(force simp add: set_zip)+

lemma length_assoc_list_of_array [simp]:
  "length (assoc_list_of_array a) = array_length a"
by(cases a) simp

lemma distinct_assoc_list_of_array:
  "distinct (map fst (assoc_list_of_array a))"
by(cases a)(auto)

lemma array_length_array_map [simp]:
  "array_length (array_map f a) = array_length a"
by(simp add: array_map_def array_of_list_def)

lemma array_get_array_map [simp]:
  "i < array_length a \<Longrightarrow> array_get (array_map f a) i = f i (array_get a i)"
by(cases a)(simp add: array_map_def map_ran_conv_map array_of_list_def)

lemma array_foldr_foldr:
  "array_foldr (\<lambda>n. f) (Array a) b = foldr f a b"
by(simp add: array_foldr_def foldr_snd_zip)

lemma assoc_list_of_array_code_induct:
  assumes IH: "\<And>n. (n < array_length a \<Longrightarrow> P (Suc n)) \<Longrightarrow> P n"
  shows "P n"
proof -
  have "a = a \<longrightarrow> P n"
    by(rule assoc_list_of_array_code.induct[where P="\<lambda>a' n. a = a' \<longrightarrow> P n"])(auto intro: IH)
  thus ?thesis by simp
qed

lemma assoc_list_of_array_code [code]:
  "assoc_list_of_array a = assoc_list_of_array_code a 0"
proof(cases a)
  case (Array A)
  { fix n
    have "zip [n..<length A] (drop n A) = assoc_list_of_array_code (Array A) n"
    proof(induct n taking: "Array A" rule: assoc_list_of_array_code_induct)
      case (1 n)
      show ?case
      proof(cases "n < array_length (Array A)")
        case False
        thus ?thesis by(simp add: assoc_list_of_array_code.simps)
      next
        case True
        hence "zip [Suc n..<length A] (drop (Suc n) A) = assoc_list_of_array_code (Array A) (Suc n)"
          by(rule 1)
        moreover from True have "n < length A" by simp
        moreover then obtain a A' where A: "drop n A = a # A'" by(cases "drop n A") auto
        moreover with \<open>n < length A\<close> have [simp]: "a = A ! n"
          by(subst append_take_drop_id[symmetric, where n=n])(simp add: nth_append min_def)
        moreover from A have "drop (Suc n) A = A'"
          by(induct A arbitrary: n)(simp_all add: drop_Cons split: nat.split_asm)
        ultimately show ?thesis by(subst upt_rec)(simp add: assoc_list_of_array_code.simps)
      qed
    qed }
  note this[of 0]
  with Array show ?thesis by simp
qed

lemma list_of_array_code [code]:
  "list_of_array a = array_foldr (\<lambda>n. Cons) a []"
by(cases a)(simp add: array_foldr_foldr foldr_Cons)

lemma array_foldr_cong [fundef_cong]:
  "\<lbrakk> a = a'; b = b';
    \<And>i b. i < array_length a \<Longrightarrow> f i (array_get a i) b = g i (array_get a i) b \<rbrakk>
  \<Longrightarrow> array_foldr f a b = array_foldr g a' b'"
by(cases a)(auto simp add: array_foldr_def set_zip intro!: foldr_cong)

lemma array_foldl_foldl:
  "array_foldl (\<lambda>n. f) b (Array a) = foldl f b a"
by(simp add: array_foldl_def foldl_snd_zip)

lemma array_map_conv_foldl_array_set:
  assumes len: "array_length A = array_length a"
  shows "array_map f a = foldl (\<lambda>A (k, v). array_set A k (f k v)) A (assoc_list_of_array a)"
proof(cases a)
  case (Array xs)
  obtain ys where [simp]: "A = Array ys" by(cases A)
  with Array len have "length xs \<le> length ys" by simp
  hence "foldr (\<lambda>x y. array_set y (fst x) (f (fst x) (snd x)))
               (rev (zip [0..<length xs] xs)) (Array ys) =
         Array (map (\<lambda>x. f (fst x) (snd x)) (zip [0..<length xs] xs) @ drop (length xs) ys)"
  proof(induct xs arbitrary: ys rule: rev_induct)
    case Nil thus ?case by simp
  next
    case (snoc x xs ys)
    from \<open>length (xs @ [x]) \<le> length ys\<close> have "length xs \<le> length ys" by simp
    hence "foldr (\<lambda>x y. array_set y (fst x) (f (fst x) (snd x)))
                 (rev (zip [0..<length xs] xs)) (Array ys) =
           Array (map (\<lambda>x. f (fst x) (snd x)) (zip [0..<length xs] xs) @ drop (length xs) ys)"
      by(rule snoc)
    moreover from \<open>length (xs @ [x]) \<le> length ys\<close>
    obtain y ys' where ys: "drop (length xs) ys = y # ys'"
      by(cases "drop (length xs) ys") auto
    moreover hence "drop (Suc (length xs)) ys = ys'" by(auto dest: drop_eq_ConsD)
    ultimately show ?case by(simp add: list_update_append)
  qed
  thus ?thesis using Array len
    by(simp add: array_map_def split_beta array_of_list_def foldl_conv_foldr)
qed

subsection \<open>Lemmas about empty arrays\<close>

lemma array_length_eq_0 [simp]:
  "array_length a = 0 \<longleftrightarrow> a = Array []"
by(cases a) simp

lemma new_array_0 [simp]: "new_array v 0 = Array []"
by(simp add: new_array_def)

lemma array_of_list_Nil [simp]:
  "array_of_list [] = Array []"
by(simp add: array_of_list_def)

lemma array_map_Nil [simp]:
  "array_map f (Array []) = Array []"
by(simp add: array_map_def)

lemma array_foldl_Nil [simp]:
  "array_foldl f b (Array []) = b"
by(simp add: array_foldl_def)

lemma array_foldr_Nil [simp]:
  "array_foldr f (Array []) b = b"
by(simp add: array_foldr_def)

lemma prod_foldl_conv:
  "(foldl f a xs, foldl g b xs) = foldl (\<lambda>(a, b) x. (f a x, g b x)) (a, b) xs"
by(induct xs arbitrary: a b) simp_all

lemma prod_array_foldl_conv:
  "(array_foldl f b a, array_foldl g c a) = array_foldl (\<lambda>h (b, c) v. (f h b v, g h c v)) (b, c) a"
by(cases a)(simp add: array_foldl_def foldl_map prod_foldl_conv split_def)

lemma array_foldl_array_foldr_comm:
  "comp_fun_commute (\<lambda>(h, v) b. f h b v) \<Longrightarrow> array_foldl f b a = array_foldr (\<lambda>h v b. f h b v) a b"
by(cases a)(simp add: array_foldl_def array_foldr_def split_def comp_fun_commute.foldr_conv_foldl)

lemma array_map_conv_array_foldl:
  "array_map f a = array_foldl (\<lambda>h a v. array_set a h (f h v)) a a"
proof(cases a)
  case (Array xs)
  define a where "a = xs"
  hence "length xs \<le> length a" by simp
  hence "foldl (\<lambda>a (k, v). array_set a k (f k v))
              (Array a) (zip [0..<length xs] xs)
         = Array (map (\<lambda>(k, v). f k v) (zip [0..<length xs] xs) @ drop (length xs) a)"
  proof(induct xs rule: rev_induct)
    case Nil thus ?case by simp
  next
    case (snoc x xs)
    have "foldl (\<lambda>a (k, v). array_set a k (f k v)) (Array a) (zip [0..<length (xs @ [x])] (xs @ [x])) =
          array_set (foldl (\<lambda>a (k, v). array_set a k (f k v)) (Array a) (zip [0..<length xs] xs))
                    (length xs) (f (length xs) x)" by simp
    also from \<open>length (xs @ [x]) \<le> length a\<close> have "length xs \<le> length a" by simp
    hence "foldl (\<lambda>a (k, v). array_set a k (f k v)) (Array a) (zip [0..<length xs] xs) =
           Array (map (\<lambda>(k, v). f k v) (zip [0..<length xs] xs) @ drop (length xs) a)" by(rule snoc)
    also note array_set.simps
    also have "(map (\<lambda>(k, v). f k v) (zip [0..<length xs] xs) @ drop (length xs) a) [length xs := f (length xs) x] =
              (map (\<lambda>(k, v). f k v) (zip [0..<length xs] xs) @ (drop (length xs) a) [0 := f (length xs) x])"
      by(simp add: list_update_append)
    also from \<open>length (xs @ [x]) \<le> length a\<close>
    have "(drop (length xs) a)[0 := f (length xs) x] =
          f (length xs) x # drop (Suc (length xs)) a"
      by(simp add: upd_conv_take_nth_drop)
    also have "map (\<lambda>(k, v). f k v) (zip [0..<length xs] xs) @ f (length xs) x # drop (Suc (length xs)) a =
             (map (\<lambda>(k, v). f k v) (zip [0..<length xs] xs) @ [f (length xs) x]) @ drop (Suc (length xs)) a" by simp
    also have "\<dots> = map (\<lambda>(k, v). f k v) (zip [0..<length (xs @ [x])] (xs @ [x])) @ drop (length (xs @ [x])) a"
      by(simp)
    finally show ?case .
  qed
  with a_def Array show ?thesis
    by(simp add: array_foldl_def array_map_def array_of_list_def)
qed

lemma array_foldl_new_array:
  "array_foldl f b (new_array a n) = foldl (\<lambda>b (k, v). f k b v) b (zip [0..<n] (replicate n a))"
  by(simp add: new_array_def array_foldl_def)

lemma array_list_of_set[simp]:
  "list_of_array (array_set a i x) = (list_of_array a) [i := x]"
  by (cases a) simp

lemma array_length_list: "array_length a = length (list_of_array a)"
  by (cases a) simp

subsection \<open>Parametricity lemmas\<close>

lemma rec_array_is_case[simp]: "rec_array = case_array"
  apply (intro ext)
  apply (auto split: array.split)
  done

definition array_rel_def_internal:
  "array_rel R \<equiv>
    {(Array xs, Array ys)|xs ys. (xs,ys) \<in> \<langle>R\<rangle>list_rel}"

lemma array_rel_def:
  "\<langle>R\<rangle>array_rel \<equiv> {(Array xs, Array ys)|xs ys. (xs,ys) \<in> \<langle>R\<rangle>list_rel}"
  unfolding array_rel_def_internal relAPP_def .

lemma array_relD:
  "(Array l, Array l') \<in> \<langle>R\<rangle>array_rel \<Longrightarrow> (l,l') \<in> \<langle>R\<rangle>list_rel"
  by (simp add: array_rel_def)

lemma array_rel_alt:
  "\<langle>R\<rangle>array_rel =
  { (Array l, l) | l. True }
  O \<langle>R\<rangle>list_rel
  O {(l,Array l) | l. True}"
  by (auto simp: array_rel_def)

lemma array_rel_sv[relator_props]:
  shows "single_valued R \<Longrightarrow> single_valued (\<langle>R\<rangle>array_rel)"
  unfolding array_rel_alt
  apply (intro relator_props )
  apply (auto intro: single_valuedI)
  done

lemma param_Array[param]:
  "(Array,Array) \<in> \<langle>R\<rangle> list_rel \<rightarrow> \<langle>R\<rangle> array_rel"
  apply (intro fun_relI)
  apply (simp add: array_rel_def)
  done

lemma param_rec_array[param]:
  "(rec_array,rec_array) \<in> (\<langle>Ra\<rangle>list_rel \<rightarrow> Rb) \<rightarrow> \<langle>Ra\<rangle>array_rel \<rightarrow> Rb"
  apply (intro fun_relI)
  apply (rename_tac f f' a a', case_tac a, case_tac a')
  apply (auto dest: fun_relD array_relD)
  done

lemma param_case_array[param]:
  "(case_array,case_array) \<in> (\<langle>Ra\<rangle>list_rel \<rightarrow> Rb) \<rightarrow> \<langle>Ra\<rangle>array_rel \<rightarrow> Rb"
  apply (clarsimp split: array.split)
  apply (drule array_relD)
  by parametricity

lemma param_case_array1':
  assumes "(a,a')\<in>\<langle>Ra\<rangle>array_rel"
  assumes "\<And>l l'. \<lbrakk> a=Array l; a'=Array l'; (l,l')\<in>\<langle>Ra\<rangle>list_rel \<rbrakk>
    \<Longrightarrow> (f l,f' l') \<in> Rb"
  shows "(case_array f a,case_array f' a') \<in> Rb"
  using assms
  apply (clarsimp split: array.split)
  apply (drule array_relD)
  apply parametricity
  by (rule refl)+

lemmas param_case_array2' = param_case_array1'[folded rec_array_is_case]

lemmas param_case_array' = param_case_array1' param_case_array2'

lemma param_array_length[param]:
    "(array_length,array_length) \<in> \<langle>Rb\<rangle>array_rel \<rightarrow> nat_rel"
  unfolding array_length_def
  by parametricity

lemma param_array_grow[param]:
  "(array_grow,array_grow) \<in> \<langle>R\<rangle>array_rel \<rightarrow> nat_rel \<rightarrow> R \<rightarrow> \<langle>R\<rangle>array_rel"
   unfolding array_grow_def by parametricity

lemma array_rel_imp_same_length:
  "(a, a') \<in> \<langle>R\<rangle>array_rel \<Longrightarrow> array_length a = array_length a'"
  apply (cases a, cases a')
  apply (auto simp add: list_rel_imp_same_length dest!: array_relD)
  done

lemma param_array_get[param]:
  assumes I: "i<array_length a"
  assumes IR: "(i,i')\<in>nat_rel"
  assumes AR: "(a,a')\<in>\<langle>R\<rangle>array_rel"
  shows "(array_get a i, array_get a' i') \<in> R"
proof -
  obtain l l' where [simp]: "a = Array l" "a' = Array l'"
      by (cases a, cases a', simp_all)
  from AR have LR: "(l,l') \<in> \<langle>R\<rangle>list_rel" by (force dest!: array_relD)
  thus ?thesis using assms
    unfolding array_get_def
    apply (auto intro!: param_nth[param_fo] dest: list_rel_imp_same_length)
    done
qed

lemma param_array_set[param]:
  "(array_set,array_set)\<in>\<langle>R\<rangle>array_rel\<rightarrow>nat_rel\<rightarrow>R\<rightarrow>\<langle>R\<rangle>array_rel"
  unfolding array_set_def by parametricity

lemma param_array_of_list[param]:
  "(array_of_list, array_of_list) \<in> \<langle>R\<rangle> list_rel \<rightarrow> \<langle>R\<rangle> array_rel"
  unfolding array_of_list_def by parametricity

lemma param_array_shrink[param]:
  assumes N: "array_length a \<ge> n"
  assumes NR: "(n,n')\<in>nat_rel"
  assumes AR: "(a,a')\<in>\<langle>R\<rangle>array_rel"
  shows "(array_shrink a n, array_shrink a' n') \<in> \<langle>R\<rangle> array_rel"
proof-
  obtain l l' where [simp]: "a = Array l" "a' = Array l'"
      by (cases a, cases a', simp_all)
  from AR have LR: "(l,l') \<in> \<langle>R\<rangle>list_rel"
    by (auto dest: array_relD)
  with assms show ?thesis by (auto intro:
      param_Array[param_fo] param_take[param_fo]
      dest: array_rel_imp_same_length
    )
qed

lemma param_assoc_list_of_array[param]:
  "(assoc_list_of_array, assoc_list_of_array) \<in>
       \<langle>R\<rangle> array_rel \<rightarrow> \<langle>\<langle>nat_rel,R\<rangle>prod_rel\<rangle>list_rel"
  unfolding assoc_list_of_array_def[abs_def] by parametricity

lemma param_array_map[param]:
  "(array_map, array_map) \<in>
       (nat_rel \<rightarrow> Ra \<rightarrow> Rb) \<rightarrow> \<langle>Ra\<rangle>array_rel \<rightarrow> \<langle>Rb\<rangle>array_rel"
  unfolding array_map_def[abs_def] by parametricity

lemma param_array_foldr[param]:
  "(array_foldr, array_foldr) \<in>
       (nat_rel \<rightarrow> Ra \<rightarrow> Rb \<rightarrow> Rb) \<rightarrow> \<langle>Ra\<rangle>array_rel \<rightarrow> Rb \<rightarrow> Rb"
  unfolding array_foldr_def[abs_def] by parametricity

lemma param_array_foldl[param]:
  "(array_foldl, array_foldl) \<in>
       (nat_rel \<rightarrow> Rb \<rightarrow> Ra \<rightarrow> Rb) \<rightarrow> Rb \<rightarrow> \<langle>Ra\<rangle>array_rel \<rightarrow> Rb"
  unfolding array_foldl_def[abs_def] by parametricity

subsection \<open>Code Generator Setup\<close>

subsubsection \<open>Code-Numeral Preparation\<close>

definition [code del]: "new_array' v == new_array v o nat_of_integer"
definition [code del]: "array_length' == integer_of_nat o array_length"
definition [code del]: "array_get' a == array_get a o nat_of_integer"
definition [code del]: "array_set' a == array_set a o nat_of_integer"
definition [code del]: "array_grow' a == array_grow a o nat_of_integer"
definition [code del]: "array_shrink' a == array_shrink a o nat_of_integer"
definition [code del]:
  "array_get_oo' x a == array_get_oo x a o nat_of_integer"
definition [code del]:
  "array_set_oo' f a == array_set_oo f a o nat_of_integer"

text \<open>Fallbacks\<close>
lemmas [code] = array_get_oo'_def[unfolded array_get_oo_def[abs_def]]
lemmas [code] = array_set_oo'_def[unfolded array_set_oo_def[abs_def]]

subsubsection \<open>Code generator setup for Haskell\<close>

code_printing type_constructor array \<rightharpoonup>
  (Haskell) "Array.ArrayType/ _"

code_reserved Haskell array_of_list

(*
code_printing code_module "Array" \<rightharpoonup>
  (Haskell) {*
--import qualified Data.Array.Diff as Arr;
import qualified Data.Array as Arr;
import Data.Array.IArray;
import Nat;

instance Ix Nat where {
    range (Nat a, Nat b) = map Nat (range (a, b));
    index (Nat a, Nat b) (Nat c) = index (a,b) c;
    inRange (Nat a, Nat b) (Nat c) = inRange (a, b) c;
    rangeSize (Nat a, Nat b) = rangeSize (a, b);
};

type ArrayType = Arr.DiffArray Nat;
--type ArrayType = Arr.Array Nat;

-- we need to start at 1 and not 0, because the empty array
-- is modelled by having s > e for (s,e) = bounds
-- and as we are in Nat, 0 is the smallest number

array_of_size :: Nat -> [e] -> ArrayType e;
array_of_size n = Arr.listArray (1, n);

new_array :: e -> Nat -> ArrayType e;
new_array a n = array_of_size n (repeat a);

array_length :: ArrayType e -> Nat;
array_length a = let (s, e) = bounds a in if s > e then 0 else e - s + 1;
-- the `if` is actually needed, because in Nat we have s > e --> e - s + 1 = 1

array_get :: ArrayType e -> Nat -> e;
array_get a i = a ! (i + 1);

array_set :: ArrayType e -> Nat -> e -> ArrayType e;
array_set a i e = a // [(i + 1, e)];

array_of_list :: [e] -> ArrayType e;
array_of_list xs = array_of_size (fromInteger (toInteger (length xs - 1))) xs;

array_grow :: ArrayType e -> Nat -> e -> ArrayType e;
array_grow a i x = let (s, e) = bounds a in Arr.listArray (s, e+i) (Arr.elems a ++ repeat x);

array_shrink :: ArrayType e -> Nat -> ArrayType e;
array_shrink a sz = if sz > array_length a then undefined else array_of_size sz (Arr.elems a);
*}
*)

(* TODO/FIXME: Using standard functional arrays here, as DiffArray seems
  to be discontinued in Haskell! *)
code_printing code_module "Array" \<rightharpoonup>
  (Haskell) \<open>module Array where {

--import qualified Data.Array.Diff as Arr;
import qualified Data.Array as Arr;

type ArrayType = Arr.Array Integer;

array_of_size :: Integer -> [e] -> ArrayType e;
array_of_size n = Arr.listArray (0, n-1);

new_array :: e -> Integer -> ArrayType e;
new_array a n = array_of_size n (repeat a);

array_length :: ArrayType e -> Integer;
array_length a = let (s, e) = Arr.bounds a in e;

array_get :: ArrayType e -> Integer -> e;
array_get a i = a Arr.! i;

array_set :: ArrayType e -> Integer -> e -> ArrayType e;
array_set a i e = a Arr.// [(i, e)];

array_of_list :: [e] -> ArrayType e;
array_of_list xs = array_of_size (toInteger (length xs)) xs;

array_grow :: ArrayType e -> Integer -> e -> ArrayType e;
array_grow a i x = let (s, e) = Arr.bounds a in Arr.listArray (s, e+i) (Arr.elems a ++ repeat x);

array_shrink :: ArrayType e -> Integer -> ArrayType e;
array_shrink a sz = if sz > array_length a then undefined else array_of_size sz (Arr.elems a);
}\<close>

code_printing constant Array \<rightharpoonup> (Haskell) "Array.array'_of'_list"
code_printing constant new_array' \<rightharpoonup> (Haskell) "Array.new'_array"
code_printing constant array_length' \<rightharpoonup> (Haskell) "Array.array'_length"
code_printing constant array_get' \<rightharpoonup> (Haskell) "Array.array'_get"
code_printing constant array_set' \<rightharpoonup> (Haskell) "Array.array'_set"
code_printing constant array_of_list \<rightharpoonup> (Haskell) "Array.array'_of'_list"
code_printing constant array_grow' \<rightharpoonup> (Haskell) "Array.array'_grow"
code_printing constant array_shrink' \<rightharpoonup> (Haskell) "Array.array'_shrink"

subsubsection \<open>Code Generator Setup For SML\<close>

text \<open>
  We have the choice between single-threaded arrays, that raise an exception if an old version is accessed,
  and truly functional arrays, that update the array in place, but store undo-information to restore
  old versions.
\<close>

code_printing code_module "STArray" \<rightharpoonup>
  (SML)
\<open>
structure STArray = struct

datatype 'a Cell = Invalid | Value of 'a array;

exception AccessedOldVersion;

type 'a array = 'a Cell Unsynchronized.ref;

fun fromList l = Unsynchronized.ref (Value (Array.fromList l));
fun array (size, v) = Unsynchronized.ref (Value (Array.array (size,v)));
fun tabulate (size, f) = Unsynchronized.ref (Value (Array.tabulate(size, f)));
fun sub (Unsynchronized.ref Invalid, idx) = raise AccessedOldVersion |
    sub (Unsynchronized.ref (Value a), idx) = Array.sub (a,idx);
fun update (aref,idx,v) =
  case aref of
    (Unsynchronized.ref Invalid) => raise AccessedOldVersion |
    (Unsynchronized.ref (Value a)) => (
      aref := Invalid;
      Array.update (a,idx,v);
      Unsynchronized.ref (Value a)
    );

fun length (Unsynchronized.ref Invalid) = raise AccessedOldVersion |
    length (Unsynchronized.ref (Value a)) = Array.length a

fun grow (aref, i, x) = case aref of
  (Unsynchronized.ref Invalid) => raise AccessedOldVersion |
  (Unsynchronized.ref (Value a)) => (
    let val len=Array.length a;
        val na = Array.array (len+i,x)
    in
      aref := Invalid;
      Array.copy {src=a, dst=na, di=0};
      Unsynchronized.ref (Value na)
    end
    );

fun shrink (aref, sz) = case aref of
  (Unsynchronized.ref Invalid) => raise AccessedOldVersion |
  (Unsynchronized.ref (Value a)) => (
    if sz > Array.length a then
      raise Size
    else (
      aref:=Invalid;
      Unsynchronized.ref (Value (Array.tabulate (sz,fn i => Array.sub (a,i))))
    )
  );

structure IsabelleMapping = struct
type 'a ArrayType = 'a array;

fun new_array (a:'a) (n:IntInf.int) = array (IntInf.toInt n, a);

fun array_length (a:'a ArrayType) = IntInf.fromInt (length a);

fun array_get (a:'a ArrayType) (i:IntInf.int) = sub (a, IntInf.toInt i);

fun array_set (a:'a ArrayType) (i:IntInf.int) (e:'a) = update (a, IntInf.toInt i, e);

fun array_of_list (xs:'a list) = fromList xs;

fun array_grow (a:'a ArrayType) (i:IntInf.int) (x:'a) = grow (a, IntInf.toInt i, x);

fun array_shrink (a:'a ArrayType) (sz:IntInf.int) = shrink (a,IntInf.toInt sz);

end;

end;

structure FArray = struct
  datatype 'a Cell = Value of 'a Array.array | Upd of (int*'a*'a Cell Unsynchronized.ref);

  type 'a array = 'a Cell Unsynchronized.ref;

  fun array (size,v) = Unsynchronized.ref (Value (Array.array (size,v)));
  fun tabulate (size, f) = Unsynchronized.ref (Value (Array.tabulate(size, f)));
  fun fromList l = Unsynchronized.ref (Value (Array.fromList l));

  fun sub (Unsynchronized.ref (Value a), idx) = Array.sub (a,idx) |
      sub (Unsynchronized.ref (Upd (i,v,cr)),idx) =
        if i=idx then v
        else sub (cr,idx);

  fun length (Unsynchronized.ref (Value a)) = Array.length a |
      length (Unsynchronized.ref (Upd (i,v,cr))) = length cr;

  fun realize_aux (aref, v) =
    case aref of
      (Unsynchronized.ref (Value a)) => (
        let
          val len = Array.length a;
          val a' = Array.array (len,v);
        in
          Array.copy {src=a, dst=a', di=0};
          Unsynchronized.ref (Value a')
        end
      ) |
      (Unsynchronized.ref (Upd (i,v,cr))) => (
        let val res=realize_aux (cr,v) in
          case res of
            (Unsynchronized.ref (Value a)) => (Array.update (a,i,v); res)
        end
      );

  fun realize aref =
    case aref of
      (Unsynchronized.ref (Value _)) => aref |
      (Unsynchronized.ref (Upd (i,v,cr))) => realize_aux(aref,v);

  fun update (aref,idx,v) =
    case aref of
      (Unsynchronized.ref (Value a)) => (
        let val nref=Unsynchronized.ref (Value a) in
          aref := Upd (idx,Array.sub(a,idx),nref);
          Array.update (a,idx,v);
          nref
        end
      ) |
      (Unsynchronized.ref (Upd _)) =>
        let val ra = realize_aux(aref,v) in
          case ra of
            (Unsynchronized.ref (Value a)) => Array.update (a,idx,v);
          ra
        end
      ;

  fun grow (aref, inc, x) = case aref of
    (Unsynchronized.ref (Value a)) => (
      let val len=Array.length a;
          val na = Array.array (len+inc,x)
      in
        Array.copy {src=a, dst=na, di=0};
        Unsynchronized.ref (Value na)
      end
      )
  | (Unsynchronized.ref (Upd _)) => (
    grow (realize aref, inc, x)
  );

  fun shrink (aref, sz) = case aref of
    (Unsynchronized.ref (Value a)) => (
      if sz > Array.length a then
        raise Size
      else (
        Unsynchronized.ref (Value (Array.tabulate (sz,fn i => Array.sub (a,i))))
      )
    ) |
    (Unsynchronized.ref (Upd _)) => (
      shrink (realize aref,sz)
    );

structure IsabelleMapping = struct
type 'a ArrayType = 'a array;

fun new_array (a:'a) (n:IntInf.int) = array (IntInf.toInt n, a);

fun array_length (a:'a ArrayType) = IntInf.fromInt (length a);

fun array_get (a:'a ArrayType) (i:IntInf.int) = sub (a, IntInf.toInt i);

fun array_set (a:'a ArrayType) (i:IntInf.int) (e:'a) = update (a, IntInf.toInt i, e);

fun array_of_list (xs:'a list) = fromList xs;

fun array_grow (a:'a ArrayType) (i:IntInf.int) (x:'a) = grow (a, IntInf.toInt i, x);

fun array_shrink (a:'a ArrayType) (sz:IntInf.int) = shrink (a,IntInf.toInt sz);

fun array_get_oo (d:'a) (a:'a ArrayType) (i:IntInf.int) =
  sub (a,IntInf.toInt i) handle Subscript => d

fun array_set_oo (d:(unit->'a ArrayType)) (a:'a ArrayType) (i:IntInf.int) (e:'a) =
  update (a, IntInf.toInt i, e) handle Subscript => d ()

end;
end;

\<close>

code_printing
  type_constructor array \<rightharpoonup> (SML) "_/ FArray.IsabelleMapping.ArrayType"
| constant Array \<rightharpoonup> (SML) "FArray.IsabelleMapping.array'_of'_list"
| constant new_array' \<rightharpoonup> (SML) "FArray.IsabelleMapping.new'_array"
| constant array_length' \<rightharpoonup> (SML) "FArray.IsabelleMapping.array'_length"
| constant array_get' \<rightharpoonup> (SML) "FArray.IsabelleMapping.array'_get"
| constant array_set' \<rightharpoonup> (SML) "FArray.IsabelleMapping.array'_set"
| constant array_grow' \<rightharpoonup> (SML) "FArray.IsabelleMapping.array'_grow"
| constant array_shrink' \<rightharpoonup> (SML) "FArray.IsabelleMapping.array'_shrink"
| constant array_of_list \<rightharpoonup> (SML) "FArray.IsabelleMapping.array'_of'_list"
| constant array_get_oo' \<rightharpoonup> (SML) "FArray.IsabelleMapping.array'_get'_oo"
| constant array_set_oo' \<rightharpoonup> (SML) "FArray.IsabelleMapping.array'_set'_oo"

subsection \<open>Code Generator Setup for Scala\<close>
text \<open>
  We use a DiffArray-Implementation in Scala.
\<close>
code_printing code_module "DiffArray" \<rightharpoonup>
  (Scala) \<open>
object DiffArray {

  import scala.collection.mutable.ArraySeq

  protected abstract sealed class DiffArray_D[A]
  final case class Current[A] (a:ArraySeq[A]) extends DiffArray_D[A]
  final case class Upd[A] (i:Int, v:A, n:DiffArray_D[A]) extends DiffArray_D[A]

  object DiffArray_Realizer {
    def realize[A](a:DiffArray_D[A]) : ArraySeq[A] = a match {
      case Current(a) => ArraySeq.empty ++ a
      case Upd(j,v,n) => {val a = realize(n); a.update(j, v); a}
    }
  }

  class T[A] (var d:DiffArray_D[A]) {

    def realize () = { val a=DiffArray_Realizer.realize(d); d = Current(a); a }
    override def toString() = realize().toSeq.toString

    override def equals(obj:Any) =
      if (obj.isInstanceOf[T[A]]) obj.asInstanceOf[T[A]].realize().equals(realize())
      else false

  }

  def array_of_list[A](l : List[A]) : T[A] = new T(Current(ArraySeq.empty ++ l))
    def new_array[A](v:A, sz : BigInt) = new T[A](Current[A](ArraySeq.fill[A](sz.intValue)(v)))

    private def length[A](a:DiffArray_D[A]) : BigInt = a match {
    case Current(a) => a.length
    case Upd(_,_,n) => length(n)
  }

  def length[A](a : T[A]) : BigInt = length(a.d)

  private def sub[A](a:DiffArray_D[A], i:Int) : A = a match {
    case Current(a) => a (i)
    case Upd(j,v,n) => if (i==j) v else sub(n,i)
  }

  def get[A](a:T[A], i:BigInt) : A = sub(a.d,i.intValue)

  private def realize[A](a:DiffArray_D[A]) = DiffArray_Realizer.realize[A](a)

  def set[A](a:T[A], i:BigInt,v:A) : T[A] = a.d match {
    case Current(ad) => {
      val ii = i.intValue;
      a.d = Upd(ii,ad(ii),a.d);
      //ad.update(ii,v);
      ad(ii)=v
      new T[A](Current(ad))
    }
    case Upd(_,_,_) => set(new T[A](Current(realize(a.d))), i.intValue,v)
  }

  def grow[A](a:T[A], sz:BigInt, v:A) : T[A] = a.d match {
    case Current(ad) => {
      val adt = ArraySeq.fill[A](sz.intValue)(v)
      System.arraycopy(ad.array, 0, adt.array, 0, ad.length);
      new T[A](Current[A](adt))
    }
    case Upd (_,_,_) =>  {
      val adt = ArraySeq.fill[A](sz.intValue)(v)
      val ad = realize(a.d)
      System.arraycopy(ad.array, 0, adt.array, 0, ad.length);
      new T[A](Current[A](adt))
    }
  }

  def shrink[A](a:T[A], sz:BigInt) : T[A] =
    if (sz==0) {
      array_of_list(Nil)
    } else {
      a.d match {
        case Current(ad) => {
            val v=ad(0);
            val szz=sz.intValue
          val adt = ArraySeq.fill[A](szz)(v);
          System.arraycopy(ad.array, 0, adt.array, 0, szz);
          new T[A](Current[A](adt))
        }
        case Upd (_,_,_) =>  {
          val ad = realize(a.d);
            val szz=sz.intValue
            val v=ad(0);
          val adt = ArraySeq.fill[A](szz)(v);
          System.arraycopy(ad.array, 0, adt.array, 0, szz);
          new T[A](Current[A](adt))
        }
      }
    }

  def get_oo[A](d: => A, a:T[A], i:BigInt):A = try get(a,i) catch {
    case _:scala.IndexOutOfBoundsException => d
  }

  def set_oo[A](d: Unit => T[A], a:T[A], i:BigInt, v:A) : T[A] = try set(a,i,v) catch {
    case _:scala.IndexOutOfBoundsException => d ()
  }

}

/*
object Test {

  def assert (b : Boolean) : Unit = if (b) () else throw new java.lang.AssertionError("Assertion Failed")

  def eql[A] (a:DiffArray.T[A], b:List[A]) = assert (a.realize.corresponds(b)((x,y) => x.equals(y)))

  def tests1(): Unit = {
    val a = DiffArray.array_of_list(1::2::3::4::Nil)
      eql(a,1::2::3::4::Nil)

    // Simple update
    val b = DiffArray.set(a,2,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)

    // Another update
    val c = DiffArray.set(b,3,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::9::9::Nil)

    // Update of old version (forces realize)
    val d = DiffArray.set(b,2,8)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::9::9::Nil)
      eql(d,1::2::8::4::Nil)

    }

  def tests2(): Unit = {
    val a = DiffArray.array_of_list(1::2::3::4::Nil)
      eql(a,1::2::3::4::Nil)

    // Simple update
    val b = DiffArray.set(a,2,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)

    // Grow of current version
    val c = DiffArray.grow(b,6,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::9::4::9::9::Nil)

    // Grow of old version
    val d = DiffArray.grow(a,6,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::9::4::9::9::Nil)
      eql(d,1::2::3::4::9::9::Nil)

  }

  def tests3(): Unit = {
    val a = DiffArray.array_of_list(1::2::3::4::Nil)
      eql(a,1::2::3::4::Nil)

    // Simple update
    val b = DiffArray.set(a,2,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)

    // Shrink of current version
    val c = DiffArray.shrink(b,3)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::9::Nil)

    // Shrink of old version
    val d = DiffArray.shrink(a,3)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::9::Nil)
      eql(d,1::2::3::Nil)

  }

  def tests4(): Unit = {
    val a = DiffArray.array_of_list(1::2::3::4::Nil)
      eql(a,1::2::3::4::Nil)

    // Update _oo (succeeds)
    val b = DiffArray.set_oo((_) => a,a,2,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)

    // Update _oo (current version,fails)
    val c = DiffArray.set_oo((_) => a,b,5,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::3::4::Nil)

    // Update _oo (old version,fails)
    val d = DiffArray.set_oo((_) => b,a,5,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)
      eql(c,1::2::3::4::Nil)
      eql(d,1::2::9::4::Nil)

  }

  def tests5(): Unit = {
    val a = DiffArray.array_of_list(1::2::3::4::Nil)
      eql(a,1::2::3::4::Nil)

    // Update
    val b = DiffArray.set(a,2,9)
      eql(a,1::2::3::4::Nil)
      eql(b,1::2::9::4::Nil)

    // Get_oo (current version, succeeds)
      assert (DiffArray.get_oo(0,b,2)==9)
    // Get_oo (current version, fails)
      assert (DiffArray.get_oo(0,b,5)==0)
    // Get_oo (old version, succeeds)
      assert (DiffArray.get_oo(0,a,2)==3)
    // Get_oo (old version, fails)
      assert (DiffArray.get_oo(0,a,5)==0)

  }

  def main(args: Array[String]): Unit = {
    tests1 ()
    tests2 ()
    tests3 ()
    tests4 ()
    tests5 ()

    Console.println("Tests passed")
  }

}*/

\<close>

code_printing
  type_constructor array \<rightharpoonup> (Scala) "DiffArray.T[_]"
| constant Array \<rightharpoonup> (Scala) "DiffArray.array'_of'_list"
| constant new_array' \<rightharpoonup> (Scala) "DiffArray.new'_array((_),(_).toInt)"
| constant array_length' \<rightharpoonup> (Scala) "DiffArray.length((_)).toInt"
| constant array_get' \<rightharpoonup> (Scala) "DiffArray.get((_),(_).toInt)"
| constant array_set' \<rightharpoonup> (Scala) "DiffArray.set((_),(_).toInt,(_))"
| constant array_grow' \<rightharpoonup> (Scala) "DiffArray.grow((_),(_).toInt,(_))"
| constant array_shrink' \<rightharpoonup> (Scala) "DiffArray.shrink((_),(_).toInt)"
| constant array_of_list \<rightharpoonup> (Scala) "DiffArray.array'_of'_list"
| constant array_get_oo' \<rightharpoonup> (Scala) "DiffArray.get'_oo((_),(_),(_).toInt)"
| constant array_set_oo' \<rightharpoonup> (Scala) "DiffArray.set'_oo((_),(_),(_).toInt,(_))"

context begin
(*private*) definition "test_diffarray_setup \<equiv> (Array,new_array',array_length',array_get', array_set', array_grow', array_shrink',array_of_list,array_get_oo',array_set_oo')"
export_code test_diffarray_setup checking Scala SML OCaml? Haskell?
end

end


theory testI
imports Main
        "$HIPSTER_HOME/IsaHipster"

begin

ML \<open>
   fun infer_term x ctxt =
     let val (T, ctxt') = Proof_Context.inferred_param x ctxt
     in (Free (x, T), ctxt') end;

   fun induct_tac ctxt xss rule thm =
     let
       val (tss, ctxt') = (fold_map o fold_map) infer_term xss ctxt;
       val instss = map (map (fn inst => SOME (NONE, (inst, false)))) tss;
       val ress = Seq.DETERM (HEADGOAL(Induction.induction_tac ctxt' false instss [] [] (SOME rule) [])) thm;
       val ab = Seq.map snd ress
       val tt = Seq.chop 3 ress
       val _ = @{print} (Seq.list_of ress)
     in ab end;
NO_CASES
\<close>

datatype 'a T1 = A1 "'a T2" | B1
   and 'a T2 = A2 "'a T1"

fun foo1 and foo2 where
   "foo1 (A1 a) = foo2 a"
| "foo1 a = a"
| "foo2 (A2 b) = foo1 b"

lemma
   "foo1 (a::'a T1) = B1"
   "foo2 (b::'a T2) = B1"
   apply (induct a and b rule: foo1_foo2.induct)
     apply simp_all
   done

lemma
   "foo1 (a::'a T1) = B1"
   "foo2 (b::'a T2) = B1"
   apply (raw_tactic \<open>induct_tac @{context} [["a"], ["b"]] @{thms foo1_foo2.induct}\<close>)
     apply simp_all
   done

end


theory Reduction
imports HOModel "../Stuttering_Equivalence/StutterEquivalence"
begin

section {* Reduction Theorem *}

text {*
  We have defined the semantics of HO algorithms such that rounds are executed
  atomically, by all processes. This definition is surprising for a model of
  asynchronous distributed algorithms since it models a synchronous execution
  of rounds. However, it simplifies representing and reasoning about the algorithms.
  For example, the communication network does not have to be modeled explicitly,
  since the possible sets of messages received by processes can be computed
  from the global configuration and the collections of HO and SHO sets.

  We will now define a more conventional ``fine-grained'' semantics where
  communication is modeled explicitly and rounds of processes can be arbitrarily
  interleaved (subject to the constraints of the communication predicates).
  We will then establish a \emph{reduction theorem} that shows that for every
  fine-grained run there exists an equivalent round-based (``coarse-grained'')
  run in the sense that the two runs exhibit the same sequences of local states
  of all processes, modulo stuttering. We prove the reduction theorem for the
  most general class of coordinated SHO algorithms. It is easy to see that the
  theorem equally holds for the special cases of uncoordinated or HO algorithms,
  and since we have in fact defined these classes of algorithms from the more
  general ones, we can directly apply the general theorem.

  As a corollary, interesting properties remain valid in the fine-grained semantics
  if they hold in the coarse-grained semantics. It is therefore enough to
  verify such properties in the coarse-grained semantics, which is much easier
  to reason about. The essential restriction is that properties may not depend
  on states of different processes occurring simultaneously. (For example, the
  coarse-grained semantics ensures by definition that all processes execute the
  same round at any instant, which is obviously not true of the fine-grained
  semantics.) We claim that all ``reasonable'' properties of fault-tolerant
  distributed algorithms are preserved by our reduction. For example, the
  Consensus (and Weak Consensus) problems fall into this class.

  The proofs follow Chaouch-Saad et al.~\cite{saad:reduction}, where the
  reduction theorem was proved for uncoordinated HO algorithms.
*}

subsection {* Fine-Grained Semantics *}

text {*
  In the fine-grained semantics, a run of an HO algorithm is represented
  as an $\omega$-sequence of system configurations. Each configuration
  is represented as a record carrying the following information:
  \begin{itemize}
  \item for every process $p$, the current round that process $p$ is executing,
  \item the local state of every process,
  \item for every process $p$, the set of processes to which $p$ has already
    sent a message for the current round,
  \item for all processes $p$ and $q$, the message (if any) that $p$ has
    received from $q$ for the round that $p$ is currently executing, and
  \item the set of messages in transit, represented as triples of the form
    $(p,r,q,m)$ meaning that process $p$ sent message $m$ to process $q$
    for round $r$, but $q$ has not yet received that message.
  \end{itemize}

  As explained earlier, the coordinators of processes are not recorded in
  the configuration, but algorithms may record them as part of the process states.
*}

record ('pst, 'proc, 'msg) config =
  round :: "'proc \<Rightarrow> nat"
  state :: "'proc \<Rightarrow> 'pst"
  sent  :: "'proc \<Rightarrow> 'proc set"
  rcvd  :: "'proc \<Rightarrow> 'proc \<Rightarrow> 'msg option"
  network :: " ('proc * nat * 'proc * 'msg) set"

type_synonym ('pst ,'proc , 'msg) fgrun = "nat \<Rightarrow> ('pst, 'proc, 'msg) config"

text {*
  In an initial configuration for an algorithm, the local state of every process
  satisfies the algorithm's initial-state predicate, and all other components
  have obvious default values.
*}

definition fg_init_config where
  "fg_init_config A (config::('pst,'proc, 'msg) config) (coord::'proc coord) \<equiv>
     round config = (\<lambda>p. 0)
   \<and> (\<forall>p. CinitState A p (state config p) (coord p))
   \<and> sent config = (\<lambda>p. {})
   \<and> rcvd config = (\<lambda>p q. None)
   \<and> network config = {}"

text {*
  In the fine-grained semantics, we have three types of transitions due to
  \begin{itemize}
  \item some process sending a message,
  \item some process receiving a message, and
  \item some process executing a local transition.
  \end{itemize}

  The following definition models process @{text p} sending a message to
  process @{text q}. The transition is enabled if @{text p} has not yet
  sent any message to @{text q} for the current round. The message to be
  sent is computed according to the algorithm's @{text sendMsg} function.
  The effect of the transition is to add @{text q} to the @{text sent}
  component of the configuration and the message quadruple to the
  @{text network} component.
*}

definition fg_send_msg where
  "fg_send_msg A p q config config' \<equiv>
     q \<notin> (sent config p)
   \<and> config' = config \<lparr>
        sent := (sent config)(p := (sent config p) \<union> {q}),
        network := network config \<union>
                   {(p, round config p, q,
                     sendMsg A (round config p) p q (state config p))} \<rparr>"

text {*
  The following definition models the reception of a message by process
  @{text p} from process @{text q}. The action is enabled if @{text q}
  is in the heard-of set @{text HO} of process @{text p} for the current
  round, and if the network contains some message from @{text q} to
  @{text p} for the round that @{text p} is currently executing.
  W.l.o.g., we model message corruption at reception: if @{text q} is not
  in @{text p}'s SHO set (parameter @{text SHO}), then an arbitrary value
  @{text m'} is received instead of @{text m}.
*}

definition fg_rcv_msg where
  "fg_rcv_msg p q HO SHO config config' \<equiv>
   \<exists>m m'. (q, (round config p), p, m) \<in> network config
     \<and> q \<in> HO
     \<and> config' = config \<lparr>
          rcvd := (rcvd config)(p := (rcvd config p)(q :=
                    if q \<in> SHO then Some m else Some m')),
          network := network config - {(q, (round config p), p, m)} \<rparr>"

text {*
  Finally, we consider local state transition of process @{text p}.
  A local transition is enabled only after @{text p} has sent all messages
  for its current round and has received all messages that it is supposed
  to receive according to its current HO set (parameter @{text HO}). The
  local state is updated according to the algorithm's @{text CnextState}
  relation, which may depend on the coordinator @{text crd} of the following
  round. The round of process @{text p} is incremented, and the
  @{text sent} and @{text rcvd} components for process @{text p} are
  reset to initial values for the new round.
*}

definition fg_local where
  "fg_local A p HO crd config config' \<equiv>
     sent config p = UNIV
   \<and> dom (rcvd config p) = HO
   \<and> (\<exists>s. CnextState A (round config p) p (state config p) (rcvd config p) crd s
        \<and> config' = config \<lparr>
             round := (round config)(p := Suc (round config p)),
             state := (state config)(p := s),
             sent := (sent config)(p := {}),
             rcvd := (rcvd config)(p := \<lambda>q. None) \<rparr>)"

text {*
  The next-state relation for process @{text p} is just the disjunction of
  the above three types of transitions.
*}

definition fg_next_config where
  "fg_next_config A p HO SHO crd config config' \<equiv>
     (\<exists>q. fg_send_msg A p q config config')
   \<or> (\<exists>q. fg_rcv_msg p q HO SHO config config')
   \<or> fg_local A p HO crd config config'"

text {*
  Fine-grained runs are infinite sequences of configurations that start
  in an initial configuration and where each step corresponds to some process
  sending a message, receiving a message or performing a local step. We also
  require that every process eventually executes every round -- note that
  this condition is implicit in the definition of coarse-grained runs.
*}

definition fg_run where
  "fg_run A rho HOs SHOs coords \<equiv>
      fg_init_config A (rho 0) (coords 0)
    \<and> (\<forall>i. \<exists>p. fg_next_config A p
                                    (HOs (round (rho i) p) p)
                                    (SHOs (round (rho i) p) p)
                                    (coords (round (rho (Suc i)) p) p)
                                    (rho i) (rho (Suc i)))
    \<and> (\<forall>p r. \<exists>n. round (rho n) p = r)"

text {*
  The following function computes at which ``time point'' (index in the
  fine-grained computation) process @{text p} starts executing round
  @{text r}. This function plays an important role in the correspondence
  between the two semantics, and in the subsequent proofs.
*}

definition fg_start_round where
  "fg_start_round rho p r \<equiv> LEAST (n::nat). round (rho n) p = r"

subsection {* Properties of the Fine-Grained Semantics *}

text {*
  In preparation for the proof of the reduction theorem, we establish a
  number of consequences of the above definitions.
*}

text {*
  Process states change only when round numbers change during a
  fine-grained run.
*}
lemma fg_state_change:
  assumes rho: "fg_run A rho HOs SHOs coords"
      and rd: "round (rho (Suc n)) p = round (rho n) p"
  shows "state (rho (Suc n)) p = state (rho n) p"
proof -
  from rho have "\<exists>p'. fg_next_config A p' (HOs (round (rho n) p') p')
                                          (SHOs (round (rho n) p') p')
                                          (coords (round (rho (Suc n)) p') p')
                                          (rho n) (rho (Suc n))"
    by (auto simp: fg_run_def)
  with rd show ?thesis
    by (auto simp: fg_next_config_def fg_send_msg_def fg_rcv_msg_def fg_local_def)
qed

text {*
  Round numbers never decrease.
*}
lemma fg_round_numbers_increase:
  assumes rho: "fg_run A rho HOs SHOs coords" and n: "n \<le> m"
  shows "round (rho n) p \<le> round (rho m) p"
proof -
  from n obtain k where k: "m = n+k" by (auto simp: le_iff_add)
  {
    fix i
    have "round (rho n) p \<le> round (rho (n+i)) p" (is "?P i")
    proof (induct i)
      show "?P 0" by simp
    next
      fix j
      assume ih: "?P j"
      from rho have "\<exists>p'. fg_next_config A p' (HOs (round (rho (n+j)) p') p')
                                              (SHOs (round (rho (n+j)) p') p')
                                              (coords (round (rho (Suc (n+j))) p') p')
                                              (rho (n+j)) (rho (Suc (n+j)))"
        by (auto simp: fg_run_def)
      hence "round (rho (n+j)) p \<le> round (rho (n + Suc j)) p"
        by (auto simp: fg_next_config_def fg_send_msg_def fg_rcv_msg_def fg_local_def)
      with ih show "?P (Suc j)" by auto
    qed
  }
  with k show ?thesis by simp
qed

text {*
  Combining the two preceding lemmas, it follows that the local states
  of process @{text p} at two configurations are the same if these
  configurations have the same round number.
*}
lemma fg_same_round_same_state:
  assumes rho: "fg_run A rho HOs SHOs coords"
      and rd: "round (rho m) p = round (rho n) p"
  shows "state (rho m) p = state (rho n) p"
proof -
  {
    fix k i
    have "round (rho (k+i)) p = round (rho k) p
          \<Longrightarrow> state (rho (k+i)) p = state (rho k) p"
      (is "?R i \<Longrightarrow> ?S i")
    proof (induct i)
      show "?S 0" by simp
    next
      fix j
      assume ih: "?R j \<Longrightarrow> ?S j"
         and r: "round (rho (k + Suc j)) p = round (rho k) p"
      from rho have 1: "round (rho k) p \<le> round (rho (k+j)) p"
        by (auto elim: fg_round_numbers_increase)
      from rho have 2: "round (rho (k+j)) p \<le> round (rho (k + Suc j)) p"
        by (auto elim: fg_round_numbers_increase)
      from 1 2 r have 3: "round (rho (k+j)) p = round (rho k) p" by auto
      with r have "round (rho (Suc (k+j))) p = round (rho (k+j)) p" by simp
      with rho have "state (rho (Suc (k+j))) p = state (rho (k+j)) p"
        by (auto elim: fg_state_change)
      with 3 ih show "?S (Suc j)" by simp
    qed
  }
  note aux = this
  show ?thesis
  proof (cases "n \<le> m")
    case True
    then obtain k where "m = n+k" by (auto simp: le_iff_add)
    with rd show ?thesis by (auto simp: aux)
  next
    case False
    hence "m \<le> n" by simp
    then obtain k where "n = m+k" by (auto simp: le_iff_add)
    with rd show ?thesis by (auto simp: aux)
  qed
qed

text {*
  Since every process executes every round, function @{text fg_startRound}
  is well-defined. We also list a few facts about @{text fg_startRound} that
  will be used to show that it is a ``stuttering sampling function'',
  a notion introduced in the theories about stuttering equivalence.
*}
lemma fg_start_round:
  assumes "fg_run A rho HOs SHOs coords"
  shows "round (rho (fg_start_round rho p r)) p = r"
using assms by (auto simp: fg_run_def fg_start_round_def intro: LeastI_ex)

lemma fg_start_round_smallest:
  assumes "round (rho k) p = r"
  shows "fg_start_round rho p r \<le> (k::nat)"
using assms unfolding fg_start_round_def by (rule Least_le)

lemma fg_start_round_later:
  assumes rho: "fg_run A rho HOs SHOs coords"
      and r: "round (rho n) p = r" and r': "r < r'"
  shows "n < fg_start_round rho p r'" (is "_ < ?start")
proof (rule ccontr)
  assume "\<not> ?thesis"
  hence start: "?start \<le> n" by simp
  from rho this have "round (rho ?start) p \<le> round (rho n) p"
    by (rule fg_round_numbers_increase)
  with r have "r' \<le> r" by (simp add: fg_start_round[OF rho])
  with r' show "False" by simp
qed

lemma fg_start_round_0:
  assumes rho: "fg_run A rho HOs SHOs coords"
  shows "fg_start_round rho p 0 = 0"
proof -
  from rho have "round (rho 0) p = 0" by (auto simp: fg_run_def fg_init_config_def)
  hence "fg_start_round rho p 0 \<le> 0" by (rule fg_start_round_smallest)
  thus ?thesis by simp
qed

lemma fg_start_round_strict_mono:
  assumes rho: "fg_run A rho HOs SHOs coords"
  shows "strict_mono (fg_start_round rho p)"
proof
  fix r r'
  assume r: "(r::nat) < r'"
  from rho have "round (rho (fg_start_round rho p r)) p = r" by (rule fg_start_round)
  from rho this r show "fg_start_round rho p r < fg_start_round rho p r'"
    by (rule fg_start_round_later)
qed

text {*
  Process @{text p} is at round @{text r} at all configurations between
  the start of round @{text r} and the start of round @{text "r+1"}.
  By lemma @{text fg_same_round_same_state}, this implies that the
  local state of process @{text p} is the same at all these configurations.
*}
lemma fg_round_between_start_rounds:
assumes rho: "fg_run A rho HOs SHOs coords"
    and 1: "fg_start_round rho p r \<le> n"
    and 2: "n < fg_start_round rho p (Suc r)"
shows "round (rho n) p = r" (is "?rd = r")
proof (rule antisym)
  from 1 have "round (rho (fg_start_round rho p r)) p \<le> ?rd"
    by (rule fg_round_numbers_increase[OF rho])
  thus "r \<le> ?rd" by (simp add: fg_start_round[OF rho])
next
  show "?rd \<le> r"
  proof (rule ccontr)
    assume "\<not> ?thesis"
    hence "Suc r \<le> ?rd" by simp
    hence "fg_start_round rho p (Suc r) \<le> fg_start_round rho p ?rd"
      by (rule rho[THEN fg_start_round_strict_mono, THEN strict_mono_mono,
                   THEN monoD])
    also have "... \<le> n" by (auto intro: fg_start_round_smallest)
    also note 2
    finally show "False" by simp
  qed
qed

text {*
  For any process @{text p} and round @{text r} there is some instant @{text n}
  where @{text p} executes a local transition from round @{text r}. In fact,
  @{text "n+1"} marks the start of round @{text "r+1"}.
*}
lemma fg_local_transition_from_round:
assumes rho: "fg_run A rho HOs SHOs coords"
obtains n where "round (rho n) p = r"
            and "fg_start_round rho p (Suc r) = Suc n"
            and "fg_local A p (HOs r p) (coords (Suc r) p) (rho n) (rho (Suc n))"
proof -
  have "fg_start_round rho p (Suc r) \<noteq> 0" (is "?start \<noteq> 0")
  proof
    assume contr: "?start = 0"
    from rho have "round (rho ?start) p = Suc r" by (rule fg_start_round)
    with contr rho show "False" by (auto simp: fg_run_def fg_init_config_def)
  qed
  then obtain n where n: "?start = Suc n" by (auto simp: gr0_conv_Suc)
  with fg_start_round[OF rho, of p "Suc r"]
  have 0: "round (rho (Suc n)) p = Suc r" by simp
  have 1: "round (rho n) p = r"
  proof (rule fg_round_between_start_rounds[OF rho])
    have "fg_start_round rho p r < fg_start_round rho p (Suc r)"
      by (rule fg_start_round_strict_mono[OF rho, THEN strict_monoD]) simp
    with n show "fg_start_round rho p r \<le> n" by simp
  next
    from n show "n < ?start" by simp
  qed
  from rho obtain p' where
    "fg_next_config A p' (HOs (round (rho n) p') p')
                         (SHOs (round (rho n) p') p')
                         (coords (round (rho (Suc n)) p') p')
                         (rho n) (rho (Suc n))"
    (is "fg_next_config _ _ ?HO ?SHO ?crd ?cfg ?cfg'")
    by (force simp: fg_run_def)
  hence "fg_local A p (HOs r p) (coords (Suc r) p) (rho n) (rho (Suc n))"
  proof (auto simp: fg_next_config_def)
    fix q
    assume "fg_send_msg A p' q ?cfg ?cfg'"
      -- "impossible because round changes"
    with 0 1 show ?thesis by (auto simp: fg_send_msg_def)
  next
    fix q
    assume "fg_rcv_msg p' q ?HO ?SHO ?cfg ?cfg'"
      -- "impossible because round changes"
    with 0 1 show ?thesis by (auto simp: fg_rcv_msg_def)
  next
    assume "fg_local A p' ?HO ?crd ?cfg ?cfg'"
    with 0 1 show ?thesis by (cases "p' = p") (auto simp: fg_local_def)
  qed
  with 1 n that show ?thesis by auto
qed

text {*
  We now prove two invariants asserted in \cite{saad:reduction}. The first
  one states that any message @{text m} in transit from process @{text p}
  to process @{text q} for round @{text r} corresponds to the message
  computed by @{text p} for @{text q}, given @{text p}'s state at its
  @{text r}th local transition.
*}

lemma fg_invariant1:
  assumes rho: "fg_run A rho HOs SHOs coords"
      and m: "(p,r,q,m) \<in> network (rho n)" (is "?msg n")
  shows "m = sendMsg A r p q (state (rho (fg_start_round rho p r)) p)"
using m proof (induct n)
  -- {* the base case is trivial because the network is empty *}
  assume "?msg 0" with rho show "?thesis"
    by (auto simp: fg_run_def fg_init_config_def)
next
  fix n
  assume m': "?msg (Suc n)" and ih: "?msg n \<Longrightarrow> ?thesis"
  from rho obtain p' where
    "fg_next_config A p' (HOs (round (rho n) p') p')
                         (SHOs (round (rho n) p') p')
                         (coords (round (rho (Suc n)) p') p')
                         (rho n) (rho (Suc n))"
    (is "fg_next_config _ _ ?HO ?SHO ?crd ?cfg ?cfg'")
    by (force simp: fg_run_def)
  thus "?thesis"
  proof (auto simp: fg_next_config_def)
    txt {*
      Only @{text fg_send_msg} transitions for process @{text p} are interesting,
      since all other transitions cannot add a message for @{text p}, hence we can
      apply the induction hypothesis.
    *}
    fix q'
    assume send: "fg_send_msg A p' q' ?cfg ?cfg'"
    show ?thesis
    proof (cases "?msg n")
      case True
      with ih show ?thesis .
    next
      case False
      with send m' have 1: "p' = p" "round ?cfg p = r"
                    and 2: "m = sendMsg A r p q (state ?cfg p)"
        by (auto simp: fg_send_msg_def)
      from rho 1 have "state ?cfg p = state (rho (fg_start_round rho p r)) p"
        by (auto simp: fg_start_round fg_same_round_same_state)
      with 1 2 show ?thesis by simp
    qed
  next
    fix q'
    assume "fg_rcv_msg p' q' ?HO ?SHO ?cfg ?cfg'"
    with m' have "?msg n" by (auto simp: fg_rcv_msg_def)
    with ih show ?thesis .
  next
    assume "fg_local A p' ?HO ?crd ?cfg ?cfg'"
    with m' have "?msg n" by (auto simp: fg_local_def)
    with ih show ?thesis .
  qed
qed

text {*
  The second invariant states that if process @{text q} received message
  @{text m} from process @{text p}, then (a) @{text p} is in @{text q}'s
  HO set for that round @{text m}, and (b) if @{text p} is moreover in
  @{text q}'s SHO set, then @{text m} is the message that @{text p} computed
  at the start of that round.
*}

lemma fg_invariant2a:
  assumes rho: "fg_run A rho HOs SHOs coords"
      and m: "rcvd (rho n) q p = Some m" (is "?rcvd n")
  shows "p \<in> HOs (round (rho n) q) q"
  (is "p \<in> HOs (?rd n) q" is "?P n")
using m proof (induct n)
  -- {* The base case is trivial because @{text q} has not received any message initially *}
  assume "?rcvd 0" with rho show "?P 0"
    by (auto simp: fg_run_def fg_init_config_def)
next
  fix n
  assume rcvd: "?rcvd (Suc n)" and ih: "?rcvd n \<Longrightarrow> ?P n"
  -- {* For the inductive step we distinguish the possible transitions *}
  from rho obtain p' where
    "fg_next_config A p' (HOs (round (rho n) p') p')
                         (SHOs (round (rho n) p') p')
                         (coords (round (rho (Suc n)) p') p')
                         (rho n) (rho (Suc n))"
    (is "fg_next_config _ _ ?HO ?SHO ?crd ?cfg ?cfg'")
    by (force simp: fg_run_def)
  thus "?P (Suc n)"
  proof (auto simp: fg_next_config_def)
    txt {*
      Except for @{text fg_rcv_msg} steps of process @{text q}, the proof
      is immediately reduced to the induction hypothesis.
    *}
    fix q'
    assume rcvmsg: "fg_rcv_msg p' q' ?HO ?SHO ?cfg ?cfg'"
    hence rd: "?rd (Suc n) = ?rd n" by (auto simp: fg_rcv_msg_def)
    show "?P (Suc n)"
    proof (cases "?rcvd n")
      case True
      with ih rd show ?thesis by simp
    next
      case False
      with rcvd rcvmsg rd show ?thesis by (auto simp: fg_rcv_msg_def)
    qed
  next
    fix q'
    assume "fg_send_msg A p' q' ?cfg ?cfg'"
    with rcvd have "?rcvd n" and "?rd (Suc n) = ?rd n"
      by (auto simp: fg_send_msg_def)
    with ih show "?P (Suc n)" by simp
  next
    assume "fg_local A p' ?HO ?crd ?cfg ?cfg'"
    with rcvd have "?rcvd n" and "?rd (Suc n) = ?rd n"
      -- {* in fact, @{text "p' = q"} is impossible because the @{text rcvd} field of @{text p'} is cleared *}
      by (auto simp: fg_local_def)
    with ih show "?P (Suc n)" by simp
  qed
qed

lemma fg_invariant2b:
  assumes rho: "fg_run A rho HOs SHOs coords"
      and m: "rcvd (rho n) q p = Some m" (is "?rcvd n")
      and sho: "p \<in> SHOs (round (rho n) q) q" (is "p \<in> SHOs (?rd n) q")
  shows "m = sendMsg A (?rd n) p q
                     (state (rho (fg_start_round rho p (?rd n))) p)"
        (is "?P n")
using m sho proof (induct n)
  -- {* The base case is trivial because @{text q} has not received any message initially *}
  assume "?rcvd 0" with rho show "?P 0"
    by (auto simp: fg_run_def fg_init_config_def)
next
  fix n
  assume rcvd: "?rcvd (Suc n)" and p: "p \<in> SHOs (?rd (Suc n)) q"
     and ih: "?rcvd n \<Longrightarrow> p \<in> SHOs (?rd n) q \<Longrightarrow> ?P n"
  -- {* For the inductive step we again distinguish the possible transitions *}
  from rho obtain p' where
    "fg_next_config A p' (HOs (round (rho n) p') p')
                         (SHOs (round (rho n) p') p')
                         (coords (round (rho (Suc n)) p') p')
                         (rho n) (rho (Suc n))"
    (is "fg_next_config _ _ ?HO ?SHO ?crd ?cfg ?cfg'")
    by (force simp: fg_run_def)
  thus "?P (Suc n)"
  proof (auto simp: fg_next_config_def)
    txt {*
      Except for @{text fg_rcv_msg} steps of process @{text q}, the proof
      is immediately reduced to the induction hypothesis.
    *}
    fix q'
    assume rcvmsg: "fg_rcv_msg p' q' ?HO ?SHO ?cfg ?cfg'"
    hence rd: "?rd (Suc n) = ?rd n" by (auto simp: fg_rcv_msg_def)
    show "?P (Suc n)"
    proof (cases "?rcvd n")
      case True
      with ih p rd show ?thesis by simp
    next
      case False
      from rcvmsg obtain m' m'' where
        "(q', round ?cfg p', p', m') \<in> network ?cfg"
        "rcvd ?cfg' = (rcvd ?cfg)(p' := (rcvd ?cfg p')(q' :=
                          if q' \<in> ?SHO then Some m' else Some m''))"
        by (auto simp: fg_rcv_msg_def split del: split_if_asm)
      with False rcvd p rd have "(p, ?rd n, q, m) \<in> network ?cfg" by auto
      with rho rd show ?thesis by (auto simp: fg_invariant1)
    qed
  next
    fix q'
    assume "fg_send_msg A p' q' ?cfg ?cfg'"
    with rcvd have "?rcvd n" and "?rd (Suc n) = ?rd n"
      by (auto simp: fg_send_msg_def)
    with p ih show "?P (Suc n)" by simp
  next
    assume "fg_local A p' ?HO ?crd ?cfg ?cfg'"
    with rcvd have "?rcvd n" and "?rd (Suc n) = ?rd n"
      -- {* in fact, @{text "p' = q"} is impossible because the @{text rcvd} field of @{text p'} is cleared *}
      by (auto simp: fg_local_def)
    with p ih show "?P (Suc n)" by simp
  qed
qed

subsection {* From Fine-Grained to Coarse-Grained Runs *}

text {*
  The reduction theorem asserts that for any fine-grained run @{text rho}
  there is a coarse-grained run such that every process sees the same
  sequence of local states in the two runs, modulo stuttering. In other words,
  no process can locally distinguish the two runs.

  Given fine-grained run @{text rho}, the corresponding coarse-grained run @{text sigma} is
  defined as the sequence of state vectors at the beginning of every round.
  Notice in particular that the local states @{text "sigma r p"} and
  @{text "sigma r q"} of two different processes @{text p} and @{text q}
  appear at different instants in the original run @{text rho}. Nevertheless,
  we prove that @{text sigma} is a coarse-grained run of the algorithm for
  the same HO, SHO, and coordinator assignments. By definition (and the
  fact that local states remain equal between @{text fg_start_round}
  instants), the sequences of process states in @{text rho} and
  @{text sigma} are easily seen to be stuttering equivalent, and this
  will be formally stated below.
*}

definition coarse_run where
  "coarse_run rho r p \<equiv> state (rho (fg_start_round rho p r)) p"

theorem reduction:
  assumes rho: "fg_run A rho HOs SHOs coords"
  shows "CSHORun A (coarse_run rho) HOs SHOs coords"
        (is "CSHORun _ ?cr _ _ _")
proof (auto simp: CSHORun_def)
  from rho show "CHOinitConfig A (?cr 0) (coords 0)"
    by (auto simp: fg_run_def fg_init_config_def CHOinitConfig_def
                   coarse_run_def fg_start_round_0[OF rho])
next
  fix r
  show "CSHOnextConfig A r (?cr r) (HOs r) (SHOs r) (coords (Suc r))
                       (?cr (Suc r))"
  proof (auto simp add: CSHOnextConfig_def)
    fix p
    from rho[THEN fg_local_transition_from_round] obtain n
      where n: "round (rho n) p = r"
        and start: "fg_start_round rho p (Suc r) = Suc n" (is "?start = _")
        and loc: "fg_local A p (HOs r p) (coords (Suc r) p) (rho n) (rho (Suc n))"
                 (is "fg_local _ _ ?HO ?crd ?cfg ?cfg'")
      by blast
    have cfg: "?cr r p = state ?cfg p"
      unfolding coarse_run_def proof (rule fg_same_round_same_state[OF rho])
      from n show "round (rho (fg_start_round rho p r)) p = round ?cfg p"
        by (simp add: fg_start_round[OF rho])
    qed
    from start have cfg': "?cr (Suc r) p = state ?cfg' p"
      by (simp add: coarse_run_def)
    have rcvd: "rcvd ?cfg p \<in> SHOmsgVectors A r p (?cr r) ?HO (SHOs r p)"
    proof (auto simp: SHOmsgVectors_def)
      fix q
      assume "q \<in> ?HO"
      with n loc show "\<exists>m. rcvd ?cfg p q = Some m" by (auto simp: fg_local_def)
    next
      fix q m
      assume "rcvd ?cfg p q = Some m"
      with rho n show "q \<in> ?HO" by (auto simp: fg_invariant2a)
    next
      fix q
      assume sho: "q \<in> SHOs r p" and ho: "q \<in> ?HO"
      from ho n loc obtain m where "rcvd ?cfg p q = Some m"
        by (auto simp: fg_local_def)
      with rho n sho show "rcvd ?cfg p q = Some (sendMsg A r q p (?cr r q))"
        by (auto simp: fg_invariant2b coarse_run_def)
    qed
    with n loc cfg cfg'
    show "\<exists>\<mu> \<in> SHOmsgVectors A r p (?cr r) ?HO (SHOs r p).
             CnextState A r p (?cr r p) \<mu> ?crd (?cr (Suc r) p)"
      by (auto simp: fg_local_def)
  qed
qed

subsection {* Locally Similar Runs and Local Properties *}

text {*
  We say that two sequences of configurations (vectors of process states)
  are \emph{locally similar} if for every process the sequences of its
  process states are stuttering equivalent. Observe that different stuttering
  reduction may be applied for every process, hence the original sequences of
  configurations need not be stuttering equivalent and can indeed differ
  wildly in the combinations of local states that occur.

  A property of a sequence of configurations is called \emph{local} if it
  is insensitive to local similarity.
*}

definition locally_similar where
  "locally_similar (\<sigma>::nat \<Rightarrow> 'proc \<Rightarrow> 'pst)  \<tau> \<equiv>
   \<forall>p::'proc. (\<lambda>n. \<sigma> n p) \<approx> (\<lambda>n. \<tau> n p)"

definition local_property where
  "local_property P \<equiv>
   \<forall>\<sigma> \<tau>. locally_similar \<sigma> \<tau> \<longrightarrow> P \<sigma> \<longrightarrow> P \<tau>"

text {*
  Local similarity is an equivalence relation.
*}

lemma locally_similar_refl: "locally_similar \<sigma> \<sigma>"
  by (simp add: locally_similar_def stutter_equiv_refl)

lemma locally_similar_sym: "locally_similar \<sigma> \<tau> \<Longrightarrow> locally_similar \<tau> \<sigma>"
  by (simp add: locally_similar_def stutter_equiv_sym)

lemma locally_similar_trans [trans]:
  "locally_similar \<rho> \<sigma> \<Longrightarrow> locally_similar \<sigma> \<tau> \<Longrightarrow> locally_similar \<rho> \<tau>"
  by (force simp add: locally_similar_def elim: stutter_equiv_trans)

lemma local_property_eq:
  "local_property P = (\<forall>\<sigma> \<tau>. locally_similar \<sigma> \<tau> \<longrightarrow> P \<sigma> = P \<tau>)"
  by (auto simp: local_property_def dest: locally_similar_sym)

text {*
  Consider any fine-grained run @{text rho}. The projection of @{text rho}
  to vectors of process states is locally similar to the coarse-grained run
  computed from @{text rho}.
*}

lemma coarse_run_locally_similar:
  assumes rho: "fg_run A rho HOs SHOs coords"
  shows "locally_similar (state \<circ> rho) (coarse_run rho)"
proof (auto simp: locally_similar_def)
  fix p
  show "(\<lambda>n. state (rho n) p) \<approx> (\<lambda>n. coarse_run rho n p)" (is "?fgr \<approx> ?cgr")
  proof (rule stutter_equivI)
    show "stutter_sampler (fg_start_round rho p) ?fgr"
    proof (auto simp: stutter_sampler_def)
      from rho show "fg_start_round rho p 0 = 0"
        by (rule fg_start_round_0)
    next
      show "strict_mono (fg_start_round rho p)"
        by (rule fg_start_round_strict_mono[OF rho])
    next
      fix r n
      assume "fg_start_round rho p r < n" and "n < fg_start_round rho p (Suc r)"
      with rho have "round (rho n) p = round (rho (fg_start_round rho p r)) p"
        by (simp add: fg_start_round fg_round_between_start_rounds)
      with rho show "state (rho n) p = state (rho (fg_start_round rho p r)) p"
        by (rule fg_same_round_same_state)
    qed
  next
    show "stutter_sampler id ?cgr"
      by (rule id_stutter_sampler)
  next
    show "?fgr \<circ> fg_start_round rho p = ?cgr \<circ> id"
      by (auto simp: coarse_run_def)
  qed
qed

text {*
  Therefore, in order to verify a local property @{text P} for a
  fine-grained run over given @{text HO}, @{text SHO}, and @{text coord}
  collections, it is enough to show that @{text P} holds for all
  coarse-grained runs for these same collections.
  Indeed, one may restrict attention to coarse-grained runs whose
  initial states agree with that of the given fine-grained run.
*}

theorem local_property_reduction:
  assumes rho: "fg_run A rho HOs SHOs coords"
      and P: "local_property P"
      and coarse_correct:
            "\<And> crho. \<lbrakk> CSHORun A crho HOs SHOs coords; crho 0 = state (rho 0)\<rbrakk>
                      \<Longrightarrow> P crho"
  shows "P (state \<circ> rho)"
proof -
  have "coarse_run rho 0 = state (rho 0)"
    by (rule ext, simp add: coarse_run_def fg_start_round_0[OF rho])
  from rho[THEN reduction] this
  have "P (coarse_run rho)" by (rule coarse_correct)
  with coarse_run_locally_similar[OF rho] P
  show ?thesis by (auto simp: local_property_eq)
qed

subsection {* Consensus as a Local Property *}

text {*
  Consensus and Weak Consensus are local properties and can therefore
  be verified just over coarse-grained runs, according to theorem
  @{text local_property_reduction}.
*}

lemma integrity_is_local:
  assumes sim: "locally_similar \<sigma> \<tau>"
      and val: "\<And>n. dec (\<sigma> n p) = Some v \<Longrightarrow> v \<in> range vals"
      and dec: "dec (\<tau> n p) = Some v"
  shows "v \<in> range vals"
proof -
  from sim have "(\<lambda>r. \<sigma> r p) \<approx> (\<lambda>r. \<tau> r p)" by (simp add: locally_similar_def)
  then obtain m where "\<sigma> m p = \<tau> n p" by (rule stutter_equiv_element_left)
  from sym[OF this] dec show ?thesis by (auto elim: val)
qed

lemma validity_is_local:
  assumes sim: "locally_similar \<sigma> \<tau>"
      and val: "\<And>n. dec (\<sigma> n p) = Some w \<Longrightarrow> w = v"
      and dec: "dec (\<tau> n p) = Some w"
  shows "w = v"
proof -
  from sim have "(\<lambda>r. \<sigma> r p) \<approx> (\<lambda>r. \<tau> r p)" by (simp add: locally_similar_def)
  then obtain m where "\<sigma> m p = \<tau> n p" by (rule stutter_equiv_element_left)
  from sym[OF this] dec show ?thesis by (auto elim: val)
qed

lemma agreement_is_local:
  assumes sim: "locally_similar \<sigma> \<tau>"
  and agr: "\<And>m n. \<lbrakk>dec (\<sigma> m p) = Some v; dec (\<sigma> n q) = Some w\<rbrakk> \<Longrightarrow> v=w"
  and v: "dec (\<tau> m p) = Some v" and w: "dec (\<tau> n q) = Some w"
  shows "v = w"
proof -
  from sim have "(\<lambda>r. \<sigma> r p) \<approx> (\<lambda>r. \<tau> r p)" by (simp add: locally_similar_def)
  then obtain m' where m': "\<sigma> m' p = \<tau> m p" by (rule stutter_equiv_element_left)
  from sim have "(\<lambda>r. \<sigma> r q) \<approx> (\<lambda>r. \<tau> r q)" by (simp add: locally_similar_def)
  then obtain n' where n': "\<sigma> n' q = \<tau> n q" by (rule stutter_equiv_element_left)
  from sym[OF m'] sym[OF n'] v w show "v = w" by (auto elim: agr)
qed

lemma termination_is_local:
  assumes sim: "locally_similar \<sigma> \<tau>"
      and trm: "dec (\<sigma> m p) = Some v"
  shows "\<exists>n. dec (\<tau> n p) = Some v"
proof -
  from sim have "(\<lambda>r. \<sigma> r p) \<approx> (\<lambda>r. \<tau> r p)" by (simp add: locally_similar_def)
  then obtain n where "\<sigma> m p = \<tau> n p" by (rule stutter_equiv_element_right)
  with trm show ?thesis by auto
qed

theorem consensus_is_local: "local_property (consensus vals dec)"
proof (auto simp: local_property_def consensus_def)
  fix \<sigma> \<tau> n p v
  assume "locally_similar \<sigma> \<tau>"
  and "\<forall>n p v. dec (\<sigma> n p) = Some v \<longrightarrow> v \<in> range vals"
  and "dec (\<tau> n p) = Some v"
  thus "v \<in> range vals" by (blast intro: integrity_is_local)
next
  fix \<sigma> \<tau> m n p q v w
  assume "locally_similar \<sigma> \<tau>"
  and "\<forall>m n p q v w. dec (\<sigma> m p) = Some v \<and> dec (\<sigma> n q) = Some w \<longrightarrow> v = w"
  and "dec (\<tau> m p) = Some v" and "dec (\<tau> n q) = Some w"
  thus "v = w" by (blast intro: agreement_is_local)
next
  fix \<sigma> \<tau> p
  assume "locally_similar \<sigma> \<tau>"
  and "\<forall>p. \<exists>m v. dec (\<sigma> m p) = Some v"
  thus "\<exists>n w. dec (\<tau> n p) = Some w" by (blast dest: termination_is_local)
qed

theorem weak_consensus_is_local: "local_property (weak_consensus vals dec)"
proof (auto simp: local_property_def weak_consensus_def)
  fix \<sigma> \<tau> n p v w
  assume "locally_similar \<sigma> \<tau>"
  and "\<forall>n p w. dec (\<sigma> n p) = Some w \<longrightarrow> w = v"
  and "dec (\<tau> n p) = Some w"
  thus "w = v" by (blast intro: validity_is_local)
next
  fix \<sigma> \<tau> m n p q v w
  assume "locally_similar \<sigma> \<tau>"
  and "\<forall>m n p q v w. dec (\<sigma> m p) = Some v \<and> dec (\<sigma> n q) = Some w \<longrightarrow> v = w"
  and "dec (\<tau> m p) = Some v" and w: "dec (\<tau> n q) = Some w"
  thus "v = w" by (blast intro: agreement_is_local)
next
  fix \<sigma> \<tau> p
  assume "locally_similar \<sigma> \<tau>"
  and "\<forall>p. \<exists>m v. dec (\<sigma> m p) = Some v"
  thus "\<exists>n w. dec (\<tau> n p) = Some w" by (blast dest: termination_is_local)
qed

end


theory Matrix_LinPoly
  imports
    Jordan_Normal_Form.Matrix_Impl
    Farkas.Simplex_for_Reals
    Farkas.Matrix_Farkas
begin

text \<open> Add this to linear polynomials in Simplex \<close>

lemma eval_poly_with_sum: "(v \<lbrace> X \<rbrace>) = (\<Sum>x\<in> vars v. coeff v x * X x)"
  using linear_poly_sum sum.cong by fastforce

lemma eval_poly_with_sum_superset:
  assumes "finite S"
  assumes "S \<supseteq> vars v"
  shows "(v \<lbrace>X\<rbrace>) = (\<Sum>x\<in>S. coeff v x * X x)"
proof -
  define D where D: "D = S - vars v"
  have zeros: "\<forall>x \<in> D. coeff v x = 0"
    using D coeff_zero by auto
  have fnt: "finite (vars v)"
    using finite_vars by auto
  have "(v \<lbrace>X\<rbrace>) = (\<Sum>x\<in> vars v. coeff v x * X x)"
    using linear_poly_sum sum.cong by fastforce
  also have "... = (\<Sum>x\<in> vars v. coeff v x * X x) + (\<Sum>x\<in>D. coeff v x * X x)"
    using zeros by auto
  also have "... = (\<Sum>x\<in> vars v \<union> D. coeff v x * X x)"
    using assms(1) fnt Diff_partition[of "vars v" S, OF assms(2)]
      sum.subset_diff[of "vars v" S, OF assms(2) assms(1)]
    by (simp add: \<open>\<And>g. sum g S = sum g (S - vars v) + sum g (vars v)\<close> D)
  also have "... = (\<Sum>x\<in>S. coeff v x * X x)"
    using D Diff_partition assms(2) by fastforce
  finally show ?thesis .
qed

text \<open> Get rid of these synonyms \<close>

section \<open> Translations of Jordan Normal Forms Matrix Library to Simplex polynomials \<close>

subsection \<open> Vectors \<close>

(* Translate rat list to linear polynomial with same coefficients *)

definition list_to_lpoly where
    "list_to_lpoly cs = sum_list (map2 (\<lambda> i c. lp_monom c i) [0..<length cs] cs)"

lemma empty_list_0poly:
  shows "list_to_lpoly [] = 0"
  unfolding list_to_lpoly_def by simp

lemma sum_list_map_upto_coeff_limit:
  assumes "i \<ge> length L"
  shows "coeff (list_to_lpoly L) i = 0"
  using assms by (induction L rule: rev_induct) (auto simp: list_to_lpoly_def)

lemma rl_lpoly_coeff_nth_non_empty:
  assumes "i < length cs"
  assumes "cs \<noteq> []"
  shows "coeff (list_to_lpoly cs) i = cs!i"
  using assms(2) assms(1)
proof (induction cs rule: rev_nonempty_induct)
  fix x ::rat
  assume "i < length [x]"
  have "(list_to_lpoly [x]) = lp_monom x 0"
    by (simp add: list_to_lpoly_def)
  then show "coeff (list_to_lpoly [x]) i = [x] ! i"
    using \<open>i < length [x]\<close> list_to_lpoly_def by auto
next
  fix x :: rat
  fix xs :: "rat list"
  assume "xs \<noteq> []"
  assume IH: "i < length xs \<Longrightarrow> coeff (list_to_lpoly xs) i = xs ! i"
  assume "i < length (xs @ [x])"
  consider (le) "i < length xs" | (eq) "i = length xs"
    using \<open>i < length (xs @ [x])\<close> less_Suc_eq by auto
  then show "coeff (list_to_lpoly (xs @ [x])) i = (xs @ [x]) ! i"
  proof (cases)
    case le
    have "coeff (lp_monom x (length xs)) i = 0"
      using le by auto
    have "coeff (sum_list (map2 (\<lambda>x y. lp_monom y x)
          [0..<length (xs @ [x])] (xs @ [x]))) i = (xs @ [x]) ! i"
      apply(simp add: IH le nth_append)
      using IH le list_to_lpoly_def by auto
    then show ?thesis
      unfolding list_to_lpoly_def by simp
  next
    case eq
    then have *: "coeff (sum_list (map2 (\<lambda>x y. lp_monom y x) [0..<length xs] xs)) i = 0"
      using sum_list_map_upto_coeff_limit[of xs i]
      by (simp add: list_to_lpoly_def)
    have **: "(sum_list (map2 (\<lambda> x y. lp_monom y x) [0..<length (xs @ [x])] (xs @ [x]))) =
          sum_list (map (\<lambda>(x,y). lp_monom y x) (zip [0..<length xs] xs)) + lp_monom x (length xs)"
      by simp
    have "coeff ((list_to_lpoly xs) + lp_monom x (length xs)) i = x"
      unfolding list_to_lpoly_def using * ** by (simp add: eq)
    then show ?thesis
      by (simp add: eq list_to_lpoly_def)
  qed
qed

lemma list_to_lpoly_coeff_nth:
  assumes "i < length cs "
  shows "coeff (list_to_lpoly cs) i = cs ! i"
  using gr_implies_not0 rl_lpoly_coeff_nth_non_empty assms by fastforce

lemma rat_list_outside_zero:
  assumes "length cs \<le> i"
  shows "coeff (list_to_lpoly cs) i = 0"
  using sum_list_map_upto_coeff_limit[of cs i, OF assms] by simp

text \<open> Transform linear polynomials to rational vectors \<close>

fun dim_poly where
  "dim_poly p = (if (vars p) = {} then 0 else Max (vars p)+1)"
(* 0, 0, 0, 3, 0, 0, \<dots> has dimension 4 , consistent with  dim vec  *)

definition max_dim_poly_list where
  "max_dim_poly_list lst = Max {Max (vars p) |p. p \<in> set lst}"

fun lpoly_to_vec where
    "lpoly_to_vec p = vec (dim_poly p) (coeff p)"

lemma all_greater_dim_poly_zero[simp]:
  assumes "x \<ge> dim_poly p"
  shows "coeff p x = 0"
  using Max_ge[of "vars p" x, OF finite_vars[of p]] coeff_zero[of p x]
  by (metis add_cancel_left_right assms dim_poly.elims empty_iff leD le_eq_less_or_eq
      trans_less_add1 zero_neq_one_class.zero_neq_one)

lemma lpoly_to_vec_0_iff_zero_poly [iff]:
  shows "(lpoly_to_vec p) = 0\<^sub>v 0 \<longleftrightarrow> p = 0"
proof(standard)
  show "lpoly_to_vec p = 0\<^sub>v 0 \<Longrightarrow> p = 0"
  proof (rule contrapos_pp)
    assume "p \<noteq> 0"
    then have "vars p \<noteq> {}"
      by (simp add: vars_empty_zero)
    then have "dim_poly p > 0"
      by (simp)
    then show "lpoly_to_vec p \<noteq> 0\<^sub>v 0"
      using vec_of_dim_0[of "lpoly_to_vec p"]  by simp
  qed
next
qed (auto simp: vars_empty_zero)

lemma dim_poly_dim_vec_equiv:
  "dim_vec (lpoly_to_vec p) = dim_poly p"
  using lpoly_to_vec.simps by auto

lemma dim_poly_greater_ex_coeff: "dim_poly x > d \<Longrightarrow> \<exists>i\<ge>d. coeff x i \<noteq> 0"
   by (simp split: if_splits) (meson Max_in coeff_zero finite_vars less_Suc_eq_le)

lemma dimpoly_all_zero_limit:
  assumes "\<And>i. i \<ge> d \<Longrightarrow> coeff x i = 0"
  shows "dim_poly x \<le> d"
proof -
  have "(\<forall>i\<ge> d. coeff x i = 0) \<Longrightarrow> dim_poly x \<le> d "
  proof (rule contrapos_pp)
    assume "\<not> dim_poly x \<le> d"
    then have "dim_poly x > d" by linarith
    then have "\<exists>i \<ge> d. coeff x i \<noteq> 0"
      using dim_poly_greater_ex_coeff[of d x] by blast
    then show "\<not> (\<forall>i\<ge>d. coeff x i = 0)"
      by blast
  qed
  then show ?thesis
    using assms by blast
qed

lemma construct_poly_from_lower_dim_poly:
  assumes "dim_poly x = d+1"
  obtains p c where "dim_poly p \<le> d" "x = p + lp_monom c d"
proof -
  define c' where c': "c' = coeff x d"
  have f: "\<forall>i>d. coeff x i = 0"
    using assms by auto
  have *: "x = x - (lp_monom c' d) + (lp_monom c' d)"
    by simp
  have "coeff (x - (lp_monom c' d)) d = 0"
    using c' by simp
  then have "\<forall>i\<ge>d. coeff (x - (lp_monom c' d)) i = 0"
    using f by auto
  then have **: "dim_poly (x - (lp_monom c' d)) \<le> d"
    using dimpoly_all_zero_limit[of d "(x - (lp_monom c' d))"] by auto
  define p' where p': "p' = x - (lp_monom c' d)"
  have "\<exists>p c. dim_poly p \<le> d \<and> x = p + lp_monom c d"
    using "*" "**" by blast
  then show ?thesis
    using * p' c' that by blast
qed

lemma vars_subset_0_dim_poly:
  "vars z \<subseteq> {0..<dim_poly z}"
  by (simp add: finite_vars less_Suc_eq_le subsetI)

lemma in_dim_and_not_var_zero: "x \<in> {0..<dim_poly z} - vars z \<Longrightarrow> coeff z x = 0"
  using coeff_zero by auto

lemma valuate_with_dim_poly: "z \<lbrace> X \<rbrace> = (\<Sum>i\<in>{0..<dim_poly z}. coeff z i * X i)"
  using eval_poly_with_sum_superset[of "{0..<dim_poly z}" z X] using vars_subset_0_dim_poly by blast

lemma lin_poly_to_vec_coeff_access:
  assumes "x < dim_poly y"
  shows "(lpoly_to_vec y) $ x = coeff y x"
proof -
  have "x < dim_vec (lpoly_to_vec y)"
    using dim_poly_dim_vec_equiv[of y] assms by auto
  then show ?thesis
    by (simp add: coeff_def)
qed

lemma addition_over_lin_poly_to_vec:
  fixes x y
  assumes "a < dim_poly x"
  assumes "dim_poly x = dim_poly y"
  shows  "(lpoly_to_vec x + lpoly_to_vec y) $ a = coeff (x + y) a"
  using assms(1) assms(2) lin_poly_to_vec_coeff_access by (simp add: dim_poly_dim_vec_equiv)

lemma list_to_lpoly_dim_less: "length cs \<ge> dim_poly (list_to_lpoly cs)"
  using dimpoly_all_zero_limit sum_list_map_upto_coeff_limit by blast

text \<open> Transform rational vectors to linear polynomials \<close>

fun vec_to_lpoly where
  "vec_to_lpoly rv = list_to_lpoly (list_of_vec rv)"

lemma vec_to_lin_poly_coeff_access:
  assumes "x < dim_vec y"
  shows "y $ x = coeff (vec_to_lpoly y) x"
  by (simp add: assms list_to_lpoly_coeff_nth)

lemma addition_over_vec_to_lin_poly:
  fixes x y
  assumes "a < dim_vec x"
  assumes "dim_vec x = dim_vec y"
  shows  "(x + y) $ a = coeff (vec_to_lpoly x + vec_to_lpoly y) a"
  using  assms(1) assms(2) coeff_plus index_add_vec(1)
  by (metis vec_to_lin_poly_coeff_access)

lemma outside_list_coeff0:
  assumes "i \<ge> dim_vec xs"
  shows "coeff (vec_to_lpoly xs) i = 0"
  by (simp add: assms sum_list_map_upto_coeff_limit)

lemma vec_to_poly_dim_less:
  "dim_poly (vec_to_lpoly x) \<le> dim_vec x"
  using list_to_lpoly_dim_less[of "list_of_vec x"] by simp

lemma vec_to_lpoly_from_lpoly_coeff_dual1:
  "coeff (vec_to_lpoly (lpoly_to_vec p)) i = coeff p i"
  by (metis all_greater_dim_poly_zero dim_poly_dim_vec_equiv lin_poly_to_vec_coeff_access
      not_less outside_list_coeff0 vec_to_lin_poly_coeff_access)

lemma vec_to_lpoly_from_lpoly_coeff_dual2:
  assumes "i < dim_vec (lpoly_to_vec (vec_to_lpoly v))"
  shows "(lpoly_to_vec (vec_to_lpoly v)) $ i = v $ i"
  by (metis assms dim_poly_dim_vec_equiv less_le_trans lin_poly_to_vec_coeff_access
      vec_to_lin_poly_coeff_access vec_to_poly_dim_less)

lemma vars_subset_dim_vec_to_lpoly_dim: "vars (vec_to_lpoly v) \<subseteq> {0..<dim_vec v}"
  by (meson ivl_subset le_numeral_extra(3) order.trans vec_to_poly_dim_less
      vars_subset_0_dim_poly)

lemma sum_dim_vec_equals_sum_dim_poly:
  shows "(\<Sum>a = 0..<dim_vec A. coeff (vec_to_lpoly  A) a * X a) =
         (\<Sum>a = 0..<dim_poly (vec_to_lpoly A). coeff (vec_to_lpoly  A) a * X a)"
proof -
  consider (eq) "dim_vec A = dim_poly (vec_to_lpoly A)" |
           (le) "dim_vec A > dim_poly (vec_to_lpoly A)"
    using vec_to_poly_dim_less[of "A"] by fastforce
  then show ?thesis
  proof (cases)
    case le
    define dp where dp: "dp = dim_poly (vec_to_lpoly A)"
    have "(\<Sum>a = 0..<dim_vec A. coeff (vec_to_lpoly A) a * X a) =
          (\<Sum>a = 0..<dp. coeff (vec_to_lpoly A) a * X a) +
          (\<Sum>a = dp..<dim_vec A. coeff (vec_to_lpoly A) a * X a)"
      by (metis (no_types, lifting) dp vec_to_poly_dim_less sum.atLeastLessThan_concat zero_le)
    also have "... = (\<Sum>a = 0..<dp. coeff (vec_to_lpoly A) a * X a)"
      using all_greater_dim_poly_zero by (simp add: dp)
    also have "... = (\<Sum>a = 0..<dim_poly (vec_to_lpoly A).coeff (vec_to_lpoly A) a * X a)"
      using dp by auto
    finally show ?thesis
      by blast
  qed (auto)
qed

lemma vec_to_lpoly_vNil [simp]: "vec_to_lpoly vNil = 0"
  by (simp add: empty_list_0poly)

lemma zero_vector_is_zero_poly: "coeff (vec_to_lpoly (0\<^sub>v n)) i = 0"
  by (metis index_zero_vec(1) index_zero_vec(2) not_less
      outside_list_coeff0 vec_to_lin_poly_coeff_access)

lemma coeff_nonzero_dim_vec_non_zero:
  assumes "coeff (vec_to_lpoly v) i \<noteq> 0"
  shows "v $ i \<noteq> 0" "i < dim_vec v"
  apply (metis assms leI outside_list_coeff0 vec_to_lin_poly_coeff_access)
  using assms leI outside_list_coeff0 by blast

lemma lpoly_of_v_equals_v_append0:
  "vec_to_lpoly v = vec_to_lpoly (v @\<^sub>v 0\<^sub>v a)" (is "?lhs = ?rhs")
proof -
  have "\<forall>i. coeff ?lhs i = coeff ?rhs i"
  proof
    fix i
    consider (le) "i < dim_vec v" | (ge) "i \<ge> dim_vec v"
      using leI by blast
    then show "coeff (vec_to_lpoly v) i = coeff (vec_to_lpoly (v @\<^sub>v 0\<^sub>v a)) i"
    proof (cases)
      case le
      then show ?thesis using vec_to_lin_poly_coeff_access[of i v] index_append_vec(1)
        by (metis  index_append_vec(2) vec_to_lin_poly_coeff_access trans_less_add1)
    next
      case ge
      then have "coeff (vec_to_lpoly v) i = 0"
        using outside_list_coeff0 by blast
      moreover have "coeff (vec_to_lpoly (v @\<^sub>v 0\<^sub>v a)) i = 0"
      proof (rule ccontr)
        assume na: "\<not> coeff (vec_to_lpoly (v @\<^sub>v 0\<^sub>v a)) i = 0"
        define va where v: "va = coeff (vec_to_lpoly (v @\<^sub>v 0\<^sub>v a)) i"
        have "i < dim_vec (v @\<^sub>v 0\<^sub>v a)"
          using coeff_nonzero_dim_vec_non_zero[of "(v @\<^sub>v 0\<^sub>v a)" i] na by blast
        moreover have "(0\<^sub>v a) $ (i - dim_vec v) = va"
          by (metis ge diff_is_0_eq' index_append_vec(1) index_append_vec(2)
              not_less_zero vec_to_lin_poly_coeff_access v zero_less_diff calculation)
        moreover have "va \<noteq> 0" using v na by linarith
        ultimately show False
          using ge by auto
      qed
      then show "coeff (vec_to_lpoly v) i = coeff (vec_to_lpoly (v @\<^sub>v 0\<^sub>v a)) i"
        using  not_less using calculation by linarith
    qed
  qed
  then show ?thesis
    using Abstract_Linear_Poly.poly_eqI by blast
qed

lemma vec_to_lpoly_eval_dot_prod:
"(vec_to_lpoly v) \<lbrace> x \<rbrace> = v \<bullet> (vec (dim_vec v) x)"
proof -
  have "(vec_to_lpoly v) \<lbrace> x \<rbrace> = (\<Sum>i\<in>{0..<dim_vec v}. coeff (vec_to_lpoly v) i * x i)"
    using eval_poly_with_sum_superset[of "{0..<dim_vec v}" "vec_to_lpoly v" x]
      vars_subset_dim_vec_to_lpoly_dim by blast
  also have "... = (\<Sum>i\<in>{0..<dim_vec v}. v$i * x i)"
    using list_to_lpoly_coeff_nth by auto
  also have "... =  v \<bullet> (vec (dim_vec v) x)"
    unfolding scalar_prod_def by auto
  finally show ?thesis .
qed

lemma vec_coeff_append1: "i \<in> {0..<dim_vec a} \<Longrightarrow> coeff (vec_to_lpoly (a@\<^sub>vb)) i = a$i"
  by (metis atLeastLessThan_iff index_append_vec(1) index_append_vec(2) vec_to_lin_poly_coeff_access trans_less_add1)

lemma vec_coeff_append2:
  "i \<in> {dim_vec a..<dim_vec (a@\<^sub>vb)} \<Longrightarrow> coeff (vec_to_lpoly (a@\<^sub>vb)) i = b$(i-dim_vec a)"
  by (metis atLeastLessThan_iff index_append_vec(1) index_append_vec(2) leD vec_to_lin_poly_coeff_access)

text \<open> Maybe Code Equation \<close>
lemma vec_to_lpoly_poly_of_vec_eq: "vec_to_lpoly v = poly_of_vec v"
proof -
  have "\<And>i. i < dim_vec v \<Longrightarrow> coeff (poly_of_vec v) i = v $ i"
    by (simp add: coeff.rep_eq poly_of_vec.rep_eq)
  moreover have "\<And>i. i < dim_vec v \<Longrightarrow> coeff (vec_to_lpoly v) i = v $ i"
    by (simp add: vec_to_lin_poly_coeff_access)
  moreover have "\<And>i. i \<ge> dim_vec v \<Longrightarrow> coeff (poly_of_vec v) i = 0"
    by (simp add: coeff.rep_eq poly_of_vec.rep_eq)
  moreover have "\<And>i. i \<ge> dim_vec v \<Longrightarrow> coeff (vec_to_lpoly v) i = 0"
    using outside_list_coeff0 by blast
  ultimately show ?thesis
    by (metis Abstract_Linear_Poly.poly_eq_iff le_less_linear)
qed

lemma vars_vec_append_subset: "vars (vec_to_lpoly (0\<^sub>v n @\<^sub>v v)) \<subseteq> {n..<n+dim_vec v}"
proof -
  let ?p = "(vec_to_lpoly (0\<^sub>v n @\<^sub>v v))"
  have "dim_poly ?p \<le> n+dim_vec v"
    using dim_poly_of_append_vec[of "0\<^sub>v n" "v"] by auto
  have "vars (vec_to_lpoly (0\<^sub>v n @\<^sub>v v)) \<subseteq> {0..<n+dim_vec v}"
    using vars_subset_dim_vec_to_lpoly_dim[of "(0\<^sub>v n @\<^sub>v v)"] by auto
  moreover have "\<forall>i < n. coeff ?p i = 0"
    using vec_coeff_append1[of _ "0\<^sub>v n" v] by auto
  ultimately show "vars (vec_to_lpoly (0\<^sub>v n @\<^sub>v v)) \<subseteq> {n..<n+dim_vec v}"
    by (meson atLeastLessThan_iff coeff_zero not_le subsetCE subsetI)
qed

section \<open> Matrices \<close>

(* \<open> From \<open> mat \<close> to \<open> linear_poly list \<close>  *)

fun matrix_to_lpolies where
  "matrix_to_lpolies A = map vec_to_lpoly (rows A)"

lemma matrix_to_lpolies_vec_of_row:
  "i <dim_row A \<Longrightarrow> matrix_to_lpolies A ! i = vec_to_lpoly (row A i)"
  using matrix_to_lpolies.simps[of A] by simp

lemma outside_of_col_range_is_0:
  assumes "i < dim_row A" and "j \<ge> dim_col A"
  shows "coeff ((matrix_to_lpolies A)!i) j = 0"
  using outside_list_coeff0[of "col A i" j]
  by (metis assms(1) assms(2) index_row(2) length_rows matrix_to_lpolies.simps nth_map nth_rows outside_list_coeff0)

lemma polys_greater_col_zero:
  assumes "x \<in> set (matrix_to_lpolies A)"
  assumes "j \<ge> dim_col A"
  shows "coeff x j = 0"
  using  assms(1) assms(2) outside_of_col_range_is_0[of _ A j]
    assms(2) matrix_to_lpolies.simps by (metis in_set_conv_nth length_map length_rows)

lemma matrix_to_lp_vec_to_lpoly_row [simp]:
  assumes "i < dim_row A"
  shows "(matrix_to_lpolies A)!i = vec_to_lpoly (row A i)"
  by (simp add: assms)

lemma matrix_to_lpolies_coeff_access:
  assumes "i < dim_row A" and "j < dim_col A"
  shows "coeff (matrix_to_lpolies A ! i) j = A $$ (i,j)"
  using matrix_to_lp_vec_to_lpoly_row[of i A, OF assms(1)]
  by (metis assms(1) assms(2) index_row(1) index_row(2) vec_to_lin_poly_coeff_access)

text \<open> From linear polynomial list to matrix \<close>

definition lin_polies_to_mat where
    "lin_polies_to_mat lst = mat (length lst) (max_dim_poly_list lst) (\<lambda>(x,y).coeff (lst!x) y)"

lemma lin_polies_to_rat_mat_coeff_index:
  assumes "i < length L" and "j <  (max_dim_poly_list L)"
  shows "coeff (L ! i) j = (lin_polies_to_mat L) $$ (i,j)"
  unfolding lin_polies_to_mat_def by (simp add: assms(1) assms(2))

lemma vec_to_lpoly_valuate_equiv_dot_prod:
  assumes "dim_vec y = dim_vec x"  (* Can be \<ge> *)
  shows "(vec_to_lpoly y) \<lbrace> ($)x \<rbrace> = y \<bullet> x"
proof -
  let ?p = "vec_to_lpoly y"
  have 2: "?p\<lbrace> ($)x \<rbrace> = (\<Sum>j\<in>vars?p. coeff ?p j * x$j)"
    using eval_poly_with_sum[of ?p "($)x"] by blast
  have "vars ?p \<subseteq> {0..<dim_vec y}"
    using vars_subset_dim_vec_to_lpoly_dim by blast
    have 2: "?p\<lbrace> ($)x \<rbrace> = (\<Sum>j\<in>vars?p. coeff ?p j * x$j)"
    using eval_poly_with_sum[of ?p "($)x"] by blast
  also have *: "... = (\<Sum>i\<in>{0..<dim_poly ?p}. coeff ?p i * x$i)"
    using valuate_with_dim_poly by (metis (no_types, lifting) calculation sum.cong)
  also have "... = y \<bullet> x"
  proof -
    have "\<And>j. j < dim_vec x \<Longrightarrow> coeff (vec_to_lpoly y) j = y $ j"
      using assms vec_to_lin_poly_coeff_access by auto
    then show ?thesis
      using vec_to_lpoly_eval_dot_prod[of "y" "($)x"]
      by (metis assms calculation dim_vec index_vec vec_eq_iff)
    qed
  finally show ?thesis unfolding scalar_prod_def .
qed

lemma matrix_to_lpolies_valuate_scalarP:
  assumes "i < dim_row A"
assumes "dim_col A = dim_vec x"
shows "(matrix_to_lpolies A!i) \<lbrace> ($)x \<rbrace> = (row A i) \<bullet> x"
  using vec_to_lpoly_valuate_equiv_dot_prod[of "row A i" x]
  by (simp add: assms(1) assms(2))

end


(* Title: Examples/SML_Relativization/Foundations/Product_Type_Ext.thy
   Author: Mihails Milehins
   Copyright 2021 (C) Mihails Milehins
*)
section\<open>Extension of the theory \<^text>\<open>Product_Type_Ext\<close>\<close>
theory Product_Type_Ext
  imports Main
begin

context
  includes lifting_syntax
begin

lemma Sigma_transfer[transfer_rule]:
  assumes [transfer_rule]: "right_total A"
  shows
    "(rel_set A ===> (A ===> rel_set B) ===> rel_set (rel_prod A B))
      Sigma Sigma"
  unfolding Sigma_def by transfer_prover

end

text\<open>\newpage\<close>

end


(* IsageoCoq2_R1

Tarski_Euclidean_2D.thy

Version 2.2.0 IsaGeoCoq2_R1, Port part of GeoCoq 3.4.0
Version 2.1.0 IsaGeoCoq2_R1, Port part of GeoCoq 3.4.0
Copyright (C) 2021-2023 Roland Coghetto roland.coghetto ( a t ) cafr-msa2p.be
License: LGPGL

History
Version 1.0.0: IsaGeoCoq
Port part of GeoCoq 3.4.0 (https://geocoq.github.io/GeoCoq/) in Isabelle/Hol (Isabelle2021)

Copyright (C) 2021  Roland Coghetto roland_coghetto (at) hotmail.com

License: LGPL

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA
*)

theory Tarski_Euclidean_2D

imports
  Tarski_Neutral
  Tarski_Postulate_Parallels
  Tarski_Euclidean
  Tarski_2D

begin

locale Tarski_Euclidean_2D = Tarski_Euclidean +
  assumes upper_dim: "\<forall> a b c p q.
                      p \<noteq> q \<and>
                      Cong a p a q \<and>
                      Cong b p b q \<and>
                      Cong c p c q
                      \<longrightarrow>
                      (Bet a b c \<or> Bet b c a \<or> Bet c a b)"

sublocale Tarski_Euclidean_2D \<subseteq> Tarski_2D
proof
  show "\<forall> a b c p q.
                      p \<noteq> q \<and>
                      Cong a p a q \<and>
                      Cong b p b q \<and>
                      Cong c p c q
                      \<longrightarrow>
                      (Bet a b c \<or> Bet b c a \<or> Bet c a b)"
    using upper_dim by blast
qed

context Tarski_Euclidean_2D

begin

lemma l12_16_2D:
  assumes "A1 A2 Par B1 B2" and
    "X Inter A1 A2 C1 C2"
  shows "\<exists> Y. Y Inter B1 B2 C1 C2"
proof -
  have "Coplanar B1 B2 C1 C2"
    using all_coplanar by blast
  thus ?thesis
    using l12_16
    using assms(1) assms(2) by blast
qed

lemma par_inter:
  assumes "A B Par C D" and
    "\<not> A B Par P Q"
  shows "\<exists> Y. Col P Q Y \<and> Col C D Y"
  using all_coplanar assms(1) assms(2) cop_par__inter by blast

lemma not_par_inter:
  assumes "\<not>  A B Par A' B'"
  shows "\<exists> P. Col P X Y \<and> (Col P A B \<or> Col P A' B')"
proof -
  have "Coplanar A B X Y"
    by (simp add: all_coplanar)
  moreover
  have "Coplanar A' B' X Y"
    by (simp add: all_coplanar)
  ultimately
  show ?thesis
    by (simp add: assms cop2_npar__inter)
qed

lemma par_perp__perp:
  assumes "A B Par C D" and
    "A B Perp P Q"
  shows "C D Perp P Q"
  using all_coplanar assms(1) assms(2) cop_par_perp__perp by blast

lemma par_perp2__par:
  assumes "A B Par C D" and
    "A B Perp E F" and
    "C D Perp G H"
  shows "E F Par G H"
  using all_coplanar assms(1) assms(2) assms(3) cop4_par_perp2__par by blast

lemma perp3__perp:
  assumes "A B Perp B C" and
    "B C Perp C D" and
    "C D Perp D A"
  shows "D A Perp A B"
proof -
  have "Coplanar A B C D"
    by (simp add: all_coplanar)
  thus ?thesis
    using assms(1) assms(2) assms(3) cop_perp3__perp by blast
qed

lemma perp3__rect:
  assumes "A B Perp B C" and
    "B C Perp C D" and
    "C D Perp D A"
  shows "Rectangle A B C D"
proof -
  have "Coplanar A B C D"
    by (simp add: all_coplanar)
  thus ?thesis
    using assms(1) assms(2) assms(3) cop_perp3__rect by blast
qed

end
end