(******************************************************************************)
(* Project: Isabelle/UTP Toolkit                                              *)
(* File: List_Extra.thy                                                       *)
(* Authors: Simon Foster and Frank Zeyda                                      *)
(* Emails: simon.foster@york.ac.uk and frank.zeyda@york.ac.uk                 *)
(******************************************************************************)

section \<open> Lists: extra functions and properties \<close>

theory List_Extra
  imports
  "HOL-Library.Sublist"
  "HOL-Library.Monad_Syntax"
  "HOL-Library.Prefix_Order"
  "Optics.Lens_Instances"
begin

subsection \<open> Useful Abbreviations \<close>

abbreviation "list_sum xs \<equiv> foldr (+) xs 0"

subsection \<open> Folds \<close>

context abel_semigroup
begin

  lemma foldr_snoc: "foldr (\<^bold>*) (xs @ [x]) k = (foldr (\<^bold>*) xs k) \<^bold>* x"
    by (induct xs, simp_all add: commute left_commute)

end

subsection \<open> List Lookup \<close>

text \<open>
  The following variant of the standard \<open>nth\<close> function returns \<open>\<bottom>\<close> if the index is
  out of range.
\<close>

primrec
  nth_el :: "'a list \<Rightarrow> nat \<Rightarrow> 'a option" ("_\<langle>_\<rangle>\<^sub>l" [90, 0] 91)
where
  "[]\<langle>i\<rangle>\<^sub>l = None"
| "(x # xs)\<langle>i\<rangle>\<^sub>l = (case i of 0 \<Rightarrow> Some x | Suc j \<Rightarrow> xs \<langle>j\<rangle>\<^sub>l)"

lemma nth_el_appendl[simp]: "i < length xs \<Longrightarrow> (xs @ ys)\<langle>i\<rangle>\<^sub>l = xs\<langle>i\<rangle>\<^sub>l"
  apply (induct xs arbitrary: i)
   apply simp
  apply (case_tac i)
   apply simp_all
  done

lemma nth_el_appendr[simp]: "length xs \<le> i \<Longrightarrow> (xs @ ys)\<langle>i\<rangle>\<^sub>l = ys\<langle>i - length xs\<rangle>\<^sub>l"
  apply (induct xs arbitrary: i)
   apply simp
  apply (case_tac i)
   apply simp_all
  done

subsection \<open> Extra List Theorems \<close>

subsubsection \<open> Map \<close>

lemma map_nth_Cons_atLeastLessThan:
  "map (nth (x # xs)) [Suc m..<n] = map (nth xs) [m..<n - 1]"
proof -
  have "nth xs = nth (x # xs) \<circ> Suc"
    by auto
  hence "map (nth xs) [m..<n - 1] = map (nth (x # xs) \<circ> Suc) [m..<n - 1]"
    by simp
  also have "... = map (nth (x # xs)) (map Suc [m..<n - 1])"
    by simp
  also have "... = map (nth (x # xs)) [Suc m..<n]"
    by (metis Suc_diff_1 le_0_eq length_upt list.simps(8) list.size(3) map_Suc_upt not_less upt_0)
  finally show ?thesis ..
qed

subsubsection \<open> Sorted Lists \<close>

lemma sorted_last [simp]: "\<lbrakk> x \<in> set xs; sorted xs \<rbrakk> \<Longrightarrow> x \<le> last xs"
  by (induct xs, auto)

lemma sorted_prefix:
  assumes "xs \<le> ys" "sorted ys"
  shows "sorted xs"
proof -
  obtain zs where "ys = xs @ zs"
    using Prefix_Order.prefixE assms(1) by auto
  thus ?thesis
    using assms(2) sorted_append by blast
qed

lemma sorted_map: "\<lbrakk> sorted xs; mono f \<rbrakk> \<Longrightarrow> sorted (map f xs)"
  by (simp add: monoD sorted_iff_nth_mono)

lemma sorted_distinct [intro]: "\<lbrakk> sorted (xs); distinct(xs) \<rbrakk> \<Longrightarrow> (\<forall> i<length xs - 1. xs!i < xs!(i + 1))"
  apply (induct xs)
   apply (auto)
  apply (metis (no_types, hide_lams) Suc_leI Suc_less_eq Suc_pred gr0_conv_Suc not_le not_less_iff_gr_or_eq nth_Cons_Suc nth_mem nth_non_equal_first_eq)
  done

text \<open> Is the given list a permutation of the given set? \<close>

definition is_sorted_list_of_set :: "('a::ord) set \<Rightarrow> 'a list \<Rightarrow> bool" where
"is_sorted_list_of_set A xs = ((\<forall> i<length(xs) - 1. xs!i < xs!(i + 1)) \<and> set(xs) = A)"

lemma sorted_is_sorted_list_of_set:
  assumes "is_sorted_list_of_set A xs"
  shows "sorted(xs)" and "distinct(xs)"
using assms proof (induct xs arbitrary: A)
  show "sorted []"
    by auto
next
  show "distinct []"
    by auto
