section \<open>Index-based manipulation of lists\<close>

theory List_Index imports Main begin

text \<open>\noindent
This theory collects functions for index-based manipulation of lists.
\<close>

subsection \<open>Finding an index\<close>

text \<open>
This subsection defines three functions for finding the index of items in a list:
\begin{description}
\item[\<open>find_index P xs\<close>] finds the index of the first element in
 \<open>xs\<close> that satisfies \<open>P\<close>.
\item[\<open>index xs x\<close>] finds the index of the first occurrence of
 \<open>x\<close> in \<open>xs\<close>.
\item[\<open>last_index xs x\<close>] finds the index of the last occurrence of
 \<open>x\<close> in \<open>xs\<close>.
\end{description}
All functions return @{term "length xs"} if \<open>xs\<close> does not contain a
suitable element.

The argument order of \<open>find_index\<close> follows the function of the same
name in the Haskell standard library. For \<open>index\<close> (and \<open>last_index\<close>) the order is intentionally reversed: \<open>index\<close> maps
lists to a mapping from elements to their indices, almost the inverse of
function \<open>nth\<close>.\<close>

primrec find_index :: "('a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> nat" where
"find_index _ [] = 0" |
"find_index P (x#xs) = (if P x then 0 else find_index P xs + 1)"

definition index :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
"index xs = (\<lambda>a. find_index (\<lambda>x. x=a) xs)"

definition last_index :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
"last_index xs x =
 (let i = index (rev xs) x; n = size xs
  in if i = n then i else n - (i+1))"

lemma find_index_append: "find_index P (xs @ ys) =
  (if \<exists>x\<in>set xs. P x then find_index P xs else size xs + find_index P ys)"
  by (induct xs) simp_all

lemma find_index_le_size[simp]: "find_index P xs <= size xs"
by(induct xs) simp_all

lemma index_le_size: "index xs x <= size xs"
by(simp add: index_def find_index_le_size)

lemma last_index_le_size: "last_index xs x <= size xs"
by(simp add: last_index_def Let_def index_le_size)

lemma index_Nil[simp]: "index [] a = 0"
by(simp add: index_def)

lemma index_Cons[simp]: "index (x#xs) a = (if x=a then 0 else index xs a + 1)"
by(simp add: index_def)

lemma index_append: "index (xs @ ys) x =
  (if x : set xs then index xs x else size xs + index ys x)"
by (induct xs) simp_all

lemma index_conv_size_if_notin[simp]: "x \<notin> set xs \<Longrightarrow> index xs x = size xs"
by (induct xs) auto

lemma find_index_eq_size_conv:
  "size xs = n \<Longrightarrow> (find_index P xs = n) = (\<forall>x \<in> set xs. ~ P x)"
by(induct xs arbitrary: n) auto

lemma size_eq_find_index_conv:
  "size xs = n \<Longrightarrow> (n = find_index P xs) = (\<forall>x \<in> set xs. ~ P x)"
by(metis find_index_eq_size_conv)

lemma index_size_conv: "size xs = n \<Longrightarrow> (index xs x = n) = (x \<notin> set xs)"
by(auto simp: index_def find_index_eq_size_conv)

lemma size_index_conv: "size xs = n \<Longrightarrow> (n = index xs x) = (x \<notin> set xs)"
by (metis index_size_conv)

lemma last_index_size_conv:
  "size xs = n \<Longrightarrow> (last_index xs x = n) = (x \<notin> set xs)"
apply(auto simp: last_index_def index_size_conv)
apply(drule length_pos_if_in_set)
apply arith
done

lemma size_last_index_conv:
  "size xs = n \<Longrightarrow> (n = last_index xs x) = (x \<notin> set xs)"
by (metis last_index_size_conv)

lemma find_index_less_size_conv:
  "(find_index P xs < size xs) = (\<exists>x \<in> set xs. P x)"
by (induct xs) auto

lemma index_less_size_conv:
  "(index xs x < size xs) = (x \<in> set xs)"
by(auto simp: index_def find_index_less_size_conv)

lemma last_index_less_size_conv:
  "(last_index xs x < size xs) = (x : set xs)"
by(simp add: last_index_def Let_def index_size_conv length_pos_if_in_set
        del:length_greater_0_conv)

lemma index_less[simp]:
  "x : set xs \<Longrightarrow> size xs <= n \<Longrightarrow> index xs x < n"
apply(induct xs) apply auto
apply (metis index_less_size_conv less_eq_Suc_le less_trans_Suc)
done

lemma last_index_less[simp]:
  "x : set xs \<Longrightarrow> size xs <= n \<Longrightarrow> last_index xs x < n"
by(simp add: last_index_less_size_conv[symmetric])

lemma last_index_Cons: "last_index (x#xs) y =
  (if x=y then
      if x \<in> set xs then last_index xs y + 1 else 0
   else last_index xs y + 1)"
using index_le_size[of "rev xs" y]
apply(auto simp add: last_index_def index_append Let_def)
apply(simp add: index_size_conv)
done

lemma last_index_append: "last_index (xs @ ys) x =
  (if x : set ys then size xs + last_index ys x
   else if x : set xs then last_index xs x else size xs + size ys)"
by (induct xs) (simp_all add: last_index_Cons last_index_size_conv)

lemma last_index_Snoc[simp]:
  "last_index (xs @ [x]) y =
  (if x=y then size xs
   else if y : set xs then last_index xs y else size xs + 1)"
by(simp add: last_index_append last_index_Cons)

lemma nth_find_index: "find_index P xs < size xs \<Longrightarrow> P(xs ! find_index P xs)"
by (induct xs) auto

lemma nth_index[simp]: "x \<in> set xs \<Longrightarrow> xs ! index xs x = x"
by (induct xs) auto

lemma nth_last_index[simp]: "x \<in> set xs \<Longrightarrow> xs ! last_index xs x = x"
by(simp add:last_index_def index_size_conv Let_def rev_nth[symmetric])

lemma index_rev: "\<lbrakk> distinct xs; x \<in> set xs \<rbrakk> \<Longrightarrow>
  index (rev xs) x = length xs - index xs x - 1"
by (induct xs) (auto simp: index_append)

lemma index_nth_id:
  "\<lbrakk> distinct xs;  n < length xs \<rbrakk> \<Longrightarrow> index xs (xs ! n) = n"
by (metis in_set_conv_nth index_less_size_conv nth_eq_iff_index_eq nth_index)

lemma index_upt[simp]: "m \<le> i \<Longrightarrow> i < n \<Longrightarrow> index [m..<n] i = i-m"
by (induction n) (auto simp add: index_append)

lemma index_eq_index_conv[simp]: "x \<in> set xs \<or> y \<in> set xs \<Longrightarrow>
  (index xs x = index xs y) = (x = y)"
by (induct xs) auto

lemma last_index_eq_index_conv[simp]: "x \<in> set xs \<or> y \<in> set xs \<Longrightarrow>
  (last_index xs x = last_index xs y) = (x = y)"
by (induct xs) (auto simp:last_index_Cons)

lemma inj_on_index: "inj_on (index xs) (set xs)"
by (simp add:inj_on_def)

lemma inj_on_index2: "I \<subseteq> set xs \<Longrightarrow> inj_on (index xs) I"
by (rule inj_onI) auto

lemma inj_on_last_index: "inj_on (last_index xs) (set xs)"
by (simp add:inj_on_def)

lemma find_index_conv_takeWhile:
  "find_index P xs = size(takeWhile (Not o P) xs)"
by(induct xs) auto

lemma index_conv_takeWhile: "index xs x = size(takeWhile (\<lambda>y. x\<noteq>y) xs)"
by(induct xs) auto

lemma find_index_first: "i < find_index P xs \<Longrightarrow> \<not>P (xs!i)"
unfolding find_index_conv_takeWhile
by (metis comp_apply nth_mem set_takeWhileD takeWhile_nth)

lemma index_first: "i<index xs x \<Longrightarrow> x\<noteq>xs!i"
using find_index_first unfolding index_def by blast

lemma find_index_eqI:
  assumes "i\<le>length xs"
  assumes "\<forall>j<i. \<not>P (xs!j)"
  assumes "i<length xs \<Longrightarrow> P (xs!i)"
  shows "find_index P xs = i"
by (metis (mono_tags, lifting) antisym_conv2 assms find_index_eq_size_conv
  find_index_first find_index_less_size_conv linorder_neqE_nat nth_find_index)

lemma find_index_eq_iff:
  "find_index P xs = i
  \<longleftrightarrow> (i\<le>length xs \<and> (\<forall>j<i. \<not>P (xs!j)) \<and> (i<length xs \<longrightarrow> P (xs!i)))"
by (auto intro: find_index_eqI
         simp: nth_find_index find_index_le_size find_index_first)

lemma find_index_property:
  "find_index P xs \<le> length xs \<and> (\<forall>j < find_index P xs. \<not>P (xs ! j)) \<and>
    (find_index P xs < length xs \<longrightarrow> P (xs ! find_index P xs))"
  by (meson find_index_eq_iff)

lemma index_eqI:
  assumes "i\<le>length xs"
  assumes "\<forall>j<i. xs!j \<noteq> x"
  assumes "i<length xs \<Longrightarrow> xs!i = x"
  shows "index xs x = i"
unfolding index_def by (simp add: find_index_eqI assms)

lemma index_eq_iff:
  "index xs x = i
  \<longleftrightarrow> (i\<le>length xs \<and> (\<forall>j<i. xs!j \<noteq> x) \<and> (i<length xs \<longrightarrow> xs!i = x))"
by (auto intro: index_eqI
         simp: index_le_size index_less_size_conv
         dest: index_first)

lemma index_take: "index xs x >= i \<Longrightarrow> x \<notin> set(take i xs)"
apply(subst (asm) index_conv_takeWhile)
apply(subgoal_tac "set(take i xs) <= set(takeWhile ((\<noteq>) x) xs)")
 apply(blast dest: set_takeWhileD)
apply(metis set_take_subset_set_take takeWhile_eq_take)
done

lemma last_index_drop:
  "last_index xs x < i \<Longrightarrow> x \<notin> set(drop i xs)"
apply(subgoal_tac "set(drop i xs) = set(take (size xs - i) (rev xs))")
 apply(simp add: last_index_def index_take Let_def split:if_split_asm)
apply (metis rev_drop set_rev)
done

lemma set_take_if_index: assumes "index xs x < i" and "i \<le> length xs"
shows "x \<in> set (take i xs)"
proof -
  have "index (take i xs @ drop i xs) x < i"
    using append_take_drop_id[of i xs] assms(1) by simp
  thus ?thesis using assms(2)
    by(simp add:index_append del:append_take_drop_id split: if_splits)
qed

lemma index_take_if_index:
assumes "index xs x \<le> n" shows "index (take n xs) x = index xs x"
proof cases
  assume "x : set(take n xs)" with assms show ?thesis
    by (metis append_take_drop_id index_append)
next
  assume "x \<notin> set(take n xs)" with assms show ?thesis
   by (metis order_le_less set_take_if_index le_cases length_take min_def size_index_conv take_all)
qed

lemma index_take_if_set:
  "x : set(take n xs) \<Longrightarrow> index (take n xs) x = index xs x"
by (metis index_take index_take_if_index linear)

lemma index_update_if_diff2:
  "n < length xs \<Longrightarrow> x \<noteq> xs!n \<Longrightarrow> x \<noteq> y \<Longrightarrow> index (xs[n := y]) x = index xs x"
by(subst (2) id_take_nth_drop[of n xs])
  (auto simp: upd_conv_take_nth_drop index_append min_def)

lemma set_drop_if_index: "distinct xs \<Longrightarrow> index xs x < i \<Longrightarrow> x \<notin> set(drop i xs)"
by (metis in_set_dropD index_nth_id last_index_drop last_index_less_size_conv nth_last_index)

lemma index_swap_if_distinct: assumes "distinct xs" "i < size xs" "j < size xs"
shows "index (xs[i := xs!j, j := xs!i]) x =
  (if x = xs!i then j else if x = xs!j then i else index xs x)"
proof-
  have "distinct(xs[i := xs!j, j := xs!i])" using assms by simp
  with assms show ?thesis
    apply (auto simp: swap_def simp del: distinct_swap)
    apply (metis index_nth_id list_update_same_conv)
    apply (metis (erased, hide_lams) index_nth_id length_list_update list_update_swap nth_list_update_eq)
    apply (metis index_nth_id length_list_update nth_list_update_eq)
    by (metis index_update_if_diff2 length_list_update nth_list_update)
qed

lemma bij_betw_index:
  "distinct xs \<Longrightarrow> X = set xs \<Longrightarrow> l = size xs \<Longrightarrow> bij_betw (index xs) X {0..<l}"
apply simp
apply(rule bij_betw_imageI[OF inj_on_index])
by (auto simp: image_def) (metis index_nth_id nth_mem)

lemma index_image: "distinct xs \<Longrightarrow> set xs = X \<Longrightarrow> index xs ` X = {0..<size xs}"
by (simp add: bij_betw_imp_surj_on bij_betw_index)

lemma index_map_inj_on:
  "\<lbrakk> inj_on f S; y \<in> S; set xs \<subseteq> S \<rbrakk> \<Longrightarrow> index (map f xs) (f y) = index xs y"
by (induct xs) (auto simp: inj_on_eq_iff)

lemma index_map_inj: "inj f \<Longrightarrow> index (map f xs) (f y) = index xs y"
by (simp add: index_map_inj_on[where S=UNIV])

subsection \<open>Map with index\<close>

primrec map_index' :: "nat \<Rightarrow> (nat \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a list \<Rightarrow> 'b list" where
  "map_index' n f [] = []"
| "map_index' n f (x#xs) = f n x # map_index' (Suc n) f xs"

lemma length_map_index'[simp]: "length (map_index' n f xs) = length xs"
  by (induct xs arbitrary: n) auto

lemma map_index'_map_zip: "map_index' n f xs = map (case_prod f) (zip [n ..< n + length xs] xs)"
proof (induct xs arbitrary: n)
  case (Cons x xs)
  hence "map_index' n f (x#xs) = f n x # map (case_prod f) (zip [Suc n ..< n + length (x # xs)] xs)" by simp
  also have "\<dots> =  map (case_prod f) (zip (n # [Suc n ..< n + length (x # xs)]) (x # xs))" by simp
  also have "(n # [Suc n ..< n + length (x # xs)]) = [n ..< n + length (x # xs)]" by (induct xs) auto
  finally show ?case by simp