next
  fix A :: "'a set"
  case (Cons x xs) note hyps = this
  assume isl: "is_sorted_list_of_set A (x # xs)"
  hence srt: "(\<forall>i<length xs - Suc 0. xs ! i < xs ! Suc i)"
    using less_diff_conv by (auto simp add: is_sorted_list_of_set_def)
  with hyps(1) have srtd: "sorted xs"
    by (simp add: is_sorted_list_of_set_def)
  with isl show "sorted (x # xs)"
    apply (auto simp add: is_sorted_list_of_set_def)
    apply (metis (mono_tags, lifting) all_nth_imp_all_set less_le_trans linorder_not_less not_less_iff_gr_or_eq nth_Cons_0 sorted_iff_nth_mono zero_order(3))
    done
  from srt hyps(2) have "distinct xs"
    by (simp add: is_sorted_list_of_set_def)
  with isl show "distinct (x # xs)"
  proof -
    have "(\<forall>n. \<not> n < length (x # xs) - 1 \<or> (x # xs) ! n < (x # xs) ! (n + 1)) \<and> set (x # xs) = A"
      by (meson \<open>is_sorted_list_of_set A (x # xs)\<close> is_sorted_list_of_set_def)
  then show ?thesis
    by (metis \<open>distinct xs\<close> add.commute add_diff_cancel_left' distinct.simps(2) leD length_Cons length_greater_0_conv length_pos_if_in_set less_le nth_Cons_0 nth_Cons_Suc plus_1_eq_Suc set_ConsD sorted.elims(2) srtd)
  qed
qed

lemma is_sorted_list_of_set_alt_def:
  "is_sorted_list_of_set A xs \<longleftrightarrow> sorted (xs) \<and> distinct (xs) \<and> set(xs) = A"
  apply (auto intro: sorted_is_sorted_list_of_set)
    apply (auto simp add: is_sorted_list_of_set_def)
  apply (metis Nat.add_0_right One_nat_def add_Suc_right sorted_distinct)
  done

definition sorted_list_of_set_alt :: "('a::ord) set \<Rightarrow> 'a list" where
"sorted_list_of_set_alt A =
  (if (A = {}) then [] else (THE xs. is_sorted_list_of_set A xs))"

lemma is_sorted_list_of_set:
  "finite A \<Longrightarrow> is_sorted_list_of_set A (sorted_list_of_set A)"
  apply (simp add: is_sorted_list_of_set_def)
  apply (metis One_nat_def add.right_neutral add_Suc_right sorted_distinct sorted_list_of_set)
  done

lemma sorted_list_of_set_other_def:
  "finite A \<Longrightarrow> sorted_list_of_set(A) = (THE xs. sorted(xs) \<and> distinct(xs) \<and> set xs = A)"
  apply (rule sym)
  apply (rule the_equality)
   apply (auto)
  apply (simp add: sorted_distinct_set_unique)
  done

lemma sorted_list_of_set_alt [simp]:
  "finite A \<Longrightarrow> sorted_list_of_set_alt(A) = sorted_list_of_set(A)"
  apply (rule sym)
  apply (auto simp add: sorted_list_of_set_alt_def is_sorted_list_of_set_alt_def sorted_list_of_set_other_def)
  done

text \<open> Sorting lists according to a relation \<close>

definition is_sorted_list_of_set_by :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a list \<Rightarrow> bool" where
"is_sorted_list_of_set_by R A xs = ((\<forall> i<length(xs) - 1. (xs!i, xs!(i + 1)) \<in> R) \<and> set(xs) = A)"

definition sorted_list_of_set_by :: "'a rel \<Rightarrow> 'a set \<Rightarrow> 'a list" where
"sorted_list_of_set_by R A = (THE xs. is_sorted_list_of_set_by R A xs)"

definition fin_set_lexord :: "'a rel \<Rightarrow> 'a set rel" where
"fin_set_lexord R = {(A, B). finite A \<and> finite B \<and>
                             (\<exists> xs ys. is_sorted_list_of_set_by R A xs \<and> is_sorted_list_of_set_by R B ys
                              \<and> (xs, ys) \<in> lexord R)}"

lemma is_sorted_list_of_set_by_mono:
  "\<lbrakk> R \<subseteq> S; is_sorted_list_of_set_by R A xs \<rbrakk> \<Longrightarrow> is_sorted_list_of_set_by S A xs"
  by (auto simp add: is_sorted_list_of_set_by_def)

lemma lexord_mono':
  "\<lbrakk> (\<And> x y. f x y \<longrightarrow> g x y); (xs, ys) \<in> lexord {(x, y). f x y} \<rbrakk> \<Longrightarrow> (xs, ys) \<in> lexord {(x, y). g x y}"
  by (metis case_prodD case_prodI lexord_take_index_conv mem_Collect_eq)

lemma fin_set_lexord_mono [mono]:
  "(\<And> x y. f x y \<longrightarrow> g x y) \<Longrightarrow> (xs, ys) \<in> fin_set_lexord {(x, y). f x y} \<longrightarrow> (xs, ys) \<in> fin_set_lexord {(x, y). g x y}"
proof
  assume
    fin: "(xs, ys) \<in> fin_set_lexord {(x, y). f x y}" and
    hyp: "(\<And> x y. f x y \<longrightarrow> g x y)"

  from fin have "finite xs" "finite ys"
    using fin_set_lexord_def by fastforce+

  with fin hyp show "(xs, ys) \<in> fin_set_lexord {(x, y). g x y}"
    apply (auto simp add: fin_set_lexord_def)
    apply (rename_tac xs' ys')
    apply (rule_tac x="xs'" in exI)
    apply (auto)
     apply (metis case_prodD case_prodI is_sorted_list_of_set_by_def mem_Collect_eq)
    apply (metis case_prodD case_prodI is_sorted_list_of_set_by_def lexord_mono' mem_Collect_eq)
    done
qed

definition distincts :: "'a set \<Rightarrow> 'a list set" where
"distincts A = {xs \<in> lists A. distinct(xs)}"

lemma tl_element:
  "\<lbrakk> x \<in> set xs; x \<noteq> hd(xs) \<rbrakk> \<Longrightarrow> x \<in> set(tl(xs))"
  by (metis in_set_insert insert_Nil list.collapse list.distinct(2) set_ConsD)

subsubsection \<open> List Update \<close>

lemma listsum_update:
  fixes xs :: "'a::ring list"
  assumes "i < length xs"
  shows "list_sum (xs[i := v]) = list_sum xs - xs ! i + v"
using assms proof (induct xs arbitrary: i)
  case Nil
  then show ?case by (simp)
next
  case (Cons a xs)
  then show ?case
  proof (cases i)
    case 0
    thus ?thesis
      by (simp add: add.commute)
  next
    case (Suc i')
    with Cons show ?thesis
      by (auto)
  qed
qed

subsubsection \<open> Drop While and Take While \<close>

lemma dropWhile_sorted_le_above:
  "\<lbrakk> sorted xs; x \<in> set (dropWhile (\<lambda> x. x \<le> n) xs) \<rbrakk> \<Longrightarrow> x > n"
  apply (induct xs)
   apply (auto)
  apply (rename_tac a xs)
  apply (case_tac "a \<le> n")
   apply (auto)
done

lemma set_dropWhile_le:
  "sorted xs \<Longrightarrow> set (dropWhile (\<lambda> x. x \<le> n) xs) = {x\<in>set xs. x > n}"
  apply (induct xs)
   apply (simp)
  apply (rename_tac x xs)
  apply (subgoal_tac "sorted xs")
   apply (simp)
   apply (safe)
     apply (auto)
done

lemma set_takeWhile_less_sorted:
  "\<lbrakk> sorted I; x \<in> set I; x < n \<rbrakk> \<Longrightarrow> x \<in> set (takeWhile (\<lambda>x. x < n) I)"
proof (induct I arbitrary: x)
  case Nil thus ?case
    by (simp)
next
  case (Cons a I) thus ?case
    by auto
qed

lemma nth_le_takeWhile_ord: "\<lbrakk> sorted xs; i \<ge> length (takeWhile (\<lambda> x. x \<le> n) xs); i < length xs \<rbrakk> \<Longrightarrow> n \<le> xs ! i"
  apply (induct xs arbitrary: i, auto)
  apply (rename_tac x xs i)
  apply (case_tac "x \<le> n")
   apply (auto)
  apply (metis One_nat_def Suc_eq_plus1 le_less_linear le_less_trans less_imp_le list.size(4) nth_mem set_ConsD)
  done

lemma length_takeWhile_less:
  "\<lbrakk> a \<in> set xs; \<not> P a \<rbrakk> \<Longrightarrow> length (takeWhile P xs) < length xs"
  by (metis in_set_conv_nth length_takeWhile_le nat_neq_iff not_less set_takeWhileD takeWhile_nth)

lemma nth_length_takeWhile_less:
  "\<lbrakk> sorted xs; distinct xs; (\<exists> a \<in> set xs. a \<ge> n) \<rbrakk> \<Longrightarrow> xs ! length (takeWhile (\<lambda>x. x < n) xs) \<ge> n"
  by (induct xs, auto)

subsubsection \<open> Last and But Last \<close>

lemma length_gt_zero_butlast_concat:
  assumes "length ys > 0"
  shows "butlast (xs @ ys) = xs @ (butlast ys)"
  using assms by (metis butlast_append length_greater_0_conv)

lemma length_eq_zero_butlast_concat:
  assumes "length ys = 0"
  shows "butlast (xs @ ys) = butlast xs"
  using assms by (metis append_Nil2 length_0_conv)

lemma butlast_single_element:
  shows "butlast [e] = []"
  by (metis butlast.simps(2))

lemma last_single_element:
  shows "last [e] = e"
  by (metis last.simps)

lemma length_zero_last_concat:
  assumes "length t = 0"
  shows "last (s @ t) = last s"
  by (metis append_Nil2 assms length_0_conv)

lemma length_gt_zero_last_concat:
  assumes "length t > 0"
  shows "last (s @ t) = last t"
  by (metis assms last_append length_greater_0_conv)

subsubsection \<open> Prefixes and Strict Prefixes \<close>

lemma prefix_length_eq:
  "\<lbrakk> length xs = length ys; prefix xs ys \<rbrakk> \<Longrightarrow> xs = ys"
  by (metis not_equal_is_parallel parallel_def)

lemma prefix_Cons_elim [elim]:
  assumes "prefix (x # xs) ys"
  obtains ys' where "ys = x # ys'" "prefix xs ys'"
  using assms
  by (metis append_Cons prefix_def)

lemma prefix_map_inj:
  "\<lbrakk> inj_on f (set xs \<union> set ys); prefix (map f xs) (map f ys) \<rbrakk> \<Longrightarrow>
   prefix xs ys"
  apply (induct xs arbitrary:ys)
   apply (simp_all)
  apply (erule prefix_Cons_elim)
  apply (auto)
  apply (metis image_insert insertI1 insert_Diff_if singletonE)
  done

lemma prefix_map_inj_eq [simp]:
  "inj_on f (set xs \<union> set ys) \<Longrightarrow>
   prefix (map f xs) (map f ys) \<longleftrightarrow> prefix xs ys"
  using map_mono_prefix prefix_map_inj by blast

lemma strict_prefix_Cons_elim [elim]:
  assumes "strict_prefix (x # xs) ys"
  obtains ys' where "ys = x # ys'" "strict_prefix xs ys'"
  using assms
  by (metis Sublist.strict_prefixE' Sublist.strict_prefixI' append_Cons)

lemma strict_prefix_map_inj:
  "\<lbrakk> inj_on f (set xs \<union> set ys); strict_prefix (map f xs) (map f ys) \<rbrakk> \<Longrightarrow>
   strict_prefix xs ys"
  apply (induct xs arbitrary:ys)
   apply (auto)
  using prefix_bot.bot.not_eq_extremum apply fastforce
  apply (erule strict_prefix_Cons_elim)
  apply (auto)
  apply (metis (hide_lams, full_types) image_insert insertI1 insert_Diff_if singletonE)
  done

lemma strict_prefix_map_inj_eq [simp]:
  "inj_on f (set xs \<union> set ys) \<Longrightarrow>
   strict_prefix (map f xs) (map f ys) \<longleftrightarrow> strict_prefix xs ys"
  by (simp add: inj_on_map_eq_map strict_prefix_def)

lemma prefix_drop:
  "\<lbrakk> drop (length xs) ys = zs; prefix xs ys \<rbrakk>
   \<Longrightarrow> ys = xs @ zs"
  by (metis append_eq_conv_conj prefix_def)

lemma list_append_prefixD [dest]: "x @ y \<le> z \<Longrightarrow> x \<le> z"
  using append_prefixD less_eq_list_def by blast

lemma prefix_not_empty:
  assumes "strict_prefix xs ys" and "xs \<noteq> []"
  shows "ys \<noteq> []"
  using Sublist.strict_prefix_simps(1) assms(1) by blast

lemma prefix_not_empty_length_gt_zero:
  assumes "strict_prefix xs ys" and "xs \<noteq> []"
  shows "length ys > 0"
  using assms prefix_not_empty by auto

lemma butlast_prefix_suffix_not_empty:
  assumes "strict_prefix (butlast xs) ys"
  shows "ys \<noteq> []"
  using assms prefix_not_empty_length_gt_zero by fastforce

lemma prefix_and_concat_prefix_is_concat_prefix:
  assumes "prefix s t" "prefix (e @ t) u"
  shows "prefix (e @ s) u"
  using Sublist.same_prefix_prefix assms(1) assms(2) prefix_order.dual_order.trans by blast

lemma strict_prefix_eq_exists:
  "strict_prefix s t \<longleftrightarrow> (\<exists>xs . s @ xs = t \<and> (length xs) > 0)"
  using prefix_def strict_prefix_def by auto

lemma butlast_strict_prefix_eq_butlast:
  assumes "length s = length t" and "strict_prefix (butlast s) t"
  shows "strict_prefix (butlast s) t \<longleftrightarrow> (butlast s) = (butlast t)"
  by (metis append_butlast_last_id append_eq_append_conv assms(1) assms(2) length_0_conv length_butlast strict_prefix_eq_exists)

lemma butlast_eq_if_eq_length_and_prefix:
  assumes "length s > 0" "length z > 0"
          "length s = length z" "strict_prefix (butlast s) t" "strict_prefix (butlast z) t"
  shows   "(butlast s) = (butlast z)"
  using assms by (auto simp add:strict_prefix_eq_exists)

lemma prefix_imp_length_lteq:
  assumes "prefix s t"
  shows "length s \<le> length t"
  using assms by (simp add: Sublist.prefix_length_le)

lemma prefix_imp_length_not_gt:
  assumes "prefix s t"
  shows "\<not> length t < length s"
  using assms by (simp add: Sublist.prefix_length_le leD)

lemma prefix_and_eq_length_imp_eq_list:
  assumes "prefix s t" and "length t = length s"
  shows "s=t"
  using assms by (simp add: prefix_length_eq)

lemma butlast_prefix_imp_length_not_gt:
  assumes "length s > 0" "strict_prefix (butlast s) t"
  shows "\<not> (length t < length s)"
  using assms prefix_length_less by fastforce

lemma length_not_gt_iff_eq_length:
  assumes "length s > 0" and "strict_prefix (butlast s) t"
  shows "(\<not> (length s < length t)) = (length s = length t)"
proof -
  have "(\<not> (length s < length t)) = ((length t < length s) \<or> (length s = length t))"
      by (metis not_less_iff_gr_or_eq)
  also have "... = (length s = length t)"
      using assms
      by (simp add:butlast_prefix_imp_length_not_gt)

  finally show ?thesis .
qed

text \<open> Greatest common prefix \<close>

fun gcp :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"gcp [] ys = []" |
"gcp (x # xs) (y # ys) = (if (x = y) then x # gcp xs ys else [])" |
"gcp _ _ = []"

lemma gcp_right [simp]: "gcp xs [] = []"
  by (induct xs, auto)

lemma gcp_append [simp]: "gcp (xs @ ys) (xs @ zs) = xs @ gcp ys zs"
  by (induct xs, auto)

lemma gcp_lb1: "prefix (gcp xs ys) xs"
  apply (induct xs arbitrary: ys, auto)
  apply (case_tac ys, auto)
  done

lemma gcp_lb2: "prefix (gcp xs ys) ys"
  apply (induct ys arbitrary: xs, auto)
  apply (case_tac xs, auto)
  done

interpretation prefix_semilattice: semilattice_inf gcp prefix strict_prefix
proof
  fix xs ys :: "'a list"
  show "prefix (gcp xs ys) xs"
    by (induct xs arbitrary: ys, auto, case_tac ys, auto)
  show "prefix (gcp xs ys) ys"
    by (induct ys arbitrary: xs, auto, case_tac xs, auto)
next
  fix xs ys zs :: "'a list"
  assume "prefix xs ys" "prefix xs zs"
  thus "prefix xs (gcp ys zs)"
    by (simp add: prefix_def, auto)
qed

subsubsection \<open> Lexicographic Order \<close>

lemma lexord_append:
  assumes "(xs\<^sub>1 @ ys\<^sub>1, xs\<^sub>2 @ ys\<^sub>2) \<in> lexord R" "length(xs\<^sub>1) = length(xs\<^sub>2)"
  shows "(xs\<^sub>1, xs\<^sub>2) \<in> lexord R \<or> (xs\<^sub>1 = xs\<^sub>2 \<and> (ys\<^sub>1, ys\<^sub>2) \<in> lexord R)"
using assms
proof (induct xs\<^sub>2 arbitrary: xs\<^sub>1)
  case (Cons x\<^sub>2 xs\<^sub>2') note hyps = this
  from hyps(3) obtain x\<^sub>1 xs\<^sub>1' where xs\<^sub>1: "xs\<^sub>1 = x\<^sub>1 # xs\<^sub>1'" "length(xs\<^sub>1') = length(xs\<^sub>2')"
    by (auto, metis Suc_length_conv)
  with hyps(2) have xcases: "(x\<^sub>1, x\<^sub>2) \<in> R \<or> (xs\<^sub>1' @ ys\<^sub>1, xs\<^sub>2' @ ys\<^sub>2) \<in> lexord R"
    by (auto)
  show ?case
  proof (cases "(x\<^sub>1, x\<^sub>2) \<in> R")
    case True with xs\<^sub>1 show ?thesis
      by (auto)
  next
    case False
    with xcases have "(xs\<^sub>1' @ ys\<^sub>1, xs\<^sub>2' @ ys\<^sub>2) \<in> lexord R"
      by (auto)
    with hyps(1) xs\<^sub>1 have dichot: "(xs\<^sub>1', xs\<^sub>2') \<in> lexord R \<or> (xs\<^sub>1' = xs\<^sub>2' \<and> (ys\<^sub>1, ys\<^sub>2) \<in> lexord R)"
      by (auto)
    have "x\<^sub>1 = x\<^sub>2"
      using False hyps(2) xs\<^sub>1(1) by auto
    with dichot xs\<^sub>1 show ?thesis
      by (simp)
  qed
next
  case Nil thus ?case
    by auto
qed

lemma strict_prefix_lexord_rel:
  "strict_prefix xs ys \<Longrightarrow> (xs, ys) \<in> lexord R"
  by (metis Sublist.strict_prefixE' lexord_append_rightI)

lemma strict_prefix_lexord_left:
  assumes "trans R" "(xs, ys) \<in> lexord R" "strict_prefix xs' xs"
  shows "(xs', ys) \<in> lexord R"
  by (metis assms lexord_trans strict_prefix_lexord_rel)

lemma prefix_lexord_right:
  assumes "trans R" "(xs, ys) \<in> lexord R" "strict_prefix ys ys'"
  shows "(xs, ys') \<in> lexord R"
  by (metis assms lexord_trans strict_prefix_lexord_rel)

lemma lexord_eq_length:
  assumes "(xs, ys) \<in> lexord R" "length xs = length ys"
  shows "\<exists> i. (xs!i, ys!i) \<in> R \<and> i < length xs \<and> (\<forall> j<i. xs!j = ys!j)"
using assms proof (induct xs arbitrary: ys)
  case (Cons x xs) note hyps = this
  then obtain y ys' where ys: "ys = y # ys'" "length ys' = length xs"
    by (metis Suc_length_conv)
  show ?case
  proof (cases "(x, y) \<in> R")
    case True with ys show ?thesis
      by (rule_tac x="0" in exI, simp)
  next
    case False
    with ys hyps(2) have xy: "x = y" "(xs, ys') \<in> lexord R"
      by auto
    with hyps(1,3) ys obtain i where "(xs!i, ys'!i) \<in> R" "i < length xs" "(\<forall> j<i. xs!j = ys'!j)"
      by force
    with xy ys show ?thesis
      apply (rule_tac x="Suc i" in exI)
      apply (auto simp add: less_Suc_eq_0_disj)
    done
  qed
next
  case Nil thus ?case by (auto)
qed

lemma lexord_intro_elems:
  assumes "length xs > i" "length ys > i" "(xs!i, ys!i) \<in> R" "\<forall> j<i. xs!j = ys!j"
  shows "(xs, ys) \<in> lexord R"
using assms proof (induct i arbitrary: xs ys)
  case 0 thus ?case
    by (auto, metis lexord_cons_cons list.exhaust nth_Cons_0)
next
  case (Suc i) note hyps = this
  then obtain x' y' xs' ys' where "xs = x' # xs'" "ys = y' # ys'"
    by (metis Suc_length_conv Suc_lessE)
  moreover with hyps(5) have "\<forall>j<i. xs' ! j = ys' ! j"
    by (auto)
  ultimately show ?case using hyps
    by (auto)
qed

subsection \<open> Distributed Concatenation \<close>

definition uncurry :: "('a \<Rightarrow> 'b \<Rightarrow>  'c) \<Rightarrow> ('a \<times> 'b \<Rightarrow> 'c)" where
[simp]: "uncurry f = (\<lambda>(x, y). f x y)"

definition dist_concat ::
  "'a list set \<Rightarrow> 'a list set \<Rightarrow> 'a list set" (infixr "\<^sup>\<frown>" 100) where
"dist_concat ls1 ls2 = (uncurry (@) ` (ls1 \<times> ls2))"

lemma dist_concat_left_empty [simp]:
  "{} \<^sup>\<frown> ys = {}"
  by (simp add: dist_concat_def)

lemma dist_concat_right_empty [simp]:
  "xs \<^sup>\<frown> {} = {}"
  by (simp add: dist_concat_def)

lemma dist_concat_insert [simp]:
"insert l ls1 \<^sup>\<frown> ls2 = ((@) l ` ( ls2)) \<union> (ls1 \<^sup>\<frown> ls2)"
  by (auto simp add: dist_concat_def)

subsection \<open> List Domain and Range \<close>

abbreviation seq_dom :: "'a list \<Rightarrow> nat set" ("dom\<^sub>l") where
"seq_dom xs \<equiv> {0..<length xs}"

abbreviation seq_ran :: "'a list \<Rightarrow> 'a set" ("ran\<^sub>l") where
"seq_ran xs \<equiv> set xs"

subsection \<open> Extracting List Elements \<close>

definition seq_extract :: "nat set \<Rightarrow> 'a list \<Rightarrow> 'a list" (infix "\<upharpoonleft>\<^sub>l" 80) where
"seq_extract A xs = nths xs A"

lemma seq_extract_Nil [simp]: "A \<upharpoonleft>\<^sub>l [] = []"
  by (simp add: seq_extract_def)

lemma seq_extract_Cons:
  "A \<upharpoonleft>\<^sub>l (x # xs) = (if 0 \<in> A then [x] else []) @ {j. Suc j \<in> A} \<upharpoonleft>\<^sub>l xs"
  by (simp add: seq_extract_def nths_Cons)

lemma seq_extract_empty [simp]: "{} \<upharpoonleft>\<^sub>l xs = []"
  by (simp add: seq_extract_def)

lemma seq_extract_ident [simp]: "{0..<length xs} \<upharpoonleft>\<^sub>l xs = xs"
  unfolding list_eq_iff_nth_eq
  by (auto simp add: seq_extract_def length_nths atLeast0LessThan)

lemma seq_extract_split:
  assumes "i \<le> length xs"
  shows "{0..<i} \<upharpoonleft>\<^sub>l xs @ {i..<length xs} \<upharpoonleft>\<^sub>l xs = xs"
using assms
proof (induct xs arbitrary: i)
  case Nil thus ?case by (simp add: seq_extract_def)
next
  case (Cons x xs) note hyp = this
  have "{j. Suc j < i} = {0..<i - 1}"
    by (auto)
  moreover have "{j. i \<le> Suc j \<and> j < length xs} = {i - 1..<length xs}"
    by (auto)
  ultimately show ?case
    using hyp by (force simp add: seq_extract_def nths_Cons)
qed

lemma seq_extract_append:
  "A \<upharpoonleft>\<^sub>l (xs @ ys) = (A \<upharpoonleft>\<^sub>l xs) @ ({j. j + length xs \<in> A} \<upharpoonleft>\<^sub>l ys)"
  by (simp add: seq_extract_def nths_append)

lemma seq_extract_range: "A \<upharpoonleft>\<^sub>l xs = (A \<inter> dom\<^sub>l(xs)) \<upharpoonleft>\<^sub>l xs"
  apply (auto simp add: seq_extract_def nths_def)
  apply (metis (no_types, lifting) atLeastLessThan_iff filter_cong in_set_zip nth_mem set_upt)
done

lemma seq_extract_out_of_range:
  "A \<inter> dom\<^sub>l(xs) = {} \<Longrightarrow> A \<upharpoonleft>\<^sub>l xs = []"
  by (metis seq_extract_def seq_extract_range nths_empty)

lemma seq_extract_length [simp]:
  "length (A \<upharpoonleft>\<^sub>l xs) = card (A \<inter> dom\<^sub>l(xs))"
proof -
  have "{i. i < length(xs) \<and> i \<in> A} = (A \<inter> {0..<length(xs)})"
    by (auto)
  thus ?thesis
    by (simp add: seq_extract_def length_nths)
qed

lemma seq_extract_Cons_atLeastLessThan:
  assumes "m < n"
  shows "{m..<n} \<upharpoonleft>\<^sub>l (x # xs) = (if (m = 0) then x # ({0..<n-1} \<upharpoonleft>\<^sub>l xs) else {m-1..<n-1} \<upharpoonleft>\<^sub>l xs)"
proof -
  have "{j. Suc j < n} = {0..<n - Suc 0}"
    by (auto)
  moreover have "{j. m \<le> Suc j \<and> Suc j < n} = {m - Suc 0..<n - Suc 0}"
    by (auto)

  ultimately show ?thesis using assms
    by (auto simp add: seq_extract_Cons)
qed

lemma seq_extract_singleton:
  assumes "i < length xs"
  shows "{i} \<upharpoonleft>\<^sub>l xs = [xs ! i]"
  using assms
  apply (induct xs arbitrary: i)
  apply (auto simp add: seq_extract_Cons)
  apply (rename_tac xs i)
  apply (subgoal_tac "{j. Suc j = i} = {i - 1}")
  apply (auto)
done

lemma seq_extract_as_map:
  assumes "m < n" "n \<le> length xs"
  shows "{m..<n} \<upharpoonleft>\<^sub>l xs = map (nth xs) [m..<n]"
using assms proof (induct xs arbitrary: m n)
  case Nil thus ?case by simp
next
  case (Cons x xs)
  have "[m..<n] = m # [m+1..<n]"
    using Cons.prems(1) upt_eq_Cons_conv by blast
  moreover have "map (nth (x # xs)) [Suc m..<n] = map (nth xs) [m..<n-1]"
    by (simp add: map_nth_Cons_atLeastLessThan)
  ultimately show ?case
    using Cons upt_rec
    by (auto simp add: seq_extract_Cons_atLeastLessThan)
qed

lemma seq_append_as_extract:
  "xs = ys @ zs \<longleftrightarrow> (\<exists> i\<le>length(xs). ys = {0..<i} \<upharpoonleft>\<^sub>l xs \<and> zs = {i..<length(xs)} \<upharpoonleft>\<^sub>l xs)"
proof
  assume xs: "xs = ys @ zs"
  moreover have "ys = {0..<length ys} \<upharpoonleft>\<^sub>l (ys @ zs)"
    by (simp add: seq_extract_append)
  moreover have "zs = {length ys..<length ys + length zs} \<upharpoonleft>\<^sub>l (ys @ zs)"
  proof -
    have "{length ys..<length ys + length zs} \<inter> {0..<length ys} = {}"
      by auto
    moreover have s1: "{j. j < length zs} = {0..<length zs}"
      by auto
    ultimately show ?thesis
      by (simp add: seq_extract_append seq_extract_out_of_range)
  qed
  ultimately show "(\<exists> i\<le>length(xs). ys = {0..<i} \<upharpoonleft>\<^sub>l xs \<and> zs = {i..<length(xs)} \<upharpoonleft>\<^sub>l xs)"
    by (rule_tac x="length ys" in exI, auto)
next
  assume "\<exists>i\<le>length xs. ys = {0..<i} \<upharpoonleft>\<^sub>l xs \<and> zs = {i..<length xs} \<upharpoonleft>\<^sub>l xs"
  thus "xs = ys @ zs"
    by (auto simp add: seq_extract_split)
qed

subsection \<open> Filtering a list according to a set \<close>

definition seq_filter :: "'a list \<Rightarrow> 'a set \<Rightarrow> 'a list" (infix "\<restriction>\<^sub>l" 80) where
"seq_filter xs A = filter (\<lambda> x. x \<in> A) xs"

lemma seq_filter_Cons_in [simp]:
  "x \<in> cs \<Longrightarrow> (x # xs) \<restriction>\<^sub>l cs = x # (xs \<restriction>\<^sub>l cs)"
  by (simp add: seq_filter_def)

lemma seq_filter_Cons_out [simp]:
  "x \<notin> cs \<Longrightarrow> (x # xs) \<restriction>\<^sub>l cs = (xs \<restriction>\<^sub>l cs)"
  by (simp add: seq_filter_def)

lemma seq_filter_Nil [simp]: "[] \<restriction>\<^sub>l A = []"
  by (simp add: seq_filter_def)

lemma seq_filter_empty [simp]: "xs \<restriction>\<^sub>l {} = []"
  by (simp add: seq_filter_def)

lemma seq_filter_append: "(xs @ ys) \<restriction>\<^sub>l A = (xs \<restriction>\<^sub>l A) @ (ys \<restriction>\<^sub>l A)"
  by (simp add: seq_filter_def)

lemma seq_filter_UNIV [simp]: "xs \<restriction>\<^sub>l UNIV = xs"
  by (simp add: seq_filter_def)

lemma seq_filter_twice [simp]: "(xs \<restriction>\<^sub>l A) \<restriction>\<^sub>l B = xs \<restriction>\<^sub>l (A \<inter> B)"
  by (simp add: seq_filter_def)

subsection \<open> Minus on lists \<close>

instantiation list :: (type) minus
begin

text \<open> We define list minus so that if the second list is not a prefix of the first, then an arbitrary
        list longer than the combined length is produced. Thus we can always determined from the output
        whether the minus is defined or not. \<close>

definition "xs - ys = (if (prefix ys xs) then drop (length ys) xs else [])"

instance ..
end

lemma minus_cancel [simp]: "xs - xs = []"
  by (simp add: minus_list_def)

lemma append_minus [simp]: "(xs @ ys) - xs = ys"
  by (simp add: minus_list_def)

lemma minus_right_nil [simp]: "xs - [] = xs"
  by (simp add: minus_list_def)

lemma list_concat_minus_list_concat: "(s @ t) - (s @ z) = t - z"
  by (simp add: minus_list_def)

lemma length_minus_list: "y \<le> x \<Longrightarrow> length(x - y) = length(x) - length(y)"
  by (simp add: less_eq_list_def minus_list_def)

lemma map_list_minus:
  "xs \<le> ys \<Longrightarrow> map f (ys - xs) = map f ys - map f xs"
  by (simp add: drop_map less_eq_list_def map_mono_prefix minus_list_def)

lemma list_minus_first_tl [simp]:
  "[x] \<le> xs \<Longrightarrow> (xs - [x]) = tl xs"
  by (metis Prefix_Order.prefixE append.left_neutral append_minus list.sel(3) not_Cons_self2 tl_append2)

text \<open> Extra lemmas about @{term prefix} and @{term strict_prefix} \<close>

lemma prefix_concat_minus:
  assumes "prefix xs ys"
  shows "xs @ (ys - xs) = ys"
  using assms by (metis minus_list_def prefix_drop)

lemma prefix_minus_concat:
  assumes "prefix s t"
  shows "(t - s) @ z = (t @ z) - s"
  using assms by (simp add: Sublist.prefix_length_le minus_list_def)

lemma strict_prefix_minus_not_empty:
  assumes "strict_prefix xs ys"
  shows "ys - xs \<noteq> []"
  using assms by (metis append_Nil2 prefix_concat_minus strict_prefix_def)

lemma strict_prefix_diff_minus:
  assumes "prefix xs ys" and "xs \<noteq> ys"
  shows "(ys - xs) \<noteq> []"
  using assms by (simp add: strict_prefix_minus_not_empty)

lemma length_tl_list_minus_butlast_gt_zero:
  assumes "length s < length t" and "strict_prefix (butlast s) t" and "length s > 0"
  shows "length (tl (t - (butlast s))) > 0"
  using assms
  by (metis Nitpick.size_list_simp(2) butlast_snoc hd_Cons_tl length_butlast length_greater_0_conv length_tl less_trans nat_neq_iff strict_prefix_minus_not_empty prefix_order.dual_order.strict_implies_order prefix_concat_minus)

lemma list_minus_butlast_eq_butlast_list:
  assumes "length t = length s" and "strict_prefix (butlast s) t"
  shows "t - (butlast s) = [last t]"
  using assms
  by (metis append_butlast_last_id append_eq_append_conv butlast.simps(1) length_butlast less_numeral_extra(3) list.size(3) prefix_order.dual_order.strict_implies_order prefix_concat_minus prefix_length_less)

lemma butlast_strict_prefix_length_lt_imp_last_tl_minus_butlast_eq_last:
  assumes "length s > 0" "strict_prefix (butlast s) t" "length s < length t"
  shows "last (tl (t - (butlast s))) = (last t)"
  using assms by (metis last_append last_tl length_tl_list_minus_butlast_gt_zero less_numeral_extra(3) list.size(3) append_minus strict_prefix_eq_exists)

lemma tl_list_minus_butlast_not_empty:
  assumes "strict_prefix (butlast s) t" and "length s > 0" and "length t > length s"
  shows "tl (t - (butlast s)) \<noteq> []"
  using assms length_tl_list_minus_butlast_gt_zero by fastforce

lemma tl_list_minus_butlast_empty:
  assumes "strict_prefix (butlast s) t" and "length s > 0" and "length t = length s"
  shows "tl (t - (butlast s)) = []"
  using assms by (simp add: list_minus_butlast_eq_butlast_list)

lemma concat_minus_list_concat_butlast_eq_list_minus_butlast:
  assumes "prefix (butlast u) s"
  shows "(t @ s) - (t @ (butlast u)) = s - (butlast u)"
  using assms by (metis append_assoc prefix_concat_minus append_minus)

lemma tl_list_minus_butlast_eq_empty:
  assumes "strict_prefix (butlast s) t" and "length s = length t"
  shows "tl (t - (butlast s)) = []"
  using assms by (metis list.sel(3) list_minus_butlast_eq_butlast_list)

(* this can be shown using length_tl, but care is needed when list is empty? *)
lemma prefix_length_tl_minus:
  assumes "strict_prefix s t"
  shows "length (tl (t-s)) = (length (t-s)) - 1"
  by (auto)

lemma length_list_minus:
  assumes "strict_prefix s t"
  shows "length(t - s) = length(t) - length(s)"
  using assms by (simp add: minus_list_def prefix_order.dual_order.strict_implies_order)

subsection \<open> Laws on @{term take}, @{term drop}, and @{term nths} \<close>

lemma take_prefix: "m \<le> n \<Longrightarrow> take m xs \<le> take n xs"
  by (metis Prefix_Order.prefixI append_take_drop_id min_absorb2 take_append take_take)

lemma nths_atLeastAtMost_0_take: "nths xs {0..m} = take (Suc m) xs"
  by (metis atLeast0AtMost lessThan_Suc_atMost nths_upt_eq_take)

lemma nths_atLeastLessThan_0_take: "nths xs {0..<m} = take m xs"
  by (simp add: atLeast0LessThan)

lemma nths_atLeastAtMost_prefix: "m \<le> n \<Longrightarrow> nths xs {0..m} \<le> nths xs {0..n}"
  by (simp add: nths_atLeastAtMost_0_take take_prefix)

lemma sorted_nths_atLeastAtMost_0: "\<lbrakk> m \<le> n; sorted (nths xs {0..n}) \<rbrakk> \<Longrightarrow> sorted (nths xs {0..m})"
  using nths_atLeastAtMost_prefix sorted_prefix by blast

lemma sorted_nths_atLeastLessThan_0: "\<lbrakk> m \<le> n; sorted (nths xs {0..<n}) \<rbrakk> \<Longrightarrow> sorted (nths xs {0..<m})"
  by (metis atLeast0LessThan nths_upt_eq_take sorted_prefix take_prefix)

lemma list_augment_as_update:
  "k < length xs \<Longrightarrow> list_augment xs k x = list_update xs k x"
  by (metis list_augment_def list_augment_idem list_update_overwrite)

lemma nths_list_update_out: "k \<notin> A \<Longrightarrow> nths (list_update xs k x) A = nths xs A"
  apply (induct xs arbitrary: k x A)
   apply (auto)
  apply (rename_tac a xs k x A)
  apply (case_tac k)
   apply (auto simp add: nths_Cons)
  done

lemma nths_list_augment_out: "\<lbrakk> k < length xs; k \<notin> A \<rbrakk> \<Longrightarrow> nths (list_augment xs k x) A = nths xs A"
  by (simp add: list_augment_as_update nths_list_update_out)

end


theory UFDS
  imports Main
begin
fun fpow where
  "fpow f 0 = id"
| "fpow f (Suc n) = f o fpow f n"

lemma fpow_is_compow[simp]: "fpow = op ^^"
proof (intro ext)
  fix f n x
  show "fpow f n x = (f^^n) x"
    apply (induction n arbitrary: x)
     apply auto
    done
qed

(*location of array contains parent*)

partial_function (tailrec) find' where
  "find' ls i = (if ls!i = i then i else find' ls (ls!i))"

thm find'.simps

definition "init n = [0..<n]"
definition "pred ls i = ls!i"
definition "is_root ls i \<longleftrightarrow> pred ls i = i"
(*definition find where "find ls i == fpow (pred ls) (length ls) i"*)
definition "invar ls \<longleftrightarrow>
  (set ls \<subseteq> {0..<length ls})
\<and> (\<forall>i<length ls. \<exists>n\<in>{0..<length ls}. is_root ls (fpow (pred ls) n i)) "

definition union where "union i j ls = ls[find' ls i := find' ls j]"

type_synonym eqcs = "nat \<Rightarrow> nat set"

definition \<alpha> :: "nat list \<Rightarrow> eqcs" where "\<alpha> ls i =
  (if i<length ls then {j. j<length ls \<and> find' ls j = find' ls i} else {i})"

definition union_eqc :: "nat \<Rightarrow> nat \<Rightarrow> eqcs \<Rightarrow> eqcs"
  where
  "union_eqc x y eqc i = (if i \<in> eqc x \<union> eqc y then eqc x \<union> eqc y else eqc i)"

value "([5,1,2]::nat list)[1:=2]"

lemma
  assumes "invar ls" "x<length ls" "y<length ls"
  shows "length ls = length (union x y ls)"
  using assms
proof(induction ls arbitrary: x y)
  case Nil
  then show ?case by auto
next
  case (Cons a ls)
  then show ?case
    unfolding union_def
    by (metis length_list_update)
qed

lemma
  assumes "invar ls" "x<length ls" "y<length ls"
  shows "invar (union x y ls)"
  apply(auto simp:invar_def)

  oops

lemma
  assumes "invar ls" "x<length ls" "y<length ls"
  shows "\<alpha> (union x y ls) = union_eqc x y (\<alpha> ls)"

lemma "invar [0..<N]"
proof(induction N)
    case 0
    then show ?case
      unfolding invar_def
      by(auto)
  next
    case (Suc N)
    then show ?case

      unfolding invar_def
      apply(auto)
      have "n = N \<or> n \<in> {0..<N}" (is "?C1 \<or> ?C2")

      qed

  thm find'.simps

lemma "\<alpha> [0..<N] i = {i}"
  apply (auto simp add: \<alpha>_def)
  apply (auto simp add: \<alpha>_def find'.simps split del: if_split)

  apply (subst (asm) find'.simps)
  apply (subst (asm) (2) find'.simps)
  apply auto
  done

lemma "find "

fun natbelow :: "nat \<Rightarrow> nat list" where
  "natbelow 0 = [0]"
| "natbelow (Suc n) = (Suc n) # natbelow n"

value "rev [1::nat,2,3]"

fun init :: "nat \<Rightarrow> nat list" where
 "init n = rev (natbelow n)"

value "init 10"
value "[0..<10]"

term upto
term upt

fun findParentAux :: "nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> nat" where
  "findParentAux n 0 xs  = (xs!n)"
| "findParentAux n (Suc b) xs = (if (xs!n = n) then n else findParentAux (xs!n) b xs)"

fun findParent :: "nat \<Rightarrow> nat list \<Rightarrow> nat" where
  "findParent n xs = findParentAux n (size xs) xs"

fun isSameSet :: "nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> bool" where
  "isSameSet a b l = (findParent a l = findParent b l)"

value "init 10"
value "findParent 5 [0, 1, 2, 3, 4, 5, 6]"
value "isSameSet 2 3 [0, 1, 4, 5, 5, 1]"

fun replace :: "nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> nat list" where
  "replace _ _ [] = []"
| "replace a b (x#xs) = (if (a = x) then b#xs else x#(replace a b xs))"

value "let ls = [0::nat,1,2,3,4,5,6] in ls[4:=9]"

fun union :: "nat \<Rightarrow> nat \<Rightarrow> nat list \<Rightarrow> nat list" where
  "union a b ls = (if (isSameSet a b ls) then ls else (replace (findParent a ls) b ls))"

value "isSameSet 2 3 (union 5 3 [0, 1, 2, 3, 4, 2, 6])"
value "union 5 0 [0, 1, 2, 3, 4, 2, 6]"
value "union 1 0 [1, 0]"

fun valid :: "nat list \<Rightarrow> bool" where
  "valid [] = False"
| "valid t = (\<forall>x \<in> set t. t!x = x)"

value "valid [1, 0]"
value "init 10"
value "valid (init 10)"

fun sizeufd :: "nat list \<Rightarrow> nat" where
  "sizeufd fn = size fn + 1"

(* here be dragons *)

lemma isSameSetWorks:"\<not> isSameSet a b t \<Longrightarrow> findParent a t \<noteq> findParent b t"
  by simp

lemma unionWorks:"valid t \<Longrightarrow> n \<ge> max a b \<Longrightarrow> isSameSet a b (union a b (init n))"
  apply(auto)

end


(*  Title:      HOL/Auth/Guard/Extensions.thy
    Author:     Frederic Blanqui, University of Cambridge Computer Laboratory
    Copyright   2001  University of Cambridge
*)

section \<open>Extensions to Standard Theories\<close>

theory Extensions
imports "../Event"
begin

subsection\<open>Extensions to Theory \<open>Set\<close>\<close>

lemma eq: "[| \<And>x. x\<in>A \<Longrightarrow> x\<in>B; \<And>x. x\<in>B \<Longrightarrow> x\<in>A |] ==> A=B"
by auto

lemma insert_Un: "P ({x} \<union> A) \<Longrightarrow> P (insert x A)"
by simp

lemma in_sub: "x\<in>A \<Longrightarrow> {x}\<subseteq>A"
by auto

subsection\<open>Extensions to Theory \<open>List\<close>\<close>

subsubsection\<open>"remove l x" erase the first element of "l" equal to "x"\<close>

primrec remove :: "'a list => 'a => 'a list" where
"remove [] y = []" |
"remove (x#xs) y = (if x=y then xs else x # remove xs y)"

lemma set_remove: "set (remove l x) <= set l"
by (induct l, auto)

subsection\<open>Extensions to Theory \<open>Message\<close>\<close>

subsubsection\<open>declarations for tactics\<close>

declare analz_subset_parts [THEN subsetD, dest]
declare parts_insert2 [simp]
declare analz_cut [dest]
declare if_split_asm [split]
declare analz_insertI [intro]
declare Un_Diff [simp]

subsubsection\<open>extract the agent number of an Agent message\<close>

primrec agt_nb :: "msg => agent" where
"agt_nb (Agent A) = A"

subsubsection\<open>messages that are pairs\<close>

definition is_MPair :: "msg => bool" where
"is_MPair X == \<exists>Y Z. X = \<lbrace>Y,Z\<rbrace>"

declare is_MPair_def [simp]

lemma MPair_is_MPair [iff]: "is_MPair \<lbrace>X,Y\<rbrace>"
by simp

lemma Agent_isnt_MPair [iff]: "~ is_MPair (Agent A)"
by simp

lemma Number_isnt_MPair [iff]: "~ is_MPair (Number n)"
by simp

lemma Key_isnt_MPair [iff]: "~ is_MPair (Key K)"
by simp

lemma Nonce_isnt_MPair [iff]: "~ is_MPair (Nonce n)"
by simp

lemma Hash_isnt_MPair [iff]: "~ is_MPair (Hash X)"
by simp

lemma Crypt_isnt_MPair [iff]: "~ is_MPair (Crypt K X)"
by simp

abbreviation
  not_MPair :: "msg => bool" where
  "not_MPair X == ~ is_MPair X"

lemma is_MPairE: "[| is_MPair X ==> P; not_MPair X ==> P |] ==> P"
by auto

declare is_MPair_def [simp del]

definition has_no_pair :: "msg set => bool" where
"has_no_pair H == \<forall>X Y. \<lbrace>X,Y\<rbrace> \<notin> H"

declare has_no_pair_def [simp]

subsubsection\<open>well-foundedness of messages\<close>

lemma wf_Crypt1 [iff]: "Crypt K X ~= X"
by (induct X, auto)

lemma wf_Crypt2 [iff]: "X ~= Crypt K X"
by (induct X, auto)

lemma parts_size: "X \<in> parts {Y} \<Longrightarrow> X=Y \<or> size X < size Y"
by (erule parts.induct, auto)

lemma wf_Crypt_parts [iff]: "Crypt K X \<notin> parts {X}"
by (auto dest: parts_size)

subsubsection\<open>lemmas on keysFor\<close>

definition usekeys :: "msg set => key set" where
"usekeys G \<equiv> {K. \<exists>Y. Crypt K Y \<in> G}"

lemma finite_keysFor [intro]: "finite G ==> finite (keysFor G)"
apply (simp add: keysFor_def)
apply (rule finite_imageI)
apply (induct G rule: finite_induct)
apply auto
apply (case_tac "\<exists>K X. x = Crypt K X", clarsimp)
apply (subgoal_tac "{Ka. \<exists>Xa. (Ka=K \<and> Xa=X) \<or> Crypt Ka Xa \<in> F}
= insert K (usekeys F)", auto simp: usekeys_def)
by (subgoal_tac "{K. \<exists>X. Crypt K X = x \<or> Crypt K X \<in> F} = usekeys F",
auto simp: usekeys_def)

subsubsection\<open>lemmas on parts\<close>

lemma parts_sub: "[| X \<in> parts G; G \<subseteq> H |] ==> X \<in> parts H"
by (auto dest: parts_mono)

lemma parts_Diff [dest]: "X \<in> parts (G - H) \<Longrightarrow> X \<in> parts G"
by (erule parts_sub, auto)

lemma parts_Diff_notin: "[| Y \<notin> H; Nonce n \<notin> parts (H - {Y}) |]
==> Nonce n \<notin> parts H"
by simp

lemmas parts_insert_substI = parts_insert [THEN ssubst]
lemmas parts_insert_substD = parts_insert [THEN sym, THEN ssubst]

lemma finite_parts_msg [iff]: "finite (parts {X})"
by (induct X, auto)

lemma finite_parts [intro]: "finite H \<Longrightarrow> finite (parts H)"
apply (erule finite_induct, simp)
by (rule parts_insert_substI, simp)

lemma parts_parts: "[| X \<in> parts {Y}; Y \<in> parts G |] ==> X \<in> parts G"
by (frule parts_cut, auto)

lemma parts_parts_parts: "[| X \<in> parts {Y}; Y \<in> parts {Z}; Z \<in> parts G |] ==> X \<in> parts G"
by (auto dest: parts_parts)

lemma parts_parts_Crypt: "[| Crypt K X \<in> parts G; Nonce n \<in> parts {X} |]
==> Nonce n \<in> parts G"
by (blast intro: parts.Body dest: parts_parts)

subsubsection\<open>lemmas on synth\<close>

lemma synth_sub: "[| X \<in> synth G; G \<subseteq> H |] ==> X \<in> synth H"
by (auto dest: synth_mono)

lemma Crypt_synth [rule_format]: "[| X \<in> synth G; Key K \<notin> G |] ==>
Crypt K Y \<in> parts {X} \<longrightarrow> Crypt K Y \<in> parts G"
by (erule synth.induct, auto dest: parts_sub)

subsubsection\<open>lemmas on analz\<close>

lemma analz_UnI1 [intro]: "X \<in> analz G ==> X \<in> analz (G \<union> H)"
  by (subgoal_tac "G <= G Un H") (blast dest: analz_mono)+

lemma analz_sub: "[| X \<in> analz G; G \<subseteq> H |] ==> X \<in> analz H"
by (auto dest: analz_mono)

lemma analz_Diff [dest]: "X \<in> analz (G - H) \<Longrightarrow> X \<in> analz G"
by (erule analz.induct, auto)

lemmas in_analz_subset_cong = analz_subset_cong [THEN subsetD]

lemma analz_eq: "A=A' ==> analz A = analz A'"
by auto

lemmas insert_commute_substI = insert_commute [THEN ssubst]

lemma analz_insertD:
     "[| Crypt K Y \<in> H; Key (invKey K) \<in> H |] ==> analz (insert Y H) = analz H"
by (blast intro: analz.Decrypt analz_insert_eq)

lemma must_decrypt [rule_format,dest]: "[| X \<in> analz H; has_no_pair H |] ==>
X \<notin> H \<longrightarrow> (\<exists>K Y. Crypt K Y \<in> H \<and> Key (invKey K) \<in> H)"
by (erule analz.induct, auto)

lemma analz_needs_only_finite: "X \<in> analz H \<Longrightarrow> \<exists>G. G \<subseteq> H \<and> finite G"
by (erule analz.induct, auto)

lemma notin_analz_insert: "X \<notin> analz (insert Y G) \<Longrightarrow> X \<notin> analz G"
by auto

subsubsection\<open>lemmas on parts, synth and analz\<close>

lemma parts_invKey [rule_format,dest]:"X \<in> parts {Y} \<Longrightarrow>
X \<in> analz (insert (Crypt K Y) H) \<longrightarrow> X \<notin> analz H \<longrightarrow> Key (invKey K) \<in> analz H"
by (erule parts.induct, auto dest: parts.Fst parts.Snd parts.Body)

lemma in_analz: "Y \<in> analz H \<Longrightarrow> \<exists>X. X \<in> H \<and> Y \<in> parts {X}"
by (erule analz.induct, auto intro: parts.Fst parts.Snd parts.Body)

lemmas in_analz_subset_parts = analz_subset_parts [THEN subsetD]

lemma Crypt_synth_insert: "[| Crypt K X \<in> parts (insert Y H);
Y \<in> synth (analz H); Key K \<notin> analz H |] ==> Crypt K X \<in> parts H"
apply (drule parts_insert_substD, clarify)
apply (frule in_sub)
apply (frule parts_mono)
apply auto
done

subsubsection\<open>greatest nonce used in a message\<close>

fun greatest_msg :: "msg => nat"
where
  "greatest_msg (Nonce n) = n"
| "greatest_msg \<lbrace>X,Y\<rbrace> = max (greatest_msg X) (greatest_msg Y)"
| "greatest_msg (Crypt K X) = greatest_msg X"
| "greatest_msg other = 0"

lemma greatest_msg_is_greatest: "Nonce n \<in> parts {X} \<Longrightarrow> n \<le> greatest_msg X"
by (induct X, auto)

subsubsection\<open>sets of keys\<close>

definition keyset :: "msg set => bool" where
"keyset G \<equiv> \<forall>X. X \<in> G \<longrightarrow> (\<exists>K. X = Key K)"

lemma keyset_in [dest]: "[| keyset G; X \<in> G |] ==> \<exists>K. X = Key K"
by (auto simp: keyset_def)

lemma MPair_notin_keyset [simp]: "keyset G ==> \<lbrace>X,Y\<rbrace> \<notin> G"
by auto

lemma Crypt_notin_keyset [simp]: "keyset G \<Longrightarrow> Crypt K X \<notin> G"
by auto

lemma Nonce_notin_keyset [simp]: "keyset G \<Longrightarrow> Nonce n \<notin> G"
by auto

lemma parts_keyset [simp]: "keyset G ==> parts G = G"
by (auto, erule parts.induct, auto)

subsubsection\<open>keys a priori necessary for decrypting the messages of G\<close>

definition keysfor :: "msg set => msg set" where
"keysfor G == Key ` keysFor (parts G)"

lemma keyset_keysfor [iff]: "keyset (keysfor G)"
by (simp add: keyset_def keysfor_def, blast)

lemma keyset_Diff_keysfor [simp]: "keyset H ==> keyset (H - keysfor G)"
by (auto simp: keyset_def)

lemma keysfor_Crypt: "Crypt K X \<in> parts G \<Longrightarrow> Key (invKey K) \<in> keysfor G"
by (auto simp: keysfor_def Crypt_imp_invKey_keysFor)

lemma no_key_no_Crypt: "Key K \<notin> keysfor G \<Longrightarrow> Crypt (invKey K) X \<notin> parts G"
by (auto dest: keysfor_Crypt)

lemma finite_keysfor [intro]: "finite G ==> finite (keysfor G)"
by (auto simp: keysfor_def intro: finite_UN_I)

subsubsection\<open>only the keys necessary for G are useful in analz\<close>

lemma analz_keyset: "keyset H ==>
analz (G Un H) = H - keysfor G Un (analz (G Un (H Int keysfor G)))"
apply (rule eq)
apply (erule analz.induct, blast)
apply (simp, blast)
apply (simp, blast)
apply (case_tac "Key (invKey K) \<in> H - keysfor G", clarsimp)
apply (drule_tac X=X in no_key_no_Crypt)
by (auto intro: analz_sub)

lemmas analz_keyset_substD = analz_keyset [THEN sym, THEN ssubst]

subsection\<open>Extensions to Theory \<open>Event\<close>\<close>

subsubsection\<open>general protocol properties\<close>

definition is_Says :: "event => bool" where
"is_Says ev == (\<exists>A B X. ev = Says A B X)"

lemma is_Says_Says [iff]: "is_Says (Says A B X)"
by (simp add: is_Says_def)

(* one could also require that Gets occurs after Says
but this is sufficient for our purpose *)
definition Gets_correct :: "event list set => bool" where
"Gets_correct p == \<forall>evs B X. evs \<in> p \<longrightarrow> Gets B X \<in> set evs
\<longrightarrow> (\<exists>A. Says A B X \<in> set evs)"

lemma Gets_correct_Says: "[| Gets_correct p; Gets B X # evs \<in> p |]
==> \<exists>A. Says A B X \<in> set evs"
apply (simp add: Gets_correct_def)
by (drule_tac x="Gets B X # evs" in spec, auto)

definition one_step :: "event list set => bool" where
"one_step p == \<forall>evs ev. ev#evs \<in> p \<longrightarrow> evs \<in> p"

lemma one_step_Cons [dest]: "[| one_step p; ev#evs \<in> p |] ==> evs \<in> p"
by (unfold one_step_def, blast)

lemma one_step_app: "[| evs@evs' \<in> p; one_step p; [] \<in> p |] ==> evs' \<in> p"
by (induct evs, auto)

lemma trunc: "[| evs @ evs' \<in> p; one_step p |] ==> evs' \<in> p"
by (induct evs, auto)

definition has_only_Says :: "event list set => bool" where
"has_only_Says p \<equiv> \<forall>evs ev. evs \<in> p \<longrightarrow> ev \<in> set evs
\<longrightarrow> (\<exists>A B X. ev = Says A B X)"

lemma has_only_SaysD: "[| ev \<in> set evs; evs \<in> p; has_only_Says p |]
==> \<exists>A B X. ev = Says A B X"
by (unfold has_only_Says_def, blast)

lemma in_has_only_Says [dest]: "[| has_only_Says p; evs \<in> p; ev \<in> set evs |]
==> \<exists>A B X. ev = Says A B X"
by (auto simp: has_only_Says_def)

lemma has_only_Says_imp_Gets_correct [simp]: "has_only_Says p
==> Gets_correct p"
by (auto simp: has_only_Says_def Gets_correct_def)

subsubsection\<open>lemma on knows\<close>

lemma Says_imp_spies2: "Says A B \<lbrace>X,Y\<rbrace> \<in> set evs \<Longrightarrow> Y \<in> parts (spies evs)"
by (drule Says_imp_spies, drule parts.Inj, drule parts.Snd, simp)

lemma Says_not_parts: "[| Says A B X \<in> set evs; Y \<notin> parts (spies evs) |]
==> Y \<notin> parts {X}"
by (auto dest: Says_imp_spies parts_parts)

subsubsection\<open>knows without initState\<close>

primrec knows' :: "agent => event list => msg set" where
  knows'_Nil: "knows' A [] = {}" |
  knows'_Cons0:
 "knows' A (ev # evs) = (
   if A = Spy then (
     case ev of
       Says A' B X => insert X (knows' A evs)
     | Gets A' X => knows' A evs
     | Notes A' X => if A' \<in> bad then insert X (knows' A evs) else knows' A evs
   ) else (
     case ev of
       Says A' B X => if A=A' then insert X (knows' A evs) else knows' A evs
     | Gets A' X => if A=A' then insert X (knows' A evs) else knows' A evs
     | Notes A' X => if A=A' then insert X (knows' A evs) else knows' A evs
   ))"

abbreviation
  spies' :: "event list => msg set" where
  "spies' == knows' Spy"

subsubsection\<open>decomposition of knows into knows' and initState\<close>

lemma knows_decomp: "knows A evs = knows' A evs Un (initState A)"
by (induct evs, auto split: event.split simp: knows.simps)

lemmas knows_decomp_substI = knows_decomp [THEN ssubst]
lemmas knows_decomp_substD = knows_decomp [THEN sym, THEN ssubst]

lemma knows'_sub_knows: "knows' A evs <= knows A evs"
by (auto simp: knows_decomp)

lemma knows'_Cons: "knows' A (ev#evs) = knows' A [ev] Un knows' A evs"
by (induct ev, auto)

lemmas knows'_Cons_substI = knows'_Cons [THEN ssubst]
lemmas knows'_Cons_substD = knows'_Cons [THEN sym, THEN ssubst]

lemma knows_Cons: "knows A (ev#evs) = initState A Un knows' A [ev]
Un knows A evs"
apply (simp only: knows_decomp)
apply (rule_tac s="(knows' A [ev] Un knows' A evs) Un initState A" in trans)
apply (simp only: knows'_Cons [of A ev evs] Un_ac)
apply blast
done

lemmas knows_Cons_substI = knows_Cons [THEN ssubst]
lemmas knows_Cons_substD = knows_Cons [THEN sym, THEN ssubst]

lemma knows'_sub_spies': "[| evs \<in> p; has_only_Says p; one_step p |]
==> knows' A evs \<subseteq> spies' evs"
by (induct evs, auto split: event.splits)

subsubsection\<open>knows' is finite\<close>

lemma finite_knows' [iff]: "finite (knows' A evs)"
by (induct evs, auto split: event.split simp: knows.simps)

subsubsection\<open>monotonicity of knows\<close>

lemma knows_sub_Cons: "knows A evs <= knows A (ev#evs)"
by(cases A, induct evs, auto simp: knows.simps split:event.split)

lemma knows_ConsI: "X \<in> knows A evs \<Longrightarrow> X \<in> knows A (ev#evs)"
by (auto dest: knows_sub_Cons [THEN subsetD])

lemma knows_sub_app: "knows A evs <= knows A (evs @ evs')"
apply (induct evs, auto)
apply (simp add: knows_decomp)
apply (rename_tac a b c)
by (case_tac a, auto simp: knows.simps)

subsubsection\<open>maximum knowledge an agent can have
includes messages sent to the agent\<close>

primrec knows_max' :: "agent => event list => msg set" where
knows_max'_def_Nil: "knows_max' A [] = {}" |
knows_max'_def_Cons: "knows_max' A (ev # evs) = (
  if A=Spy then (
    case ev of
      Says A' B X => insert X (knows_max' A evs)
    | Gets A' X => knows_max' A evs
    | Notes A' X =>
      if A' \<in> bad then insert X (knows_max' A evs) else knows_max' A evs
  ) else (
    case ev of
      Says A' B X =>
      if A=A' | A=B then insert X (knows_max' A evs) else knows_max' A evs
    | Gets A' X =>
      if A=A' then insert X (knows_max' A evs) else knows_max' A evs
    | Notes A' X =>
      if A=A' then insert X (knows_max' A evs) else knows_max' A evs
  ))"

definition knows_max :: "agent => event list => msg set" where
"knows_max A evs == knows_max' A evs Un initState A"

abbreviation
  spies_max :: "event list => msg set" where
  "spies_max evs == knows_max Spy evs"

subsubsection\<open>basic facts about \<^term>\<open>knows_max\<close>\<close>

lemma spies_max_spies [iff]: "spies_max evs = spies evs"
by (induct evs, auto simp: knows_max_def split: event.splits)

lemma knows_max'_Cons: "knows_max' A (ev#evs)
= knows_max' A [ev] Un knows_max' A evs"
by (auto split: event.splits)

lemmas knows_max'_Cons_substI = knows_max'_Cons [THEN ssubst]
lemmas knows_max'_Cons_substD = knows_max'_Cons [THEN sym, THEN ssubst]

lemma knows_max_Cons: "knows_max A (ev#evs)
= knows_max' A [ev] Un knows_max A evs"
apply (simp add: knows_max_def del: knows_max'_def_Cons)
apply (rule_tac evs=evs in knows_max'_Cons_substI)
by blast

lemmas knows_max_Cons_substI = knows_max_Cons [THEN ssubst]
lemmas knows_max_Cons_substD = knows_max_Cons [THEN sym, THEN ssubst]

lemma finite_knows_max' [iff]: "finite (knows_max' A evs)"
by (induct evs, auto split: event.split)

lemma knows_max'_sub_spies': "[| evs \<in> p; has_only_Says p; one_step p |]
==> knows_max' A evs \<subseteq> spies' evs"
by (induct evs, auto split: event.splits)

lemma knows_max'_in_spies' [dest]: "[| evs \<in> p; X \<in> knows_max' A evs;
has_only_Says p; one_step p |] ==> X \<in> spies' evs"
by (rule knows_max'_sub_spies' [THEN subsetD], auto)

lemma knows_max'_app: "knows_max' A (evs @ evs')
= knows_max' A evs Un knows_max' A evs'"
by (induct evs, auto split: event.splits)

lemma Says_to_knows_max': "Says A B X \<in> set evs \<Longrightarrow> X \<in> knows_max' B evs"
by (simp add: in_set_conv_decomp, clarify, simp add: knows_max'_app)

lemma Says_from_knows_max': "Says A B X \<in> set evs \<Longrightarrow> X \<in> knows_max' A evs"
by (simp add: in_set_conv_decomp, clarify, simp add: knows_max'_app)

subsubsection\<open>used without initState\<close>

primrec used' :: "event list => msg set" where
"used' [] = {}" |
"used' (ev # evs) = (
  case ev of
    Says A B X => parts {X} Un used' evs
    | Gets A X => used' evs
    | Notes A X => parts {X} Un used' evs
  )"

definition init :: "msg set" where
"init == used []"

lemma used_decomp: "used evs = init Un used' evs"
by (induct evs, auto simp: init_def split: event.split)

lemma used'_sub_app: "used' evs \<subseteq> used' (evs@evs')"
by (induct evs, auto split: event.split)

lemma used'_parts [rule_format]: "X \<in> used' evs \<Longrightarrow> Y \<in> parts {X} \<longrightarrow> Y \<in> used' evs"
apply (induct evs, simp)
apply (rename_tac a b)
apply (case_tac a, simp_all)
apply (blast dest: parts_trans)+
done

subsubsection\<open>monotonicity of used\<close>

lemma used_sub_Cons: "used evs <= used (ev#evs)"
by (induct evs, (induct ev, auto)+)

lemma used_ConsI: "X \<in> used evs \<Longrightarrow> X \<in> used (ev#evs)"
by (auto dest: used_sub_Cons [THEN subsetD])

lemma notin_used_ConsD: "X \<notin> used (ev#evs) \<Longrightarrow> X \<notin> used evs"
by (auto dest: used_sub_Cons [THEN subsetD])

lemma used_appD [dest]: "X \<in> used (evs @ evs') \<Longrightarrow> X \<in> used evs \<or> X \<in> used evs'"
by (induct evs, auto, rename_tac a b, case_tac a, auto)

lemma used_ConsD: "X \<in> used (ev#evs) \<Longrightarrow> X \<in> used [ev] \<or> X \<in> used evs"
by (case_tac ev, auto)

lemma used_sub_app: "used evs <= used (evs@evs')"
by (auto simp: used_decomp dest: used'_sub_app [THEN subsetD])

lemma used_appIL: "X \<in> used evs \<Longrightarrow> X \<in> used (evs' @ evs)"
by (induct evs', auto intro: used_ConsI)

lemma used_appIR: "X \<in> used evs \<Longrightarrow> X \<in> used (evs @ evs')"
by (erule used_sub_app [THEN subsetD])

lemma used_parts: "[| X \<in> parts {Y}; Y \<in> used evs |] ==> X \<in> used evs"
apply (auto simp: used_decomp dest: used'_parts)
by (auto simp: init_def used_Nil dest: parts_trans)

lemma parts_Says_used: "[| Says A B X \<in> set evs; Y \<in> parts {X} |] ==> Y \<in> used evs"
by (induct evs, simp_all, safe, auto intro: used_ConsI)

lemma parts_used_app: "X \<in> parts {Y} \<Longrightarrow> X \<in> used (evs @ Says A B Y # evs')"
apply (drule_tac evs="[Says A B Y]" in used_parts, simp, blast)
apply (drule_tac evs'=evs' in used_appIR)
apply (drule_tac evs'=evs in used_appIL)
by simp

subsubsection\<open>lemmas on used and knows\<close>

lemma initState_used: "X \<in> parts (initState A) \<Longrightarrow> X \<in> used evs"
by (induct evs, auto simp: used.simps split: event.split)

lemma Says_imp_used: "Says A B X \<in> set evs \<Longrightarrow> parts {X} \<subseteq> used evs"
by (induct evs, auto intro: used_ConsI)

lemma not_used_not_spied: "X \<notin> used evs \<Longrightarrow> X \<notin> parts (spies evs)"
by (induct evs, auto simp: used_Nil)

lemma not_used_not_parts: "[| Y \<notin> used evs; Says A B X \<in> set evs |]
==> Y \<notin> parts {X}"
by (induct evs, auto intro: used_ConsI)

lemma not_used_parts_false: "[| X \<notin> used evs; Y \<in> parts (spies evs) |]
==> X \<notin> parts {Y}"
by (auto dest: parts_parts)

lemma known_used [rule_format]: "[| evs \<in> p; Gets_correct p; one_step p |]
==> X \<in> parts (knows A evs) \<longrightarrow> X \<in> used evs"
apply (case_tac "A=Spy", blast)
apply (induct evs)
apply (simp add: used.simps, blast)
apply (rename_tac a evs)
apply (frule_tac ev=a and evs=evs in one_step_Cons, simp, clarify)
apply (drule_tac P="\<lambda>G. X \<in> parts G" in knows_Cons_substD, safe)
apply (erule initState_used)
apply (case_tac a, auto)
apply (rename_tac msg)
apply (drule_tac B=A and X=msg and evs=evs in Gets_correct_Says)
by (auto dest: Says_imp_used intro: used_ConsI)

lemma known_max_used [rule_format]: "[| evs \<in> p; Gets_correct p; one_step p |]
==> X \<in> parts (knows_max A evs) \<longrightarrow> X \<in> used evs"
apply (case_tac "A=Spy")
apply force
apply (induct evs)
apply (simp add: knows_max_def used.simps, blast)
apply (rename_tac a evs)
apply (frule_tac ev=a and evs=evs in one_step_Cons, simp, clarify)
apply (drule_tac P="\<lambda>G. X \<in> parts G" in knows_max_Cons_substD, safe)
apply (case_tac a, auto)
apply (rename_tac msg)
apply (drule_tac B=A and X=msg and evs=evs in Gets_correct_Says)
by (auto simp: knows_max'_Cons dest: Says_imp_used intro: used_ConsI)

lemma not_used_not_known: "[| evs \<in> p; X \<notin> used evs;
Gets_correct p; one_step p |] ==> X \<notin> parts (knows A evs)"
by (case_tac "A=Spy", auto dest: not_used_not_spied known_used)

lemma not_used_not_known_max: "[| evs \<in> p; X \<notin> used evs;
Gets_correct p; one_step p |] ==> X \<notin> parts (knows_max A evs)"
by (case_tac "A=Spy", auto dest: not_used_not_spied known_max_used)

subsubsection\<open>a nonce or key in a message cannot equal a fresh nonce or key\<close>

lemma Nonce_neq [dest]: "[| Nonce n' \<notin> used evs;
Says A B X \<in> set evs; Nonce n \<in> parts {X} |] ==> n \<noteq> n'"
by (drule not_used_not_spied, auto dest: Says_imp_knows_Spy parts_sub)

lemma Key_neq [dest]: "[| Key n' \<notin> used evs;
Says A B X \<in> set evs; Key n \<in> parts {X} |] ==> n ~= n'"
by (drule not_used_not_spied, auto dest: Says_imp_knows_Spy parts_sub)

subsubsection\<open>message of an event\<close>

primrec msg :: "event => msg"
where
  "msg (Says A B X) = X"
| "msg (Gets A X) = X"
| "msg (Notes A X) = X"

lemma used_sub_parts_used: "X \<in> used (ev # evs) ==> X \<in> parts {msg ev} \<union> used evs"
by (induct ev, auto)

end


(*
    This file is a part of IsarMathLib -
    a library of formalized mathematics written for Isabelle/Isar.

    Copyright (C) 2013 Daniel de la Concepcion

    This program is free software; Redistribution and use in source and binary forms,
    with or without modification, are permitted provided that the following conditions are met:

   1. Redistributions of source code must retain the above copyright notice,
   this list of conditions and the following disclaimer.
   2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation and/or
   other materials provided with the distribution.
   3. The name of the author may not be used to endorse or promote products
   derived from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. *)

section \<open>Topology 8\<close>

theory Topology_ZF_8 imports Topology_ZF_6 EquivClass1
begin

text\<open>This theory deals with quotient topologies.\<close>

subsection\<open>Definition of quotient topology\<close>

text\<open>Given a surjective function $f:X\to Y$ and a topology $\tau$ in $X$, it is
posible to consider a special topology in $Y$. $f$ is called quotient function.\<close>

definition(in topology0)
  QuotientTop ("{quotient topology in}_{by}_" 80)
  where "f\<in>surj(\<Union>T,Y) \<Longrightarrow>{quotient topology in}Y{by}f\<equiv>
    {U\<in>Pow(Y). f-``U\<in>T}"

abbreviation QuotientTopTop ("{quotient topology in}_{by}_{from}_")
  where "QuotientTopTop(Y,f,T) \<equiv> topology0.QuotientTop(T,Y,f)"

text\<open>The quotient topology is indeed a topology.\<close>

theorem(in topology0) quotientTop_is_top:
  assumes "f\<in>surj(\<Union>T,Y)"
  shows "({quotient topology in} Y {by} f) {is a topology}"
proof-
  have "({quotient topology in} Y {by} f)={U \<in> Pow(Y) . f -`` U \<in> T}" using QuotientTop_def assms
    by auto moreover
  {
    fix M x B assume M:"M \<subseteq> {U \<in> Pow(Y) . f -`` U \<in> T}"
    then have "\<Union>M\<subseteq>Y" by blast moreover
    have A1:"f -`` (\<Union>M)=(\<Union>y\<in>(\<Union>M). f-``{y})" using vimage_eq_UN by blast
    {
      fix A assume "A\<in>M"
      with M have "A\<in>Pow(Y)" "f -`` A\<in>T" by auto
      have "f -`` A=(\<Union>y\<in>A. f-``{y})" using vimage_eq_UN by blast
    }
    then have "(\<Union>A\<in>M. f-`` A)=(\<Union>A\<in>M. (\<Union>y\<in>A. f-``{y}))" by auto
    then have "(\<Union>A\<in>M. f-`` A)=(\<Union>y\<in>\<Union>M. f-``{y})" by auto
    with A1 have A2:"f -`` (\<Union>M)=\<Union>{f-`` A. A\<in>M}" by auto
    {
      fix A assume "A\<in>M"
      with M have "f -`` A\<in>T" by auto
    }
    then have "\<forall>A\<in>M. f -`` A\<in>T" by auto
    then have "{f-`` A. A\<in>M}\<subseteq>T" by auto
    then have "(\<Union>{f-`` A. A\<in>M})\<in>T" using topSpaceAssum unfolding IsATopology_def by auto
    with A2 have "(f -`` (\<Union>M))\<in>T" by auto
    ultimately have "\<Union>M\<in>{U\<in>Pow(Y). f-``U\<in>T}" by auto
  }
  moreover
  {
    fix U V assume "U\<in>{U\<in>Pow(Y). f-``U\<in>T}""V\<in>{U\<in>Pow(Y). f-``U\<in>T}"
    then have "U\<in>Pow(Y)""V\<in>Pow(Y)""f-``U\<in>T""f-``V\<in>T" by auto
    then have "(f-``U)\<inter>(f-``V)\<in>T" using topSpaceAssum unfolding IsATopology_def by auto
    then have "f-`` (U\<inter>V)\<in>T" using invim_inter_inter_invim assms unfolding surj_def
      by auto
    with \<open>U\<in>Pow(Y)\<close>\<open>V\<in>Pow(Y)\<close> have "U\<inter>V\<in>{U\<in>Pow(Y). f-``U\<in>T}" by auto
  }
  ultimately show ?thesis using IsATopology_def by auto
qed

text\<open>The quotient function is continuous.\<close>

lemma (in topology0) quotient_func_cont:
  assumes "f\<in>surj(\<Union>T,Y)"
  shows "IsContinuous(T,({quotient topology in} Y {by} f),f)"
    unfolding IsContinuous_def using QuotientTop_def assms by auto

text\<open>One of the important properties of this topology, is that a function
from the quotient space is continuous iff the composition with the quotient
function is continuous.\<close>

theorem(in two_top_spaces0) cont_quotient_top:
  assumes "h\<in>surj(\<Union>\<tau>\<^sub>1,Y)" "g:Y\<rightarrow>\<Union>\<tau>\<^sub>2" "IsContinuous(\<tau>\<^sub>1,\<tau>\<^sub>2,g O h)"
  shows "IsContinuous(({quotient topology in} Y {by} h {from} \<tau>\<^sub>1),\<tau>\<^sub>2,g)"
proof-
  {
    fix U assume "U\<in>\<tau>\<^sub>2"
    with assms(3) have "(g O h)-``(U)\<in>\<tau>\<^sub>1" unfolding IsContinuous_def by auto
    then have "h-``(g-``(U))\<in>\<tau>\<^sub>1" using vimage_comp by auto
    then have "g-``(U)\<in>({quotient topology in} Y {by} h {from} \<tau>\<^sub>1)" using topology0.QuotientTop_def
      tau1_is_top assms(1) using func1_1_L3 assms(2) unfolding topology0_def by auto
  }
  then show ?thesis unfolding IsContinuous_def by auto
qed

text\<open>The underlying set of the quotient topology is $Y$.\<close>

lemma(in topology0) total_quo_func:
  assumes "f\<in>surj(\<Union>T,Y)"
  shows "(\<Union>({quotient topology in}Y{by}f))=Y"
proof-
  from assms have "f-``Y=\<Union>T" using func1_1_L4 unfolding surj_def by auto moreover
  have "\<Union>T\<in>T" using topSpaceAssum unfolding IsATopology_def by auto ultimately
  have "Y\<in>({quotient topology in}Y{by}f{from}T)" using QuotientTop_def assms by auto
  then show ?thesis using QuotientTop_def assms by auto
qed

subsection\<open>Quotient topologies from equivalence relations\<close>
text\<open>In this section we will show that the quotient topologies come from
an equivalence relation.\<close>

text\<open>First, some lemmas for relations.\<close>

lemma quotient_proj_fun:
  shows "{\<langle>b,r``{b}\<rangle>. b\<in>A}:A\<rightarrow>A//r" unfolding Pi_def function_def domain_def
    unfolding quotient_def by auto

lemma quotient_proj_surj:
  shows "{\<langle>b,r``{b}\<rangle>. b\<in>A}\<in>surj(A,A//r)"
proof-
  {
    fix y assume "y\<in>A//r"
    then obtain yy where A:"yy\<in>A" "y=r``{yy}" unfolding quotient_def by auto
    then have "\<langle>yy,y\<rangle>\<in>{\<langle>b,r``{b}\<rangle>. b\<in>A}" by auto
    then have "{\<langle>b,r``{b}\<rangle>. b\<in>A}`yy=y" using apply_equality[OF _ quotient_proj_fun] by auto
    with A(1) have "\<exists>yy\<in>A. {\<langle>b,r``{b}\<rangle>. b\<in>A}`yy=y" by auto
  }
  with quotient_proj_fun show ?thesis unfolding surj_def by auto
qed

lemma preim_equi_proj:
  assumes "U\<subseteq>A//r" "equiv(A,r)"
  shows "{\<langle>b,r``{b}\<rangle>. b\<in>A}-``U=\<Union>U"
proof
  {
    fix y assume "y\<in>\<Union>U"
    then obtain V where V:"y\<in>V""V\<in>U" by auto
    with \<open>U\<subseteq>(A//r)\<close> have "y\<in>A" using EquivClass_1_L1 assms(2) by auto moreover
    from \<open>U\<subseteq>(A//r)\<close> V have "r``{y}=V" using EquivClass_1_L2 assms(2) by auto
    moreover note V(2) ultimately have "y\<in>{x\<in>A. r``{x}\<in>U}" by auto
    then have "y\<in>{\<langle>b,r``{b}\<rangle>. b\<in>A}-``U" by auto
  }
  then show "\<Union>U\<subseteq>{\<langle>b,r``{b}\<rangle>. b\<in>A}-``U" by blast moreover
  {
    fix y assume "y\<in>{\<langle>b,r``{b}\<rangle>. b\<in>A}-``U"
    then have yy:"y\<in>{x\<in>A. r``{x}\<in>U}" by auto
    then have "r``{y}\<in>U" by auto moreover
    from yy have "y\<in>r``{y}" using assms equiv_class_self by auto ultimately
    have "y\<in>\<Union>U" by auto
  }
  then show "{\<langle>b,r``{b}\<rangle>. b\<in>A}-``U\<subseteq>\<Union>U" by blast
qed

text\<open>Now we define what a quotient topology from an equivalence relation is:\<close>

definition(in topology0)
  EquivQuo ("{quotient by}_" 70)
  where "equiv(\<Union>T,r)\<Longrightarrow>({quotient by}r)\<equiv>{quotient topology in}(\<Union>T)//r{by}{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}"

abbreviation
  EquivQuoTop ("_{quotient by}_" 60)
  where "EquivQuoTop(T,r)\<equiv>topology0.EquivQuo(T,r)"

text\<open>First, another description of the topology (more intuitive):\<close>

theorem (in topology0) quotient_equiv_rel:
  assumes "equiv(\<Union>T,r)"
  shows "({quotient by}r)={U\<in>Pow((\<Union>T)//r). \<Union>U\<in>T}"
proof-
  have "({quotient topology in}(\<Union>T)//r{by}{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T})={U\<in>Pow((\<Union>T)//r). {\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}-``U\<in>T}"
    using QuotientTop_def quotient_proj_surj by auto moreover
  have "{U\<in>Pow((\<Union>T)//r). {\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}-``U\<in>T}={U\<in>Pow((\<Union>T)//r). \<Union>U\<in>T}"
    proof
     {
       fix U assume "U\<in>{U\<in>Pow((\<Union>T)//r). {\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}-``U\<in>T}"
       then have "U\<in>{U\<in>Pow((\<Union>T)//r). \<Union>U\<in>T}" using preim_equi_proj assms by auto
     }
     then show "{U\<in>Pow((\<Union>T)//r). {\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}-``U\<in>T}\<subseteq>{U\<in>Pow((\<Union>T)//r). \<Union>U\<in>T}" by auto
     {
       fix U assume "U\<in>{U\<in>Pow((\<Union>T)//r). \<Union>U\<in>T}"
       then have "U\<in>{U\<in>Pow((\<Union>T)//r). {\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}-``U\<in>T}" using preim_equi_proj assms by auto
     }
     then show "{U\<in>Pow((\<Union>T)//r). \<Union>U\<in>T}\<subseteq>{U\<in>Pow((\<Union>T)//r). {\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}-``U\<in>T}" by auto
   qed
  ultimately show ?thesis using EquivQuo_def assms by auto
qed

text\<open>We apply previous results to this topology.\<close>

theorem(in topology0) total_quo_equi:
  assumes "equiv(\<Union>T,r)"
  shows "\<Union>({quotient by}r)=(\<Union>T)//r"
  using total_quo_func quotient_proj_surj EquivQuo_def assms by auto

theorem(in topology0) equiv_quo_is_top:
  assumes "equiv(\<Union>T,r)"
  shows "({quotient by}r){is a topology}"
  using quotientTop_is_top quotient_proj_surj EquivQuo_def assms by auto

text\<open>MAIN RESULT: All quotient topologies arise from an equivalence relation given by the quotient
function $f:X\to Y$. This means that any quotient topology is homeomorphic to a topology
given by an equivalence relation quotient.\<close>

theorem(in topology0) equiv_quotient_top:
  assumes "f\<in>surj(\<Union>T,Y)"
  defines "r\<equiv>{\<langle>x,y\<rangle>\<in>\<Union>T\<times>\<Union>T. f`(x)=f`(y)}"
  defines "g\<equiv>{\<langle>y,f-``{y}\<rangle>. y\<in>Y}"
  shows "equiv(\<Union>T,r)" and "IsAhomeomorphism(({quotient topology in}Y{by}f),({quotient by}r),g)"
proof-
  have ff:"f:\<Union>T\<rightarrow>Y" using assms(1) unfolding surj_def by auto
  show B:"equiv(\<Union>T,r)" unfolding equiv_def refl_def sym_def trans_def unfolding r_def by auto
  have gg:"g:Y\<rightarrow>((\<Union>T)//r)"
    proof-
      {
        fix B assume "B\<in>g"
        then obtain y where Y:"y\<in>Y" "B=\<langle>y,f-``{y}\<rangle>" unfolding g_def by auto
        then have "f-``{y}\<subseteq>\<Union>T" using func1_1_L3 ff by blast
        then have eq:"f-``{y}={x\<in>\<Union>T. \<langle>x,y\<rangle>\<in>f}" using vimage_iff by auto
        from Y obtain A where A1:"A\<in>\<Union>T""f`A=y" using assms(1) unfolding surj_def by blast
        with eq have A:"A\<in>f-``{y}" using apply_Pair[OF ff] by auto
        {
          fix t assume "t\<in>f-``{y}"
          with A have "t\<in>\<Union>T""A\<in>\<Union>T""\<langle>t,y\<rangle>\<in>f""\<langle>A,y\<rangle>\<in>f" using eq by auto
          then have "f`t=f`A" using apply_equality assms(1) unfolding surj_def by auto
          with \<open>t\<in>\<Union>T\<close>\<open>A\<in>\<Union>T\<close> have "\<langle>A,t\<rangle>\<in>r" using r_def by auto
          then have "t\<in>r``{A}" using image_iff by auto
        }
        then have "f-``{y}\<subseteq>r``{A}" by auto moreover
        {
          fix t assume "t\<in>r``{A}"
          then have "\<langle>A,t\<rangle>\<in>r" using image_iff by auto
          then have un:"t\<in>\<Union>T""A\<in>\<Union>T" and eq2:"f`t=f`A" unfolding r_def by auto moreover
          from un have "\<langle>t,f`t\<rangle>\<in>f" using apply_Pair[OF ff] by auto
          with eq2 A1 have "\<langle>t,y\<rangle>\<in>f" by auto
          with un have "t\<in>f-``{y}" using eq by auto
        }
        then have "r``{A}\<subseteq>f-``{y}" by auto ultimately
        have "f-``{y}=r``{A}" by auto
        then have "f-``{y}\<in> (\<Union>T)//r" using A1(1) unfolding quotient_def by auto
        with Y have "B\<in>Y\<times>(\<Union>T)//r" by auto
      }
      then have "\<forall>A\<in>g. A\<in> Y\<times>(\<Union>T)//r" by auto
      then have "g\<subseteq>(Y\<times>(\<Union>T)//r)" by auto moreover
      then show ?thesis unfolding Pi_def function_def domain_def g_def by auto
    qed
  then have gg2:"g:Y\<rightarrow>(\<Union>({quotient by}r))" using total_quo_equi B by auto
  {
    fix s assume S:"s\<in>({quotient topology in}Y{by}f)"
    then have "s\<in>Pow(Y)"and P:"f-``s\<in>T" using QuotientTop_def topSpaceAssum assms(1)
      by auto
    have "f-``s=(\<Union>y\<in>s. f-``{y})" using vimage_eq_UN by blast moreover
    from \<open>s\<in>Pow(Y)\<close> have "\<forall>y\<in>s. \<langle>y,f-``{y}\<rangle>\<in>g" unfolding g_def by auto
    then have "\<forall>y\<in>s. g`y=f-``{y}" using apply_equality gg by auto ultimately
    have "f-``s=(\<Union>y\<in>s. g`y)" by auto
    with P have "(\<Union>y\<in>s. g`y)\<in>T" by auto moreover
    from \<open>s\<in>Pow(Y)\<close> have "\<forall>y\<in>s. g`y\<in>(\<Union>T)//r" using apply_type gg by auto
    ultimately have "{g`y. y\<in>s}\<in>({quotient by}r)" using quotient_equiv_rel B by auto
    with \<open>s\<in>Pow(Y)\<close> have "g``s\<in>({quotient by}r)" using func_imagedef gg by auto
  }
  then have gopen:"\<forall>s\<in>({quotient topology in}Y{by}f). g``s\<in>(T{quotient by}r)" by auto
  have pr_fun:"{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}:\<Union>T\<rightarrow>(\<Union>T)//r" using quotient_proj_fun by auto
  {
    fix b assume b:"b\<in>\<Union>T"
    have bY:"f`b\<in>Y" using apply_funtype ff b by auto
    with b have com:"(g O f)`b=g`(f`b)" using comp_fun_apply ff by auto
    from bY have pg:"\<langle>f`b,f-``({f`b})\<rangle>\<in>g" unfolding g_def by auto
    then have "g`(f`b)=f-``({f`b})" using apply_equality gg by auto
    with com have comeq:"(g O f)`b=f-``({f`b})" by auto
    from b have A:"f``{b}={f`b}" "{b}\<subseteq>\<Union>T" using func_imagedef ff by auto
    from A(2) have "b\<in>f -`` (f `` {b})" using func1_1_L9 ff by blast
    then have "b\<in>f-``({f`b})" using A(1) by auto moreover
    from pg have "f-``({f`b})\<in>(\<Union>T)//r" using gg unfolding Pi_def by auto
    ultimately have "r``{b}=f-``({f`b})" using EquivClass_1_L2 B by auto
    then have "(g O f)`b=r``{b}" using comeq by auto moreover
    from b have "\<langle>b,r``{b}\<rangle>\<in>{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}" by auto
    with pr_fun have "{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}`b=r``{b}" using apply_equality by auto ultimately
    have "(g O f)`b={\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}`b" by auto
  }
  then have reg:"\<forall>b\<in>\<Union>T. (g O f)`b={\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}`b" by auto moreover
  have compp:"g O f\<in>\<Union>T\<rightarrow>(\<Union>T)//r" using comp_fun ff gg by auto
  have feq:"(g O f)={\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}" using fun_extension[OF compp pr_fun] reg by auto
  then have "IsContinuous(T,{quotient by}r,(g O f))" using quotient_func_cont quotient_proj_surj
    EquivQuo_def topSpaceAssum B by auto moreover
  have "(g O f):\<Union>T\<rightarrow>\<Union>({quotient by}r)" using comp_fun ff gg2 by auto
  ultimately have gcont:"IsContinuous({quotient topology in}Y{by}f,{quotient by}r,g)"
    using two_top_spaces0.cont_quotient_top assms(1) gg2 unfolding two_top_spaces0_def
    using topSpaceAssum equiv_quo_is_top B by auto
  {
    fix x y assume T:"x\<in>Y""y\<in>Y""g`x=g`y"
      then have "f-``{x}=f-``{y}" using apply_equality gg unfolding g_def by auto
      then have "f``(f-``{x})=f``(f-``{y})" by auto
      with T(1,2) have "{x}={y}" using surj_image_vimage assms(1) by auto
      then have "x=y" by auto
  }
  with gg2 have "g\<in>inj(Y,\<Union>({quotient by}r))" unfolding inj_def by auto moreover
  have "g O f\<in>surj(\<Union>T, (\<Union>T)//r)" using feq quotient_proj_surj by auto
  then have "g\<in>surj(Y,(\<Union>T)//r)" using comp_mem_surjD1 ff gg by auto
  then have "g\<in>surj(Y,\<Union>(T{quotient by}r))" using total_quo_equi B by auto
  ultimately have "g\<in>bij(\<Union>({quotient topology in}Y{by}f),\<Union>({quotient by}r))" unfolding bij_def using total_quo_func assms(1) by auto
  with gcont gopen show "IsAhomeomorphism(({quotient topology in}Y{by}f),({quotient by}r),g)"
    using bij_cont_open_homeo by auto
qed

lemma product_equiv_rel_fun:
  shows "{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}:(\<Union>T\<times>\<Union>T)\<rightarrow>((\<Union>T)//r\<times>(\<Union>T)//r)"
proof-
  have " {\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}\<in>\<Union>T\<rightarrow>(\<Union>T)//r" using quotient_proj_fun by auto moreover
  have "\<forall>A\<in>\<Union>T. \<langle>A,r``{A}\<rangle>\<in>{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}" by auto
  ultimately have "\<forall>A\<in>\<Union>T. {\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}`A=r``{A}" using apply_equality by auto
  then have IN:" {\<langle>\<langle>b, c\<rangle>, r `` {b}, r `` {c}\<rangle> . \<langle>b,c\<rangle> \<in> \<Union>T \<times> \<Union>T}= {\<langle>\<langle>x, y\<rangle>, {\<langle>b, r `` {b}\<rangle> . b \<in> \<Union>T} ` x, {\<langle>b, r `` {b}\<rangle> . b \<in> \<Union>T} ` y\<rangle> . \<langle>x,y\<rangle> \<in> \<Union>T \<times> \<Union>T}"
    by force
  then show ?thesis using prod_fun quotient_proj_fun by auto
qed

lemma(in topology0) prod_equiv_rel_surj:
  shows "{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}:surj(\<Union>(ProductTopology(T,T)),((\<Union>T)//r\<times>(\<Union>T)//r))"
proof-
  have fun:"{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}:(\<Union>T\<times>\<Union>T)\<rightarrow>((\<Union>T)//r\<times>(\<Union>T)//r)" using
    product_equiv_rel_fun by auto moreover
  {
    fix M assume "M\<in>((\<Union>T)//r\<times>(\<Union>T)//r)"
    then obtain M1 M2 where M:"M=\<langle>M1,M2\<rangle>" "M1\<in>(\<Union>T)//r""M2\<in>(\<Union>T)//r" by auto
    then obtain m1 m2 where m:"m1\<in>\<Union>T""m2\<in>\<Union>T""M1=r``{m1}""M2=r``{m2}" unfolding quotient_def
      by auto
    then have mm:"\<langle>m1,m2\<rangle>\<in>(\<Union>T\<times>\<Union>T)" by auto
    then have "\<langle>\<langle>m1,m2\<rangle>,\<langle>r``{m1},r``{m2}\<rangle>\<rangle>\<in>{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}" by auto
    then have "{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}`\<langle>m1,m2\<rangle>=\<langle>r``{m1},r``{m2}\<rangle>"
      using apply_equality fun by auto
    then have "{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}`\<langle>m1,m2\<rangle>=M" using M(1) m(3,4) by auto
    then have "\<exists>R\<in>(\<Union>T\<times>\<Union>T). {\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}`R=M" using mm by auto
  }
  ultimately show ?thesis unfolding surj_def using Top_1_4_T1(3) topSpaceAssum by auto
qed

lemma(in topology0) product_quo_fun:
  assumes "equiv(\<Union>T,r)"
  shows "IsContinuous(ProductTopology(T,T),ProductTopology({quotient by}r,({quotient by}r)),{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T})"
proof-
  have "{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}:\<Union>T\<rightarrow>(\<Union>T)//r" using quotient_proj_fun by auto moreover
  have "\<forall>A\<in>\<Union>T. \<langle>A,r``{A}\<rangle>\<in>{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}" by auto ultimately
  have "\<forall>A\<in>\<Union>T. {\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}`A=r``{A}" using apply_equality by auto
  then have IN:" {\<langle>\<langle>b, c\<rangle>, r `` {b}, r `` {c}\<rangle> . \<langle>b,c\<rangle> \<in> \<Union>T \<times> \<Union>T}= {\<langle>\<langle>x, y\<rangle>, {\<langle>b, r `` {b}\<rangle> . b \<in> \<Union>T} ` x, {\<langle>b, r `` {b}\<rangle> . b \<in> \<Union>T} ` y\<rangle> . \<langle>x,y\<rangle> \<in> \<Union>T \<times> \<Union>T}"
    by force
  have cont:"IsContinuous(T,{quotient by}r,{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T})" using quotient_func_cont quotient_proj_surj
    EquivQuo_def assms by auto
  have tot:"\<Union>(T{quotient by}r) = (\<Union>T) // r" and top:"({quotient by}r) {is a topology}" using total_quo_equi equiv_quo_is_top assms by auto
  then have fun:"{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}:\<Union>T\<rightarrow>\<Union>({quotient by}r)" using quotient_proj_fun by auto
  then have two:"two_top_spaces0(T,{quotient by}r,{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T})" unfolding two_top_spaces0_def using topSpaceAssum top by auto
  show ?thesis using two_top_spaces0.product_cont_functions two fun fun cont cont top topSpaceAssum IN by auto
qed

text\<open>The product of quotient topologies is a quotient topology given that the
quotient map is open. This isn't true in general.\<close>

theorem(in topology0) prod_quotient:
  assumes "equiv(\<Union>T,r)" "\<forall>A\<in>T. {\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}``A\<in>({quotient by}r)"
  shows "(ProductTopology({quotient by}r,{quotient by}r)) = ({quotient topology in}(((\<Union>T)//r)\<times>((\<Union>T)//r)){by}({\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}){from}(ProductTopology(T,T)))"
proof
  {
    fix A assume A:"A\<in>ProductTopology({quotient by}r,{quotient by}r)"
    from assms have "IsContinuous(ProductTopology(T,T),ProductTopology({quotient by}r,({quotient by}r)),{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T})" using product_quo_fun
      by auto
    with A have "{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}-``A\<in>ProductTopology(T,T)"
      unfolding IsContinuous_def by auto moreover
    from A have "A\<subseteq>\<Union>ProductTopology(T{quotient by}r,T{quotient by}r)" by auto
    then have "A\<subseteq>\<Union>(T{quotient by}r)\<times>\<Union>(T{quotient by}r)" using Top_1_4_T1(3) equiv_quo_is_top equiv_quo_is_top
      using assms by auto
    then have "A\<in>Pow(((\<Union>T)//r)\<times>((\<Union>T)//r))" using total_quo_equi assms by auto
    ultimately have "A\<in>({quotient topology in}(((\<Union>T)//r)\<times>((\<Union>T)//r)){by}{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}{from}(ProductTopology(T,T)))"
      using topology0.QuotientTop_def Top_1_4_T1(1) topSpaceAssum prod_equiv_rel_surj assms(1) unfolding topology0_def by auto
  }
  then show "ProductTopology(T{quotient by}r,T{quotient by}r)\<subseteq>({quotient topology in}(((\<Union>T)//r)\<times>((\<Union>T)//r)){by}{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}{from}(ProductTopology(T,T)))"
    by auto
  {
    fix A assume "A\<in>({quotient topology in}(((\<Union>T)//r)\<times>((\<Union>T)//r)){by}{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}{from}(ProductTopology(T,T)))"
    then have A:"A\<subseteq>((\<Union>T)//r)\<times>((\<Union>T)//r)" "{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}-``A\<in>ProductTopology(T,T)"
      using topology0.QuotientTop_def Top_1_4_T1(1) topSpaceAssum prod_equiv_rel_surj assms(1) unfolding topology0_def by auto
    {
      fix CC assume "CC\<in>A"
      with A(1) obtain C1 C2 where CC:"CC=\<langle>C1,C2\<rangle>" "C1\<in>((\<Union>T)//r)""C2\<in>((\<Union>T)//r)" by auto
      then obtain c1 c2 where CC1:"c1\<in>\<Union>T""c2\<in>\<Union>T" and CC2:"C1=r``{c1}""C2=r``{c2}" unfolding quotient_def
        by auto
      then have "\<langle>c1,c2\<rangle>\<in>\<Union>T\<times>\<Union>T" by auto
      then have "\<langle>\<langle>c1,c2\<rangle>,\<langle>r``{c1},r``{c2}\<rangle>\<rangle>\<in>{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}" by auto
      with CC2 CC have "\<langle>\<langle>c1,c2\<rangle>,CC\<rangle>\<in>{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}" by auto
      with \<open>CC\<in>A\<close> have "\<langle>c1,c2\<rangle>\<in>{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}-``A"
        using vimage_iff by auto
      with A(2) have " \<exists>V W. V \<in> T \<and> W \<in> T \<and> V \<times> W \<subseteq> {\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}-``A \<and> \<langle>c1,c2\<rangle> \<in> V \<times> W"
         using prod_top_point_neighb topSpaceAssum by blast
      then obtain V W where VW:"V\<in>T""W\<in>T""V \<times> W \<subseteq> {\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}-``A""c1\<in>V""c2\<in>W" by auto
      with assms(2) have "{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}``V\<in>(T{quotient by}r)""{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}``W\<in>(T{quotient by}r)" by auto
      then have P:"{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}``V\<times>{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}``W\<in>ProductTopology(T{quotient by}r,T{quotient by}r)" using prod_open_open_prod equiv_quo_is_top
        assms(1) by auto
      {
        fix S assume "S\<in>{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}``V\<times>{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}``W"
        then obtain s1 s2 where S:"S=\<langle>s1,s2\<rangle>""s1\<in>{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}``V""s2\<in>{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}``W" by blast
        then obtain t1 t2 where T:"\<langle>t1,s1\<rangle>\<in>{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}""\<langle>t2,s2\<rangle>\<in>{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}""t1\<in>V""t2\<in>W" using image_iff by auto
        then have "\<langle>t1,t2\<rangle>\<in>V\<times>W" by auto
        with VW(3) have "\<langle>t1,t2\<rangle>\<in>{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}-``A" by auto
        then have "\<exists>SS\<in>A. \<langle>\<langle>t1,t2\<rangle>,SS\<rangle>\<in>{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}" using vimage_iff by auto
        then obtain SS where "SS\<in>A""\<langle>\<langle>t1,t2\<rangle>,SS\<rangle>\<in>{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}" by auto moreover
        from T VW(1,2) have "\<langle>t1,t2\<rangle>\<in>\<Union>T\<times>\<Union>T""\<langle>s1,s2\<rangle>=\<langle>r``{t1},r``{t2}\<rangle>" by auto
        with S(1) have "\<langle>\<langle>t1,t2\<rangle>,S\<rangle>\<in>{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}" by auto
        ultimately have "S\<in>A" using product_equiv_rel_fun unfolding Pi_def function_def
          by auto
      }
      then have sub:"{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}``V\<times>{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}``W\<subseteq>A" by blast
      have "\<langle>c1,C1\<rangle>\<in>{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}""\<langle>c2,C2\<rangle>\<in>{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}" using CC2 CC1
        by auto
      with \<open>c1\<in>V\<close>\<open>c2\<in>W\<close> have "C1\<in>{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}``V""C2\<in>{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}``W"
        using image_iff by auto
      then have "CC\<in>{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}``V\<times>{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}``W" using CC by auto
      with sub P have "\<exists>OO\<in>ProductTopology(T{quotient by}r,T{quotient by}r). CC\<in>OO\<and> OO\<subseteq>A"
        using exI[where x="{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}``V\<times>{\<langle>b,r``{b}\<rangle>. b\<in>\<Union>T}``W" and P="\<lambda>OO. OO\<in>ProductTopology(T{quotient by}r,T{quotient by}r)\<and> CC\<in>OO\<and> OO\<subseteq>A"]
        by auto
    }
    then have "\<forall>C\<in>A. \<exists>OO\<in>ProductTopology(T{quotient by}r,T{quotient by}r). C\<in>OO\<and> OO\<subseteq>A" by auto
    then have "A\<in>ProductTopology(T{quotient by}r,T{quotient by}r)" using topology0.open_neigh_open
      unfolding topology0_def using Top_1_4_T1 equiv_quo_is_top assms by auto
  }
  then show "({quotient topology in}(((\<Union>T)//r)\<times>((\<Union>T)//r)){by}{\<langle>\<langle>b,c\<rangle>,\<langle>r``{b},r``{c}\<rangle>\<rangle>. \<langle>b,c\<rangle>\<in>\<Union>T\<times>\<Union>T}{from}(ProductTopology(T,T)))\<subseteq>ProductTopology(T{quotient by}r,T{quotient by}r)"
    by auto
qed

end