qed simp

abbreviation "map_index \<equiv> map_index' 0"

lemmas map_index = map_index'_map_zip[of 0, simplified]

lemma take_map_index: "take p (map_index f xs) = map_index f (take p xs)"
  unfolding map_index by (auto simp: min_def take_map take_zip)

lemma drop_map_index: "drop p (map_index f xs) = map_index' p f (drop p xs)"
  unfolding map_index'_map_zip by (cases "p < length xs") (auto simp: drop_map drop_zip)

lemma map_map_index[simp]: "map g (map_index f xs) = map_index (\<lambda>n x. g (f n x)) xs"
  unfolding map_index by auto

lemma map_index_map[simp]: "map_index f (map g xs) = map_index (\<lambda>n x. f n (g x)) xs"
  unfolding map_index by (auto simp: map_zip_map2)

lemma set_map_index[simp]: "x \<in> set (map_index f xs) = (\<exists>i < length xs. f i (xs ! i) = x)"
  unfolding map_index by (auto simp: set_zip intro!: image_eqI[of _ "case_prod f"])

lemma set_map_index'[simp]: "x\<in>set (map_index' n f xs)
  \<longleftrightarrow> (\<exists>i<length xs. f (n+i) (xs!i) = x) "
  unfolding map_index'_map_zip
  by (auto simp: set_zip intro!: image_eqI[of _ "case_prod f"])

lemma nth_map_index[simp]: "p < length xs \<Longrightarrow> map_index f xs ! p = f p (xs ! p)"
  unfolding map_index by auto

lemma map_index_cong:
  "\<forall>p < length xs. f p (xs ! p) = g p (xs ! p) \<Longrightarrow> map_index f xs = map_index g xs"
  unfolding map_index by (auto simp: set_zip)

lemma map_index_id: "map_index (curry snd) xs = xs"
  unfolding map_index by auto

lemma map_index_no_index[simp]: "map_index (\<lambda>n x. f x) xs = map f xs"
  unfolding map_index by (induct xs rule: rev_induct) auto

lemma map_index_congL:
  "\<forall>p < length xs. f p (xs ! p) = xs ! p \<Longrightarrow> map_index f xs = xs"
  by (rule trans[OF map_index_cong map_index_id]) auto

lemma map_index'_is_NilD: "map_index' n f xs = [] \<Longrightarrow> xs = []"
  by (induct xs) auto

declare map_index'_is_NilD[of 0, dest!]

lemma map_index'_is_ConsD:
  "map_index' n f xs = y # ys \<Longrightarrow> \<exists>z zs. xs = z # zs \<and> f n z = y \<and> map_index' (n + 1) f zs = ys"
  by (induct xs arbitrary: n) auto

lemma map_index'_eq_imp_length_eq: "map_index' n f xs = map_index' n g ys \<Longrightarrow> length xs = length ys"
proof (induct ys arbitrary: xs n)
  case (Cons y ys) thus ?case by (cases xs) auto
qed (auto dest!: map_index'_is_NilD)

lemmas map_index_eq_imp_length_eq = map_index'_eq_imp_length_eq[of 0]

lemma map_index'_comp[simp]: "map_index' n f (map_index' n g xs) = map_index' n (\<lambda>n. f n o g n) xs"
  by (induct xs arbitrary: n) auto

lemma map_index'_append[simp]: "map_index' n f (a @ b)
  = map_index' n f a @ map_index' (n + length a) f b"
  by (induct a arbitrary: n) auto

lemma map_index_append[simp]: "map_index f (a @ b)
  = map_index f a @ map_index' (length a) f b"
  using map_index'_append[where n=0]
  by (simp del: map_index'_append)

subsection \<open>Insert at position\<close>

primrec insert_nth :: "nat \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "insert_nth 0 x xs = x # xs"
| "insert_nth (Suc n) x xs = (case xs of [] \<Rightarrow> [x] | y # ys \<Rightarrow> y # insert_nth n x ys)"

lemma insert_nth_take_drop[simp]: "insert_nth n x xs = take n xs @ [x] @ drop n xs"
proof (induct n arbitrary: xs)
  case Suc thus ?case by (cases xs) auto
qed simp

lemma length_insert_nth: "length (insert_nth n x xs) = Suc (length xs)"
  by (induct xs) auto

lemma set_insert_nth:
  "set (insert_nth i x xs) = insert x (set xs)"
by (simp add: set_append[symmetric])

lemma distinct_insert_nth:
  assumes "distinct xs"
  assumes "x \<notin> set xs"
  shows "distinct (insert_nth i x xs)"
using assms proof (induct xs arbitrary: i)
  case Nil
  then show ?case by (cases i) auto
next
  case (Cons a xs)
  then show ?case
    by (cases i) (auto simp add: set_insert_nth simp del: insert_nth_take_drop)
qed

lemma nth_insert_nth_front:
  assumes "i < j" "j \<le> length xs"
  shows "insert_nth j x xs ! i = xs ! i"
using assms by (simp add: nth_append)

lemma nth_insert_nth_index_eq:
  assumes "i \<le> length xs"
  shows "insert_nth i x xs ! i = x"
using assms by (simp add: nth_append)

lemma nth_insert_nth_back:
  assumes "j < i" "i \<le> length xs"
  shows "insert_nth j x xs ! i = xs ! (i - 1)"
using assms by (cases i) (auto simp add: nth_append min_def)

lemma nth_insert_nth:
  assumes "i \<le> length xs" "j \<le> length xs"
  shows "insert_nth j x xs ! i = (if i = j then x else if i < j then xs ! i else xs ! (i - 1))"
using assms by (simp add: nth_insert_nth_front nth_insert_nth_index_eq nth_insert_nth_back del: insert_nth_take_drop)

lemma insert_nth_inverse:
  assumes "j \<le> length xs" "j' \<le> length xs'"
  assumes "x \<notin> set xs" "x \<notin> set xs'"
  assumes "insert_nth j x xs = insert_nth j' x xs'"
  shows "j = j'"
proof -
  from assms(1,3) have "\<forall>i\<le>length xs. insert_nth j x xs ! i = x \<longleftrightarrow> i = j"
    by (auto simp add: nth_insert_nth simp del: insert_nth_take_drop)
  moreover from assms(2,4) have "\<forall>i\<le>length xs'. insert_nth j' x xs' ! i = x \<longleftrightarrow> i = j'"
    by (auto simp add: nth_insert_nth simp del: insert_nth_take_drop)
  ultimately show "j = j'"
    using assms(1,2,5) by (metis dual_order.trans nat_le_linear)
qed

text \<open>Insert several elements at given (ascending) positions\<close>

lemma length_fold_insert_nth:
  "length (fold (\<lambda>(p, b). insert_nth p b) pxs xs) = length xs + length pxs"
  by (induct pxs arbitrary: xs) auto

lemma invar_fold_insert_nth:
  "\<lbrakk>\<forall>x\<in>set pxs. p < fst x; p < length xs; xs ! p = b\<rbrakk> \<Longrightarrow>
    fold (\<lambda>(x, y). insert_nth x y) pxs xs ! p = b"
  by (induct pxs arbitrary: xs) (auto simp: nth_append)

lemma nth_fold_insert_nth:
  "\<lbrakk>sorted (map fst pxs); distinct (map fst pxs); \<forall>(p, b) \<in> set pxs. p < length xs + length pxs;
    i < length pxs; pxs ! i = (p, b)\<rbrakk> \<Longrightarrow>
  fold (\<lambda>(p, b). insert_nth p b) pxs xs ! p = b"
proof (induct pxs arbitrary: xs i p b)
  case (Cons pb pxs)
  show ?case
  proof (cases i)
    case 0
    with Cons.prems have "p < Suc (length xs)"
    proof (induct pxs rule: rev_induct)
      case (snoc pb' pxs)
      then obtain p' b' where "pb' = (p', b')" by auto
      with snoc.prems have "\<forall>p \<in> fst ` set pxs. p < p'" "p' \<le> Suc (length xs + length pxs)"
        by (auto simp: image_iff sorted_append le_eq_less_or_eq)
      with snoc.prems show ?case by (intro snoc(1)) (auto simp: sorted_append)
    qed auto
    with 0 Cons.prems show ?thesis unfolding fold.simps o_apply
    by (intro invar_fold_insert_nth) (auto simp: image_iff le_eq_less_or_eq nth_append)
  next
    case (Suc n) with Cons.prems show ?thesis unfolding fold.simps
      by (auto intro!: Cons(1))
  qed
qed simp

subsection \<open>Remove at position\<close>

fun remove_nth :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a list"
where
  "remove_nth i [] = []"
| "remove_nth 0 (x # xs) = xs"
| "remove_nth (Suc i) (x # xs) = x # remove_nth i xs"

lemma remove_nth_take_drop:
  "remove_nth i xs = take i xs @ drop (Suc i) xs"
proof (induct xs arbitrary: i)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case by (cases i) auto
qed

lemma remove_nth_insert_nth:
  assumes "i \<le> length xs"
  shows "remove_nth i (insert_nth i x xs) = xs"
using assms proof (induct xs arbitrary: i)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case by (cases i) auto
qed

lemma insert_nth_remove_nth:
  assumes "i < length xs"
  shows "insert_nth i (xs ! i) (remove_nth i xs) = xs"
using assms proof (induct xs arbitrary: i)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case by (cases i) auto
qed

lemma length_remove_nth:
  assumes "i < length xs"
  shows "length (remove_nth i xs) = length xs - 1"
using assms unfolding remove_nth_take_drop by simp

lemma set_remove_nth_subset:
  "set (remove_nth j xs) \<subseteq> set xs"
proof (induct xs arbitrary: j)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case by (cases j) auto
qed

lemma set_remove_nth:
  assumes "distinct xs" "j < length xs"
  shows "set (remove_nth j xs) = set xs - {xs ! j}"
using assms proof (induct xs arbitrary: j)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case by (cases j) auto
qed

lemma distinct_remove_nth:
  assumes "distinct xs"
  shows "distinct (remove_nth i xs)"
using assms proof (induct xs arbitrary: i)
  case Nil
  then show ?case by simp
next
  case (Cons a xs)
  then show ?case
    by (cases i) (auto simp add: set_remove_nth_subset rev_subsetD)
qed

lemma find_index_sorted_le[simp]: "sorted xs \<Longrightarrow> i < length xs \<Longrightarrow> xs ! i < x \<Longrightarrow> i < find_index ((\<le>) x) xs"
    and find_index_sorted_leq[simp]: "sorted xs \<Longrightarrow> i < length xs \<Longrightarrow> x \<le> xs ! i \<Longrightarrow> find_index ((\<le>) x) xs \<le> i"
  unfolding sorted_iff_nth_mono
  by (metis less_le_trans linorder_neqE_nat not_le find_index_property find_index_property)+

end


(* Author: Tobias Nipkow *)

section \<open>Creating Almost Complete Trees\<close>

theory Balance
imports
  "HOL-Library.Tree_Real"
begin

fun bal :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a tree * 'a list" where
"bal n xs = (if n=0 then (Leaf,xs) else
 (let m = n div 2;
      (l, ys) = bal m xs;
      (r, zs) = bal (n-1-m) (tl ys)
  in (Node l (hd ys) r, zs)))"

declare bal.simps[simp del]
declare Let_def[simp]

definition bal_list :: "nat \<Rightarrow> 'a list \<Rightarrow> 'a tree" where
"bal_list n xs = fst (bal n xs)"

definition balance_list :: "'a list \<Rightarrow> 'a tree" where
"balance_list xs = bal_list (length xs) xs"

definition bal_tree :: "nat \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"bal_tree n t = bal_list n (inorder t)"

definition balance_tree :: "'a tree \<Rightarrow> 'a tree" where
"balance_tree t = bal_tree (size t) t"

lemma bal_simps:
  "bal 0 xs = (Leaf, xs)"
  "n > 0 \<Longrightarrow>
   bal n xs =
  (let m = n div 2;
      (l, ys) = bal m xs;
      (r, zs) = bal (n-1-m) (tl ys)
  in (Node l (hd ys) r, zs))"
by(simp_all add: bal.simps)

lemma bal_inorder:
  "\<lbrakk> n \<le> length xs; bal n xs = (t,zs) \<rbrakk>
  \<Longrightarrow> xs = inorder t @ zs \<and> size t = n"
proof(induction n arbitrary: xs t zs rule: less_induct)
  case (less n) show ?case
  proof cases
    assume "n = 0" thus ?thesis using less.prems by (simp add: bal_simps)
  next
    assume [arith]: "n \<noteq> 0"
    let ?m = "n div 2" let ?m' = "n - 1 - ?m"
    from less.prems(2) obtain l r ys where
      b1: "bal ?m xs = (l,ys)" and
      b2: "bal ?m' (tl ys) = (r,zs)" and
      t: "t = \<langle>l, hd ys, r\<rangle>"
      by(auto simp: bal_simps split: prod.splits)
    have IH1: "xs = inorder l @ ys \<and> size l = ?m"
      using b1 less.prems(1) by(intro less.IH) auto
    have IH2: "tl ys = inorder r @ zs \<and> size r = ?m'"
      using  b2 IH1 less.prems(1) by(intro less.IH) auto
    show ?thesis using t IH1 IH2 less.prems(1) hd_Cons_tl[of ys] by fastforce
  qed
qed

corollary inorder_bal_list[simp]:
  "n \<le> length xs \<Longrightarrow> inorder(bal_list n xs) = take n xs"
unfolding bal_list_def
by (metis (mono_tags) prod.collapse[of "bal n xs"] append_eq_conv_conj bal_inorder length_inorder)

corollary inorder_balance_list[simp]: "inorder(balance_list xs) = xs"
by(simp add: balance_list_def)

corollary inorder_bal_tree:
  "n \<le> size t \<Longrightarrow> inorder(bal_tree n t) = take n (inorder t)"
by(simp add: bal_tree_def)

corollary inorder_balance_tree[simp]: "inorder(balance_tree t) = inorder t"
by(simp add: balance_tree_def inorder_bal_tree)

text\<open>The length/size lemmas below do not require the precondition @{prop"n \<le> length xs"}
(or  @{prop"n \<le> size t"}) that they come with. They could take advantage of the fact
that @{term "bal xs n"} yields a result even if @{prop "n > length xs"}.
In that case the result will contain one or more occurrences of @{term "hd []"}.
However, this is counter-intuitive and does not reflect the execution
in an eager functional language.\<close>

lemma bal_length: "\<lbrakk> n \<le> length xs; bal n xs = (t,zs) \<rbrakk> \<Longrightarrow> length zs = length xs - n"
using bal_inorder by fastforce

corollary size_bal_list[simp]: "n \<le> length xs \<Longrightarrow> size(bal_list n xs) = n"
unfolding bal_list_def using bal_inorder prod.exhaust_sel by blast

corollary size_balance_list[simp]: "size(balance_list xs) = length xs"
by (simp add: balance_list_def)

corollary size_bal_tree[simp]: "n \<le> size t \<Longrightarrow> size(bal_tree n t) = n"
by(simp add: bal_tree_def)

corollary size_balance_tree[simp]: "size(balance_tree t) = size t"
by(simp add: balance_tree_def)

lemma min_height_bal:
  "\<lbrakk> n \<le> length xs; bal n xs = (t,zs) \<rbrakk> \<Longrightarrow> min_height t = nat(\<lfloor>log 2 (n + 1)\<rfloor>)"
proof(induction n arbitrary: xs t zs rule: less_induct)
  case (less n)
  show ?case
  proof cases
    assume "n = 0" thus ?thesis using less.prems(2) by (simp add: bal_simps)
  next
    assume [arith]: "n \<noteq> 0"
    let ?m = "n div 2" let ?m' = "n - 1 - ?m"
    from less.prems obtain l r ys where
      b1: "bal ?m xs = (l,ys)" and
      b2: "bal ?m' (tl ys) = (r,zs)" and
      t: "t = \<langle>l, hd ys, r\<rangle>"
      by(auto simp: bal_simps split: prod.splits)
    let ?hl = "nat (floor(log 2 (?m + 1)))"
    let ?hr = "nat (floor(log 2 (?m' + 1)))"
    have IH1: "min_height l = ?hl" using less.IH[OF _ _ b1] less.prems(1) by simp
    have IH2: "min_height r = ?hr"
      using less.prems(1) bal_length[OF _ b1] b2 by(intro less.IH) auto
    have "(n+1) div 2 \<ge> 1" by arith
    hence 0: "log 2 ((n+1) div 2) \<ge> 0" by simp
    have "?m' \<le> ?m" by arith
    hence le: "?hr \<le> ?hl" by(simp add: nat_mono floor_mono)
    have "min_height t = min ?hl ?hr + 1" by (simp add: t IH1 IH2)
    also have "\<dots> = ?hr + 1" using le by (simp add: min_absorb2)
    also have "?m' + 1 = (n+1) div 2" by linarith
    also have "nat (floor(log 2 ((n+1) div 2))) + 1
       = nat (floor(log 2 ((n+1) div 2) + 1))"
      using 0 by linarith
    also have "\<dots> = nat (floor(log 2 (n + 1)))"
      using floor_log2_div2[of "n+1"] by (simp add: log_mult)
    finally show ?thesis .
  qed
qed

lemma height_bal:
  "\<lbrakk> n \<le> length xs; bal n xs = (t,zs) \<rbrakk> \<Longrightarrow> height t = nat \<lceil>log 2 (n + 1)\<rceil>"
proof(induction n arbitrary: xs t zs rule: less_induct)
  case (less n) show ?case
  proof cases
    assume "n = 0" thus ?thesis
      using less.prems by (simp add: bal_simps)
  next
    assume [arith]: "n \<noteq> 0"
    let ?m = "n div 2" let ?m' = "n - 1 - ?m"
    from less.prems obtain l r ys where
      b1: "bal ?m xs = (l,ys)" and
      b2: "bal ?m' (tl ys) = (r,zs)" and
      t: "t = \<langle>l, hd ys, r\<rangle>"
      by(auto simp: bal_simps split: prod.splits)
    let ?hl = "nat \<lceil>log 2 (?m + 1)\<rceil>"
    let ?hr = "nat \<lceil>log 2 (?m' + 1)\<rceil>"
    have IH1: "height l = ?hl" using less.IH[OF _ _ b1] less.prems(1) by simp
    have IH2: "height r = ?hr"
      using b2 bal_length[OF _ b1] less.prems(1) by(intro less.IH) auto
    have 0: "log 2 (?m + 1) \<ge> 0" by simp
    have "?m' \<le> ?m" by arith
    hence le: "?hr \<le> ?hl"
      by(simp add: nat_mono ceiling_mono del: nat_ceiling_le_eq)
    have "height t = max ?hl ?hr + 1" by (simp add: t IH1 IH2)
    also have "\<dots> = ?hl + 1" using le by (simp add: max_absorb1)
    also have "\<dots> = nat \<lceil>log 2 (?m + 1) + 1\<rceil>" using 0 by linarith
    also have "\<dots> = nat \<lceil>log 2 (n + 1)\<rceil>"
      using ceiling_log2_div2[of "n+1"] by (simp)
    finally show ?thesis .
  qed
qed

lemma acomplete_bal:
  assumes "n \<le> length xs" "bal n xs = (t,ys)" shows "acomplete t"
unfolding acomplete_def
using height_bal[OF assms] min_height_bal[OF assms]
by linarith

lemma height_bal_list:
  "n \<le> length xs \<Longrightarrow> height (bal_list n xs) = nat \<lceil>log 2 (n + 1)\<rceil>"
unfolding bal_list_def by (metis height_bal prod.collapse)

lemma height_balance_list:
  "height (balance_list xs) = nat \<lceil>log 2 (length xs + 1)\<rceil>"
by (simp add: balance_list_def height_bal_list)

corollary height_bal_tree:
  "n \<le> size t \<Longrightarrow> height (bal_tree n t) = nat\<lceil>log 2 (n + 1)\<rceil>"
unfolding bal_list_def bal_tree_def
by (metis bal_list_def height_bal_list length_inorder)

corollary height_balance_tree:
  "height (balance_tree t) = nat\<lceil>log 2 (size t + 1)\<rceil>"
by (simp add: bal_tree_def balance_tree_def height_bal_list)

corollary acomplete_bal_list[simp]: "n \<le> length xs \<Longrightarrow> acomplete (bal_list n xs)"
unfolding bal_list_def by (metis  acomplete_bal prod.collapse)

corollary acomplete_balance_list[simp]: "acomplete (balance_list xs)"
by (simp add: balance_list_def)

corollary acomplete_bal_tree[simp]: "n \<le> size t \<Longrightarrow> acomplete (bal_tree n t)"
by (simp add: bal_tree_def)

corollary acomplete_balance_tree[simp]: "acomplete (balance_tree t)"
by (simp add: balance_tree_def)

lemma wbalanced_bal: "\<lbrakk> n \<le> length xs; bal n xs = (t,ys) \<rbrakk> \<Longrightarrow> wbalanced t"
proof(induction n arbitrary: xs t ys rule: less_induct)
  case (less n)
  show ?case
  proof cases
    assume "n = 0"
    thus ?thesis using less.prems(2) by(simp add: bal_simps)
  next
    assume [arith]: "n \<noteq> 0"
    with less.prems obtain l ys r zs where
      rec1: "bal (n div 2) xs = (l, ys)" and
      rec2: "bal (n - 1 - n div 2) (tl ys) = (r, zs)" and
      t: "t = \<langle>l, hd ys, r\<rangle>"
      by(auto simp add: bal_simps split: prod.splits)
    have l: "wbalanced l" using less.IH[OF _ _ rec1] less.prems(1) by linarith
    have "wbalanced r"
      using rec1 rec2 bal_length[OF _ rec1] less.prems(1) by(intro less.IH) auto
    with l t bal_length[OF _ rec1] less.prems(1) bal_inorder[OF _ rec1] bal_inorder[OF _ rec2]
    show ?thesis by auto
  qed
qed

text\<open>An alternative proof via @{thm acomplete_if_wbalanced}:\<close>
lemma "\<lbrakk> n \<le> length xs; bal n xs = (t,ys) \<rbrakk> \<Longrightarrow> acomplete t"
by(rule acomplete_if_wbalanced[OF wbalanced_bal])

lemma wbalanced_bal_list[simp]: "n \<le> length xs \<Longrightarrow> wbalanced (bal_list n xs)"
by(simp add: bal_list_def) (metis prod.collapse wbalanced_bal)

lemma wbalanced_balance_list[simp]: "wbalanced (balance_list xs)"
by(simp add: balance_list_def)

lemma wbalanced_bal_tree[simp]: "n \<le> size t \<Longrightarrow> wbalanced (bal_tree n t)"
by(simp add: bal_tree_def)

lemma wbalanced_balance_tree: "wbalanced (balance_tree t)"
by (simp add: balance_tree_def)

hide_const (open) bal

end


header {* \isaheader{Auxiliary lemmas} *}

theory AuxLemmas imports Main begin

abbreviation "arbitrary == undefined"

text {* Lemmas about left- and rightmost elements in lists *}

lemma leftmost_element_property:
  assumes "\<exists>x \<in> set xs. P x"
  obtains zs x' ys where "xs = zs@x'#ys" and "P x'" and "\<forall>z \<in> set zs. \<not> P z"
proof(atomize_elim)
  from `\<exists>x \<in> set xs. P x`
  show "\<exists>zs x' ys. xs = zs @ x' # ys \<and> P x' \<and> (\<forall>z\<in>set zs. \<not> P z)"
  proof(induct xs)
    case Nil thus ?case by simp
  next
    case (Cons x' xs')
    note IH = `\<exists>a\<in>set xs'. P a
      \<Longrightarrow> \<exists>zs x' ys. xs' = zs@x'#ys \<and> P x' \<and> (\<forall>z\<in>set zs. \<not> P z)`
    show ?case
    proof (cases "P x'")
      case True
      then have "(\<exists>ys. x' # xs' = [] @ x' # ys) \<and> P x' \<and> (\<forall>x\<in>set []. \<not> P x)" by simp
      then show ?thesis by blast
    next
      case False
      with `\<exists>y\<in>set (x'#xs'). P y` have "\<exists>y\<in>set xs'. P y" by simp
      from IH[OF this] obtain y ys zs where "xs' = zs@y#ys"
        and "P y" and "\<forall>z\<in>set zs. \<not> P z" by blast
      from `\<forall>z\<in>set zs. \<not> P z` False have "\<forall>z\<in>set (x'#zs). \<not> P z" by simp
      with `xs' = zs@y#ys` `P y` show ?thesis by (metis Cons_eq_append_conv)
    qed
  qed
qed

lemma rightmost_element_property:
  assumes "\<exists>x \<in> set xs. P x"
  obtains ys x' zs where "xs = ys@x'#zs" and "P x'" and "\<forall>z \<in> set zs. \<not> P z"
proof(atomize_elim)
  from `\<exists>x \<in> set xs. P x`
  show "\<exists>ys x' zs. xs = ys @ x' # zs \<and> P x' \<and> (\<forall>z\<in>set zs. \<not> P z)"
  proof(induct xs)
    case Nil thus ?case by simp
  next
    case (Cons x' xs')
    note IH = `\<exists>a\<in>set xs'. P a
      \<Longrightarrow> \<exists>ys x' zs. xs' = ys @ x' # zs \<and> P x' \<and> (\<forall>z\<in>set zs. \<not> P z)`
    show ?case
    proof(cases "\<exists>y\<in>set xs'. P y")
      case True
      from IH[OF this] obtain y ys zs where "xs' = ys @ y # zs"
        and "P y" and "\<forall>z\<in>set zs. \<not> P z" by blast
      thus ?thesis by (metis Cons_eq_append_conv)
    next
      case False
      with `\<exists>y\<in>set (x'#xs'). P y` have "P x'" by simp
      with False show ?thesis by (metis eq_Nil_appendI)
    qed
  qed
qed

text {* Lemma concerning maps and @{text @} *}

lemma map_append_append_maps:
  assumes map:"map f xs = ys@zs"
  obtains xs' xs'' where "map f xs' = ys" and "map f xs'' = zs" and "xs=xs'@xs''"
by (metis append_eq_conv_conj append_take_drop_id assms drop_map take_map that)

text {* Lemma concerning splitting of @{term list}s *}

lemma  path_split_general:
assumes all:"\<forall>zs. xs \<noteq> ys@zs"
obtains j zs where "xs = (take j ys)@zs" and "j < length ys"
  and "\<forall>k > j. \<forall>zs'. xs \<noteq> (take k ys)@zs'"
proof(atomize_elim)
  from `\<forall>zs. xs \<noteq> ys@zs`
  show "\<exists>j zs. xs = take j ys @ zs \<and> j < length ys \<and>
               (\<forall>k>j. \<forall>zs'. xs \<noteq> take k ys @ zs')"
  proof(induct ys arbitrary:xs)
    case Nil thus ?case by auto
  next
    case (Cons y' ys')
    note IH = `\<And>xs. \<forall>zs. xs \<noteq> ys' @ zs \<Longrightarrow>
      \<exists>j zs. xs = take j ys' @ zs \<and> j < length ys' \<and>
      (\<forall>k. j < k \<longrightarrow> (\<forall>zs'. xs \<noteq> take k ys' @ zs'))`
    show ?case
    proof(cases xs)
      case Nil thus ?thesis by simp
    next
      case (Cons x' xs')
      with `\<forall>zs. xs \<noteq> (y' # ys') @ zs` have "x' \<noteq> y' \<or> (\<forall>zs. xs' \<noteq> ys' @ zs)"
        by simp
      show ?thesis
      proof(cases "x' = y'")
        case True
        with `x' \<noteq> y' \<or> (\<forall>zs. xs' \<noteq> ys' @ zs)` have "\<forall>zs. xs' \<noteq> ys' @ zs" by simp
        from IH[OF this] have "\<exists>j zs. xs' = take j ys' @ zs \<and> j < length ys' \<and>
          (\<forall>k. j < k \<longrightarrow> (\<forall>zs'. xs' \<noteq> take k ys' @ zs'))" .
        then obtain j zs where "xs' = take j ys' @ zs"
          and "j < length ys'"
          and all_sub:"\<forall>k. j < k \<longrightarrow> (\<forall>zs'. xs' \<noteq> take k ys' @ zs')"
          by blast
        from `xs' = take j ys' @ zs` True
          have "(x'#xs') = take (Suc j) (y' # ys') @ zs"
          by simp
        from all_sub True have all_imp:"\<forall>k. j < k \<longrightarrow>
          (\<forall>zs'. (x'#xs') \<noteq> take (Suc k) (y' # ys') @ zs')"
          by auto
        { fix l assume "(Suc j) < l"
          then obtain k where [simp]:"l = Suc k" by(cases l) auto
          with `(Suc j) < l` have "j < k" by simp
          with all_imp
          have "\<forall>zs'. (x'#xs') \<noteq> take (Suc k) (y' # ys') @ zs'"
            by simp
          hence "\<forall>zs'. (x'#xs') \<noteq> take l (y' # ys') @ zs'"
            by simp }
        with `(x'#xs') = take (Suc j) (y' # ys') @ zs` `j < length ys'` Cons
        show ?thesis by (metis Suc_length_conv less_Suc_eq_0_disj)
      next
        case False
        with Cons have "\<forall>i zs'. i > 0 \<longrightarrow> xs \<noteq> take i (y' # ys') @ zs'"
          by auto(case_tac i,auto)
        moreover
        have "\<exists>zs. xs = take 0 (y' # ys') @ zs" by simp
        ultimately show ?thesis by(rule_tac x="0" in exI,auto)
      qed
    qed
  qed
qed

end


(*  Title:      HOL/Number_Theory/MiscAlgebra.thy
    Author:     Jeremy Avigad
*)

section \<open>Things that can be added to the Algebra library\<close>

theory MiscAlgebra
imports
  "~~/src/HOL/Algebra/Ring"
  "~~/src/HOL/Algebra/FiniteProduct"
begin

subsection \<open>Finiteness stuff\<close>

lemma bounded_set1_int [intro]: "finite {(x::int). a < x & x < b & P x}"
  apply (subgoal_tac "{x. a < x & x < b & P x} <= {a<..<b}")
  apply (erule finite_subset)
  apply auto
  done

subsection \<open>The rest is for the algebra libraries\<close>

subsubsection \<open>These go in Group.thy\<close>

text \<open>
  Show that the units in any monoid give rise to a group.

  The file Residues.thy provides some infrastructure to use
  facts about the unit group within the ring locale.
\<close>

definition units_of :: "('a, 'b) monoid_scheme => 'a monoid" where
  "units_of G == (| carrier = Units G,
     Group.monoid.mult = Group.monoid.mult G,
     one  = one G |)"

(*

lemma (in monoid) Units_mult_closed [intro]:
  "x : Units G ==> y : Units G ==> x \<otimes> y : Units G"
  apply (unfold Units_def)
  apply (clarsimp)
  apply (rule_tac x = "xaa \<otimes> xa" in bexI)
  apply auto
  apply (subst m_assoc)
  apply auto
  apply (subst (2) m_assoc [symmetric])
  apply auto
  apply (subst m_assoc)
  apply auto
  apply (subst (2) m_assoc [symmetric])
  apply auto
done

*)

lemma (in monoid) units_group: "group(units_of G)"
  apply (unfold units_of_def)
  apply (rule groupI)
  apply auto
  apply (subst m_assoc)
  apply auto
  apply (rule_tac x = "inv x" in bexI)
  apply auto
  done

lemma (in comm_monoid) units_comm_group: "comm_group(units_of G)"
  apply (rule group.group_comm_groupI)
  apply (rule units_group)
  apply (insert comm_monoid_axioms)
  apply (unfold units_of_def Units_def comm_monoid_def comm_monoid_axioms_def)
  apply auto
  done

lemma units_of_carrier: "carrier (units_of G) = Units G"
  unfolding units_of_def by auto

lemma units_of_mult: "mult(units_of G) = mult G"
  unfolding units_of_def by auto

lemma units_of_one: "one(units_of G) = one G"
  unfolding units_of_def by auto

lemma (in monoid) units_of_inv: "x : Units G ==> m_inv (units_of G) x = m_inv G x"
  apply (rule sym)
  apply (subst m_inv_def)
  apply (rule the1_equality)
  apply (rule ex_ex1I)
  apply (subst (asm) Units_def)
  apply auto
  apply (erule inv_unique)
  apply auto
  apply (rule Units_closed)
  apply (simp_all only: units_of_carrier [symmetric])
  apply (insert units_group)
  apply auto
  apply (subst units_of_mult [symmetric])
  apply (subst units_of_one [symmetric])
  apply (erule group.r_inv, assumption)
  apply (subst units_of_mult [symmetric])
  apply (subst units_of_one [symmetric])
  apply (erule group.l_inv, assumption)
  done

lemma (in group) inj_on_const_mult: "a: (carrier G) ==> inj_on (%x. a \<otimes> x) (carrier G)"
  unfolding inj_on_def by auto

lemma (in group) surj_const_mult: "a : (carrier G) ==> (%x. a \<otimes> x) ` (carrier G) = (carrier G)"
  apply (auto simp add: image_def)
  apply (rule_tac x = "(m_inv G a) \<otimes> x" in bexI)
  apply auto
(* auto should get this. I suppose we need "comm_monoid_simprules"
   for ac_simps rewriting. *)
  apply (subst m_assoc [symmetric])
  apply auto
  done

lemma (in group) l_cancel_one [simp]:
    "x : carrier G \<Longrightarrow> a : carrier G \<Longrightarrow> (x \<otimes> a = x) = (a = one G)"
  apply auto
  apply (subst l_cancel [symmetric])
  prefer 4
  apply (erule ssubst)
  apply auto
  done

lemma (in group) r_cancel_one [simp]: "x : carrier G \<Longrightarrow> a : carrier G \<Longrightarrow>
    (a \<otimes> x = x) = (a = one G)"
  apply auto
  apply (subst r_cancel [symmetric])
  prefer 4
  apply (erule ssubst)
  apply auto
  done

(* Is there a better way to do this? *)
lemma (in group) l_cancel_one' [simp]: "x : carrier G \<Longrightarrow> a : carrier G \<Longrightarrow>
    (x = x \<otimes> a) = (a = one G)"
  apply (subst eq_commute)
  apply simp
  done

lemma (in group) r_cancel_one' [simp]: "x : carrier G \<Longrightarrow> a : carrier G \<Longrightarrow>
    (x = a \<otimes> x) = (a = one G)"
  apply (subst eq_commute)
  apply simp
  done

(* This should be generalized to arbitrary groups, not just commutative
   ones, using Lagrange's theorem. *)

lemma (in comm_group) power_order_eq_one:
  assumes fin [simp]: "finite (carrier G)"
    and a [simp]: "a : carrier G"
  shows "a (^) card(carrier G) = one G"
proof -
  have "(\<Otimes>x\<in>carrier G. x) = (\<Otimes>x\<in>carrier G. a \<otimes> x)"
    by (subst (2) finprod_reindex [symmetric],
      auto simp add: Pi_def inj_on_const_mult surj_const_mult)
  also have "\<dots> = (\<Otimes>x\<in>carrier G. a) \<otimes> (\<Otimes>x\<in>carrier G. x)"
    by (auto simp add: finprod_multf Pi_def)
  also have "(\<Otimes>x\<in>carrier G. a) = a (^) card(carrier G)"
    by (auto simp add: finprod_const)
  finally show ?thesis
(* uses the preceeding lemma *)
    by auto
qed

subsubsection \<open>Miscellaneous\<close>

lemma (in cring) field_intro2: "\<zero>\<^bsub>R\<^esub> ~= \<one>\<^bsub>R\<^esub> \<Longrightarrow> \<forall>x \<in> carrier R - {\<zero>\<^bsub>R\<^esub>}. x \<in> Units R \<Longrightarrow> field R"
  apply (unfold_locales)
  apply (insert cring_axioms, auto)
  apply (rule trans)
  apply (subgoal_tac "a = (a \<otimes> b) \<otimes> inv b")
  apply assumption
  apply (subst m_assoc)
  apply auto
  apply (unfold Units_def)
  apply auto
  done

lemma (in monoid) inv_char: "x : carrier G \<Longrightarrow> y : carrier G \<Longrightarrow>
    x \<otimes> y = \<one> \<Longrightarrow> y \<otimes> x = \<one> \<Longrightarrow> inv x = y"
  apply (subgoal_tac "x : Units G")
  apply (subgoal_tac "y = inv x \<otimes> \<one>")
  apply simp
  apply (erule subst)
  apply (subst m_assoc [symmetric])
  apply auto
  apply (unfold Units_def)
  apply auto
  done

lemma (in comm_monoid) comm_inv_char: "x : carrier G \<Longrightarrow> y : carrier G \<Longrightarrow>
  x \<otimes> y = \<one> \<Longrightarrow> inv x = y"
  apply (rule inv_char)
  apply auto
  apply (subst m_comm, auto)
  done

lemma (in ring) inv_neg_one [simp]: "inv (\<ominus> \<one>) = \<ominus> \<one>"
  apply (rule inv_char)
  apply (auto simp add: l_minus r_minus)
  done

lemma (in monoid) inv_eq_imp_eq: "x : Units G \<Longrightarrow> y : Units G \<Longrightarrow>
    inv x = inv y \<Longrightarrow> x = y"
  apply (subgoal_tac "inv(inv x) = inv(inv y)")
  apply (subst (asm) Units_inv_inv)+
  apply auto
  done

lemma (in ring) Units_minus_one_closed [intro]: "\<ominus> \<one> : Units R"
  apply (unfold Units_def)
  apply auto
  apply (rule_tac x = "\<ominus> \<one>" in bexI)
  apply auto
  apply (simp add: l_minus r_minus)
  done

lemma (in monoid) inv_one [simp]: "inv \<one> = \<one>"
  apply (rule inv_char)
  apply auto
  done

lemma (in ring) inv_eq_neg_one_eq: "x : Units R \<Longrightarrow> (inv x = \<ominus> \<one>) = (x = \<ominus> \<one>)"
  apply auto
  apply (subst Units_inv_inv [symmetric])
  apply auto
  done

lemma (in monoid) inv_eq_one_eq: "x : Units G \<Longrightarrow> (inv x = \<one>) = (x = \<one>)"
  by (metis Units_inv_inv inv_one)

subsubsection \<open>This goes in FiniteProduct\<close>

lemma (in comm_monoid) finprod_UN_disjoint:
  "finite I \<Longrightarrow> (ALL i:I. finite (A i)) \<longrightarrow> (ALL i:I. ALL j:I. i ~= j \<longrightarrow>
     (A i) Int (A j) = {}) \<longrightarrow>
      (ALL i:I. ALL x: (A i). g x : carrier G) \<longrightarrow>
        finprod G g (UNION I A) = finprod G (%i. finprod G g (A i)) I"
  apply (induct set: finite)
  apply force
  apply clarsimp
  apply (subst finprod_Un_disjoint)
  apply blast
  apply (erule finite_UN_I)
  apply blast
  apply (fastforce)
  apply (auto intro!: funcsetI finprod_closed)
  done

lemma (in comm_monoid) finprod_Union_disjoint:
  "[| finite C; (ALL A:C. finite A & (ALL x:A. f x : carrier G));
      (ALL A:C. ALL B:C. A ~= B --> A Int B = {}) |]
   ==> finprod G f (\<Union>C) = finprod G (finprod G f) C"
  apply (frule finprod_UN_disjoint [of C id f])
  apply auto
  done

lemma (in comm_monoid) finprod_one:
    "finite A \<Longrightarrow> (\<And>x. x:A \<Longrightarrow> f x = \<one>) \<Longrightarrow> finprod G f A = \<one>"
  by (induct set: finite) auto

(* need better simplification rules for rings *)
(* the next one holds more generally for abelian groups *)

lemma (in cring) sum_zero_eq_neg: "x : carrier R \<Longrightarrow> y : carrier R \<Longrightarrow> x \<oplus> y = \<zero> \<Longrightarrow> x = \<ominus> y"
  by (metis minus_equality)

lemma (in domain) square_eq_one:
  fixes x
  assumes [simp]: "x : carrier R"
    and "x \<otimes> x = \<one>"
  shows "x = \<one> | x = \<ominus>\<one>"
proof -
  have "(x \<oplus> \<one>) \<otimes> (x \<oplus> \<ominus> \<one>) = x \<otimes> x \<oplus> \<ominus> \<one>"
    by (simp add: ring_simprules)
  also from \<open>x \<otimes> x = \<one>\<close> have "\<dots> = \<zero>"
    by (simp add: ring_simprules)
  finally have "(x \<oplus> \<one>) \<otimes> (x \<oplus> \<ominus> \<one>) = \<zero>" .
  then have "(x \<oplus> \<one>) = \<zero> | (x \<oplus> \<ominus> \<one>) = \<zero>"
    by (intro integral, auto)
  then show ?thesis
    apply auto
    apply (erule notE)
    apply (rule sum_zero_eq_neg)
    apply auto
    apply (subgoal_tac "x = \<ominus> (\<ominus> \<one>)")
    apply (simp add: ring_simprules)
    apply (rule sum_zero_eq_neg)
    apply auto
    done
qed

lemma (in Ring.domain) inv_eq_self: "x : Units R \<Longrightarrow> x = inv x \<Longrightarrow> x = \<one> \<or> x = \<ominus>\<one>"
  by (metis Units_closed Units_l_inv square_eq_one)

text \<open>
  The following translates theorems about groups to the facts about
  the units of a ring. (The list should be expanded as more things are
  needed.)
\<close>

lemma (in ring) finite_ring_finite_units [intro]: "finite (carrier R) \<Longrightarrow> finite (Units R)"
  by (rule finite_subset) auto

lemma (in monoid) units_of_pow:
  fixes n :: nat
  shows "x \<in> Units G \<Longrightarrow> x (^)\<^bsub>units_of G\<^esub> n = x (^)\<^bsub>G\<^esub> n"
  apply (induct n)
  apply (auto simp add: units_group group.is_monoid
    monoid.nat_pow_0 monoid.nat_pow_Suc units_of_one units_of_mult)
  done

lemma (in cring) units_power_order_eq_one: "finite (Units R) \<Longrightarrow> a : Units R
    \<Longrightarrow> a (^) card(Units R) = \<one>"
  apply (subst units_of_carrier [symmetric])
  apply (subst units_of_one [symmetric])
  apply (subst units_of_pow [symmetric])
  apply assumption
  apply (rule comm_group.power_order_eq_one)
  apply (rule units_comm_group)
  apply (unfold units_of_def, auto)
  done

end