(*  Title:      HOL/Library/Sublist.thy
    Author:     Tobias Nipkow and Markus Wenzel, TU Muenchen
    Author:     Christian Sternagel, JAIST
*)

section \<open>List prefixes, suffixes, and homeomorphic embedding\<close>

theory Sublist
imports Main
begin

subsection \<open>Prefix order on lists\<close>

definition prefix :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where "prefix xs ys \<longleftrightarrow> (\<exists>zs. ys = xs @ zs)"

definition strict_prefix :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where "strict_prefix xs ys \<longleftrightarrow> prefix xs ys \<and> xs \<noteq> ys"

interpretation prefix_order: order prefix strict_prefix
  by standard (auto simp: prefix_def strict_prefix_def)

interpretation prefix_bot: order_bot Nil prefix strict_prefix
  by standard (simp add: prefix_def)

lemma prefixI [intro?]: "ys = xs @ zs \<Longrightarrow> prefix xs ys"
  unfolding prefix_def by blast

lemma prefixE [elim?]:
  assumes "prefix xs ys"
  obtains zs where "ys = xs @ zs"
  using assms unfolding prefix_def by blast

lemma strict_prefixI' [intro?]: "ys = xs @ z # zs \<Longrightarrow> strict_prefix xs ys"
  unfolding strict_prefix_def prefix_def by blast

lemma strict_prefixE' [elim?]:
  assumes "strict_prefix xs ys"
  obtains z zs where "ys = xs @ z # zs"
proof -
  from \<open>strict_prefix xs ys\<close> obtain us where "ys = xs @ us" and "xs \<noteq> ys"
    unfolding strict_prefix_def prefix_def by blast
  with that show ?thesis by (auto simp add: neq_Nil_conv)
qed

(* FIXME rm *)
lemma strict_prefixI [intro?]: "prefix xs ys \<Longrightarrow> xs \<noteq> ys \<Longrightarrow> strict_prefix xs ys"
by(fact prefix_order.le_neq_trans)

lemma strict_prefixE [elim?]:
  fixes xs ys :: "'a list"
  assumes "strict_prefix xs ys"
  obtains "prefix xs ys" and "xs \<noteq> ys"
  using assms unfolding strict_prefix_def by blast

subsection \<open>Basic properties of prefixes\<close>

(* FIXME rm *)
theorem Nil_prefix [iff]: "prefix [] xs"
by(fact prefix_bot.bot_least)

(* FIXME rm *)
theorem prefix_Nil [simp]: "(prefix xs []) = (xs = [])"
by(fact prefix_bot.bot_unique)

lemma prefix_snoc [simp]: "prefix xs (ys @ [y]) \<longleftrightarrow> xs = ys @ [y] \<or> prefix xs ys"
proof
  assume "prefix xs (ys @ [y])"
  then obtain zs where zs: "ys @ [y] = xs @ zs" ..
  show "xs = ys @ [y] \<or> prefix xs ys"
    by (metis append_Nil2 butlast_append butlast_snoc prefixI zs)
next
  assume "xs = ys @ [y] \<or> prefix xs ys"
  then show "prefix xs (ys @ [y])"
    by (metis prefix_order.eq_iff prefix_order.order_trans prefixI)
qed

lemma Cons_prefix_Cons [simp]: "prefix (x # xs) (y # ys) = (x = y \<and> prefix xs ys)"
  by (auto simp add: prefix_def)

lemma prefix_code [code]:
  "prefix [] xs \<longleftrightarrow> True"
  "prefix (x # xs) [] \<longleftrightarrow> False"
  "prefix (x # xs) (y # ys) \<longleftrightarrow> x = y \<and> prefix xs ys"
  by simp_all

lemma same_prefix_prefix [simp]: "prefix (xs @ ys) (xs @ zs) = prefix ys zs"
  by (induct xs) simp_all

lemma same_prefix_nil [iff]: "prefix (xs @ ys) xs = (ys = [])"
  by (metis append_Nil2 append_self_conv prefix_order.eq_iff prefixI)

lemma prefix_prefix [simp]: "prefix xs ys \<Longrightarrow> prefix xs (ys @ zs)"
  by (metis prefix_order.le_less_trans prefixI strict_prefixE strict_prefixI)

lemma append_prefixD: "prefix (xs @ ys) zs \<Longrightarrow> prefix xs zs"
  by (auto simp add: prefix_def)

theorem prefix_Cons: "prefix xs (y # ys) = (xs = [] \<or> (\<exists>zs. xs = y # zs \<and> prefix zs ys))"
  by (cases xs) (auto simp add: prefix_def)

theorem prefix_append:
  "prefix xs (ys @ zs) = (prefix xs ys \<or> (\<exists>us. xs = ys @ us \<and> prefix us zs))"
  apply (induct zs rule: rev_induct)
   apply force
  apply (simp del: append_assoc add: append_assoc [symmetric])
  apply (metis append_eq_appendI)
  done

lemma append_one_prefix:
  "prefix xs ys \<Longrightarrow> length xs < length ys \<Longrightarrow> prefix (xs @ [ys ! length xs]) ys"
  proof (unfold prefix_def)
    assume a1: "\<exists>zs. ys = xs @ zs"
    then obtain sk :: "'a list" where sk: "ys = xs @ sk" by fastforce
    assume a2: "length xs < length ys"
    have f1: "\<And>v. ([]::'a list) @ v = v" using append_Nil2 by simp
    have "[] \<noteq> sk" using a1 a2 sk less_not_refl by force
    hence "\<exists>v. xs @ hd sk # v = ys" using sk by (metis hd_Cons_tl)
    thus "\<exists>zs. ys = (xs @ [ys ! length xs]) @ zs" using f1 by fastforce
  qed

theorem prefix_length_le: "prefix xs ys \<Longrightarrow> length xs \<le> length ys"
  by (auto simp add: prefix_def)

lemma prefix_same_cases:
  "prefix (xs\<^sub>1::'a list) ys \<Longrightarrow> prefix xs\<^sub>2 ys \<Longrightarrow> prefix xs\<^sub>1 xs\<^sub>2 \<or> prefix xs\<^sub>2 xs\<^sub>1"
  unfolding prefix_def by (force simp: append_eq_append_conv2)

lemma prefix_length_prefix:
  "prefix ps xs \<Longrightarrow> prefix qs xs \<Longrightarrow> length ps \<le> length qs \<Longrightarrow> prefix ps qs"
by (auto simp: prefix_def) (metis append_Nil2 append_eq_append_conv_if)

lemma set_mono_prefix: "prefix xs ys \<Longrightarrow> set xs \<subseteq> set ys"
  by (auto simp add: prefix_def)

lemma take_is_prefix: "prefix (take n xs) xs"
  unfolding prefix_def by (metis append_take_drop_id)

lemma prefixeq_butlast: "prefix (butlast xs) xs"
by (simp add: butlast_conv_take take_is_prefix)

lemma map_prefixI: "prefix xs ys \<Longrightarrow> prefix (map f xs) (map f ys)"
  by (auto simp: prefix_def)

lemma prefix_length_less: "strict_prefix xs ys \<Longrightarrow> length xs < length ys"
  by (auto simp: strict_prefix_def prefix_def)

lemma prefix_snocD: "prefix (xs@[x]) ys \<Longrightarrow> strict_prefix xs ys"
  by (simp add: strict_prefixI' prefix_order.dual_order.strict_trans1)

lemma strict_prefix_simps [simp, code]:
  "strict_prefix xs [] \<longleftrightarrow> False"
  "strict_prefix [] (x # xs) \<longleftrightarrow> True"
  "strict_prefix (x # xs) (y # ys) \<longleftrightarrow> x = y \<and> strict_prefix xs ys"
  by (simp_all add: strict_prefix_def cong: conj_cong)

lemma take_strict_prefix: "strict_prefix xs ys \<Longrightarrow> strict_prefix (take n xs) ys"
proof (induct n arbitrary: xs ys)
  case 0
  then show ?case by (cases ys) simp_all
next
  case (Suc n)
  then show ?case by (metis prefix_order.less_trans strict_prefixI take_is_prefix)
qed

lemma not_prefix_cases:
  assumes pfx: "\<not> prefix ps ls"
  obtains
    (c1) "ps \<noteq> []" and "ls = []"
  | (c2) a as x xs where "ps = a#as" and "ls = x#xs" and "x = a" and "\<not> prefix as xs"
  | (c3) a as x xs where "ps = a#as" and "ls = x#xs" and "x \<noteq> a"
proof (cases ps)
  case Nil
  then show ?thesis using pfx by simp
next
  case (Cons a as)
  note c = \<open>ps = a#as\<close>
  show ?thesis
  proof (cases ls)
    case Nil then show ?thesis by (metis append_Nil2 pfx c1 same_prefix_nil)
  next
    case (Cons x xs)
    show ?thesis
    proof (cases "x = a")
      case True
      have "\<not> prefix as xs" using pfx c Cons True by simp
      with c Cons True show ?thesis by (rule c2)
    next
      case False
      with c Cons show ?thesis by (rule c3)
    qed
  qed
qed

lemma not_prefix_induct [consumes 1, case_names Nil Neq Eq]:
  assumes np: "\<not> prefix ps ls"
    and base: "\<And>x xs. P (x#xs) []"
    and r1: "\<And>x xs y ys. x \<noteq> y \<Longrightarrow> P (x#xs) (y#ys)"
    and r2: "\<And>x xs y ys. \<lbrakk> x = y; \<not> prefix xs ys; P xs ys \<rbrakk> \<Longrightarrow> P (x#xs) (y#ys)"
  shows "P ps ls" using np
proof (induct ls arbitrary: ps)
  case Nil
  then show ?case
    by (auto simp: neq_Nil_conv elim!: not_prefix_cases intro!: base)
next
  case (Cons y ys)
  then have npfx: "\<not> prefix ps (y # ys)" by simp
  then obtain x xs where pv: "ps = x # xs"
    by (rule not_prefix_cases) auto
  show ?case by (metis Cons.hyps Cons_prefix_Cons npfx pv r1 r2)
qed

subsection \<open>Prefixes\<close>

fun prefixes where
"prefixes [] = [[]]" |
"prefixes (x#xs) = [] # map (op # x) (prefixes xs)"

lemma in_set_prefixes[simp]: "xs \<in> set (prefixes ys) \<longleftrightarrow> prefix xs ys"
proof (induct xs arbitrary: ys)
  case Nil
  then show ?case by (cases ys) auto
next
  case (Cons a xs)
  then show ?case by (cases ys) auto
qed

lemma length_prefixes[simp]: "length (prefixes xs) = length xs+1"
by (induction xs) auto

lemma prefixes_snoc[simp]:
  "prefixes (xs@[x]) = prefixes xs @ [xs@[x]]"
by (induction xs) auto

lemma prefixes_eq_Snoc:
  "prefixes ys = xs @ [x] \<longleftrightarrow>
  (ys = [] \<and> xs = [] \<or> (\<exists>z zs. ys = zs@[z] \<and> xs = prefixes zs)) \<and> x = ys"
by (cases ys rule: rev_cases) auto

subsection \<open>Longest Common Prefix\<close>

definition Longest_common_prefix :: "'a list set \<Rightarrow> 'a list" where
"Longest_common_prefix L = (GREATEST ps WRT length. \<forall>xs \<in> L. prefix ps xs)"

lemma Longest_common_prefix_ex: "L \<noteq> {} \<Longrightarrow>
  \<exists>ps. (\<forall>xs \<in> L. prefix ps xs) \<and> (\<forall>qs. (\<forall>xs \<in> L. prefix qs xs) \<longrightarrow> size qs \<le> size ps)"
  (is "_ \<Longrightarrow> \<exists>ps. ?P L ps")
proof(induction "LEAST n. \<exists>xs \<in>L. n = length xs" arbitrary: L)
  case 0
  have "[] : L" using "0.hyps" LeastI[of "\<lambda>n. \<exists>xs\<in>L. n = length xs"] \<open>L \<noteq> {}\<close>
    by auto
  hence "?P L []" by(auto)
  thus ?case ..
next
  case (Suc n)
  let ?EX = "\<lambda>n. \<exists>xs\<in>L. n = length xs"
  obtain x xs where xxs: "x#xs \<in> L" "size xs = n" using Suc.prems Suc.hyps(2)
    by(metis LeastI_ex[of ?EX] Suc_length_conv ex_in_conv)
  hence "[] \<notin> L" using Suc.hyps(2) by auto
  show ?case
  proof (cases "\<forall>xs \<in> L. \<exists>ys. xs = x#ys")
    case True
    let ?L = "{ys. x#ys \<in> L}"
    have 1: "(LEAST n. \<exists>xs \<in> ?L. n = length xs) = n"
      using xxs Suc.prems Suc.hyps(2) Least_le[of "?EX"]
      by - (rule Least_equality, fastforce+)
    have 2: "?L \<noteq> {}" using \<open>x # xs \<in> L\<close> by auto
    from Suc.hyps(1)[OF 1[symmetric] 2] obtain ps where IH: "?P ?L ps" ..
    { fix qs
      assume "\<forall>qs. (\<forall>xa. x # xa \<in> L \<longrightarrow> prefix qs xa) \<longrightarrow> length qs \<le> length ps"
      and "\<forall>xs\<in>L. prefix qs xs"
      hence "length (tl qs) \<le> length ps"
        by (metis Cons_prefix_Cons hd_Cons_tl list.sel(2) Nil_prefix)
      hence "length qs \<le> Suc (length ps)" by auto
    }
    hence "?P L (x#ps)" using True IH by auto
    thus ?thesis ..
  next
    case False
    then obtain y ys where yys: "x\<noteq>y" "y#ys \<in> L" using \<open>[] \<notin> L\<close>
      by (auto) (metis list.exhaust)
    have "\<forall>qs. (\<forall>xs\<in>L. prefix qs xs) \<longrightarrow> qs = []" using yys \<open>x#xs \<in> L\<close>
      by auto (metis Cons_prefix_Cons prefix_Cons)
    hence "?P L []" by auto
    thus ?thesis ..
  qed
qed

lemma Longest_common_prefix_unique: "L \<noteq> {} \<Longrightarrow>
  \<exists>! ps. (\<forall>xs \<in> L. prefix ps xs) \<and> (\<forall>qs. (\<forall>xs \<in> L. prefix qs xs) \<longrightarrow> size qs \<le> size ps)"
by(rule ex_ex1I[OF Longest_common_prefix_ex];
   meson equals0I prefix_length_prefix prefix_order.antisym)

lemma Longest_common_prefix_eq:
 "\<lbrakk> L \<noteq> {};  \<forall>xs \<in> L. prefix ps xs;
    \<forall>qs. (\<forall>xs \<in> L. prefix qs xs) \<longrightarrow> size qs \<le> size ps \<rbrakk>
  \<Longrightarrow> Longest_common_prefix L = ps"
unfolding Longest_common_prefix_def GreatestM_def
by(rule some1_equality[OF Longest_common_prefix_unique]) auto

lemma Longest_common_prefix_prefix:
  "xs \<in> L \<Longrightarrow> prefix (Longest_common_prefix L) xs"
unfolding Longest_common_prefix_def GreatestM_def
by(rule someI2_ex[OF Longest_common_prefix_ex]) auto

lemma Longest_common_prefix_longest:
  "L \<noteq> {} \<Longrightarrow> \<forall>xs\<in>L. prefix ps xs \<Longrightarrow> length ps \<le> length(Longest_common_prefix L)"
unfolding Longest_common_prefix_def GreatestM_def
by(rule someI2_ex[OF Longest_common_prefix_ex]) auto

lemma Longest_common_prefix_max_prefix:
  "L \<noteq> {} \<Longrightarrow> \<forall>xs\<in>L. prefix ps xs \<Longrightarrow> prefix ps (Longest_common_prefix L)"
by(metis Longest_common_prefix_prefix Longest_common_prefix_longest
     prefix_length_prefix ex_in_conv)

lemma Longest_common_prefix_Nil: "[] \<in> L \<Longrightarrow> Longest_common_prefix L = []"
using Longest_common_prefix_prefix prefix_Nil by blast

lemma Longest_common_prefix_image_Cons: "L \<noteq> {} \<Longrightarrow>
  Longest_common_prefix (op # x ` L) = x # Longest_common_prefix L"
apply(rule Longest_common_prefix_eq)
  apply(simp)
 apply (simp add: Longest_common_prefix_prefix)
apply simp
by(metis Longest_common_prefix_longest[of L] Cons_prefix_Cons Nitpick.size_list_simp(2)
     Suc_le_mono hd_Cons_tl order.strict_implies_order zero_less_Suc)

lemma Longest_common_prefix_eq_Cons: assumes "L \<noteq> {}" "[] \<notin> L"  "\<forall>xs\<in>L. hd xs = x"
shows "Longest_common_prefix L = x # Longest_common_prefix {ys. x#ys \<in> L}"
proof -
  have "L = op # x ` {ys. x#ys \<in> L}" using assms(2,3)
    by (auto simp: image_def)(metis hd_Cons_tl)
  thus ?thesis
    by (metis Longest_common_prefix_image_Cons image_is_empty assms(1))
qed

lemma Longest_common_prefix_eq_Nil:
  "\<lbrakk>x#ys \<in> L; y#zs \<in> L; x \<noteq> y \<rbrakk> \<Longrightarrow> Longest_common_prefix L = []"
by (metis Longest_common_prefix_prefix list.inject prefix_Cons)

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

lemma longest_common_prefix_prefix1:
  "prefix (longest_common_prefix xs ys) xs"
by(induction xs ys rule: longest_common_prefix.induct) auto

lemma longest_common_prefix_prefix2:
  "prefix (longest_common_prefix xs ys) ys"
by(induction xs ys rule: longest_common_prefix.induct) auto

lemma longest_common_prefix_max_prefix:
  "\<lbrakk> prefix ps xs; prefix ps ys \<rbrakk>
   \<Longrightarrow> prefix ps (longest_common_prefix xs ys)"
by(induction xs ys arbitrary: ps rule: longest_common_prefix.induct)
  (auto simp: prefix_Cons)

subsection \<open>Parallel lists\<close>

definition parallel :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"  (infixl "\<parallel>" 50)
  where "(xs \<parallel> ys) = (\<not> prefix xs ys \<and> \<not> prefix ys xs)"

lemma parallelI [intro]: "\<not> prefix xs ys \<Longrightarrow> \<not> prefix ys xs \<Longrightarrow> xs \<parallel> ys"
  unfolding parallel_def by blast

lemma parallelE [elim]:
  assumes "xs \<parallel> ys"
  obtains "\<not> prefix xs ys \<and> \<not> prefix ys xs"
  using assms unfolding parallel_def by blast

theorem prefix_cases:
  obtains "prefix xs ys" | "strict_prefix ys xs" | "xs \<parallel> ys"
  unfolding parallel_def strict_prefix_def by blast

theorem parallel_decomp:
  "xs \<parallel> ys \<Longrightarrow> \<exists>as b bs c cs. b \<noteq> c \<and> xs = as @ b # bs \<and> ys = as @ c # cs"
proof (induct xs rule: rev_induct)
  case Nil
  then have False by auto
  then show ?case ..
next
  case (snoc x xs)
  show ?case
  proof (rule prefix_cases)
    assume le: "prefix xs ys"
    then obtain ys' where ys: "ys = xs @ ys'" ..
    show ?thesis
    proof (cases ys')
      assume "ys' = []"
      then show ?thesis by (metis append_Nil2 parallelE prefixI snoc.prems ys)
    next
      fix c cs assume ys': "ys' = c # cs"
      have "x \<noteq> c" using snoc.prems ys ys' by fastforce
      thus "\<exists>as b bs c cs. b \<noteq> c \<and> xs @ [x] = as @ b # bs \<and> ys = as @ c # cs"
        using ys ys' by blast
    qed
  next
    assume "strict_prefix ys xs"
    then have "prefix ys (xs @ [x])" by (simp add: strict_prefix_def)
    with snoc have False by blast
    then show ?thesis ..
  next
    assume "xs \<parallel> ys"
    with snoc obtain as b bs c cs where neq: "(b::'a) \<noteq> c"
      and xs: "xs = as @ b # bs" and ys: "ys = as @ c # cs"
      by blast
    from xs have "xs @ [x] = as @ b # (bs @ [x])" by simp
    with neq ys show ?thesis by blast
  qed
qed

lemma parallel_append: "a \<parallel> b \<Longrightarrow> a @ c \<parallel> b @ d"
  apply (rule parallelI)
    apply (erule parallelE, erule conjE,
      induct rule: not_prefix_induct, simp+)+
  done

lemma parallel_appendI: "xs \<parallel> ys \<Longrightarrow> x = xs @ xs' \<Longrightarrow> y = ys @ ys' \<Longrightarrow> x \<parallel> y"
  by (simp add: parallel_append)

lemma parallel_commute: "a \<parallel> b \<longleftrightarrow> b \<parallel> a"
  unfolding parallel_def by auto

subsection \<open>Suffix order on lists\<close>

definition suffix :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where "suffix xs ys = (\<exists>zs. ys = zs @ xs)"

definition strict_suffix :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where "strict_suffix xs ys \<longleftrightarrow> (\<exists>us. ys = us @ xs \<and> us \<noteq> [])"

lemma strict_suffix_imp_suffix:
  "strict_suffix xs ys \<Longrightarrow> suffix xs ys"
  by (auto simp: suffix_def strict_suffix_def)

lemma suffixI [intro?]: "ys = zs @ xs \<Longrightarrow> suffix xs ys"
  unfolding suffix_def by blast

lemma suffixE [elim?]:
  assumes "suffix xs ys"
  obtains zs where "ys = zs @ xs"
  using assms unfolding suffix_def by blast

lemma suffix_refl [iff]: "suffix xs xs"
  by (auto simp add: suffix_def)

lemma suffix_trans:
  "suffix xs ys \<Longrightarrow> suffix ys zs \<Longrightarrow> suffix xs zs"
  by (auto simp: suffix_def)

lemma strict_suffix_trans:
  "\<lbrakk>strict_suffix xs ys; strict_suffix ys zs\<rbrakk> \<Longrightarrow> strict_suffix xs zs"
by (auto simp add: strict_suffix_def)

lemma suffix_antisym: "\<lbrakk>suffix xs ys; suffix ys xs\<rbrakk> \<Longrightarrow> xs = ys"
  by (auto simp add: suffix_def)

lemma suffix_tl [simp]: "suffix (tl xs) xs"
  by (induct xs) (auto simp: suffix_def)

lemma strict_suffix_tl [simp]: "xs \<noteq> [] \<Longrightarrow> strict_suffix (tl xs) xs"
  by (induct xs) (auto simp: strict_suffix_def)

lemma Nil_suffix [iff]: "suffix [] xs"
  by (simp add: suffix_def)

lemma suffix_Nil [simp]: "(suffix xs []) = (xs = [])"
  by (auto simp add: suffix_def)

lemma suffix_ConsI: "suffix xs ys \<Longrightarrow> suffix xs (y # ys)"
  by (auto simp add: suffix_def)

lemma suffix_ConsD: "suffix (x # xs) ys \<Longrightarrow> suffix xs ys"
  by (auto simp add: suffix_def)

lemma suffix_appendI: "suffix xs ys \<Longrightarrow> suffix xs (zs @ ys)"
  by (auto simp add: suffix_def)

lemma suffix_appendD: "suffix (zs @ xs) ys \<Longrightarrow> suffix xs ys"
  by (auto simp add: suffix_def)

lemma strict_suffix_set_subset: "strict_suffix xs ys \<Longrightarrow> set xs \<subseteq> set ys"
by (auto simp: strict_suffix_def)

lemma suffix_set_subset: "suffix xs ys \<Longrightarrow> set xs \<subseteq> set ys"
by (auto simp: suffix_def)

lemma suffix_ConsD2: "suffix (x # xs) (y # ys) \<Longrightarrow> suffix xs ys"
proof -
  assume "suffix (x # xs) (y # ys)"
  then obtain zs where "y # ys = zs @ x # xs" ..
  then show ?thesis
    by (induct zs) (auto intro!: suffix_appendI suffix_ConsI)
qed

lemma suffix_to_prefix [code]: "suffix xs ys \<longleftrightarrow> prefix (rev xs) (rev ys)"
proof
  assume "suffix xs ys"
  then obtain zs where "ys = zs @ xs" ..
  then have "rev ys = rev xs @ rev zs" by simp
  then show "prefix (rev xs) (rev ys)" ..
next
  assume "prefix (rev xs) (rev ys)"
  then obtain zs where "rev ys = rev xs @ zs" ..
  then have "rev (rev ys) = rev zs @ rev (rev xs)" by simp
  then have "ys = rev zs @ xs" by simp
  then show "suffix xs ys" ..
qed

lemma distinct_suffix: "distinct ys \<Longrightarrow> suffix xs ys \<Longrightarrow> distinct xs"
  by (clarsimp elim!: suffixE)

lemma suffix_map: "suffix xs ys \<Longrightarrow> suffix (map f xs) (map f ys)"
  by (auto elim!: suffixE intro: suffixI)

lemma suffix_drop: "suffix (drop n as) as"
  unfolding suffix_def
  apply (rule exI [where x = "take n as"])
  apply simp
  done

lemma suffix_take: "suffix xs ys \<Longrightarrow> ys = take (length ys - length xs) ys @ xs"
  by (auto elim!: suffixE)

lemma strict_suffix_reflclp_conv: "strict_suffix\<^sup>=\<^sup>= = suffix"
by (intro ext) (auto simp: suffix_def strict_suffix_def)

lemma suffix_lists: "suffix xs ys \<Longrightarrow> ys \<in> lists A \<Longrightarrow> xs \<in> lists A"
  unfolding suffix_def by auto

lemma parallelD1: "x \<parallel> y \<Longrightarrow> \<not> prefix x y"
  by blast

lemma parallelD2: "x \<parallel> y \<Longrightarrow> \<not> prefix y x"
  by blast

lemma parallel_Nil1 [simp]: "\<not> x \<parallel> []"
  unfolding parallel_def by simp

lemma parallel_Nil2 [simp]: "\<not> [] \<parallel> x"
  unfolding parallel_def by simp

lemma Cons_parallelI1: "a \<noteq> b \<Longrightarrow> a # as \<parallel> b # bs"
  by auto

lemma Cons_parallelI2: "\<lbrakk> a = b; as \<parallel> bs \<rbrakk> \<Longrightarrow> a # as \<parallel> b # bs"
  by (metis Cons_prefix_Cons parallelE parallelI)

lemma not_equal_is_parallel:
  assumes neq: "xs \<noteq> ys"
    and len: "length xs = length ys"
  shows "xs \<parallel> ys"
  using len neq
proof (induct rule: list_induct2)
  case Nil
  then show ?case by simp
next
  case (Cons a as b bs)
  have ih: "as \<noteq> bs \<Longrightarrow> as \<parallel> bs" by fact
  show ?case
  proof (cases "a = b")
    case True
    then have "as \<noteq> bs" using Cons by simp
    then show ?thesis by (rule Cons_parallelI2 [OF True ih])
  next
    case False
    then show ?thesis by (rule Cons_parallelI1)
  qed
qed

subsection \<open>Homeomorphic embedding on lists\<close>

inductive list_emb :: "('a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  for P :: "('a \<Rightarrow> 'a \<Rightarrow> bool)"
where
  list_emb_Nil [intro, simp]: "list_emb P [] ys"
| list_emb_Cons [intro] : "list_emb P xs ys \<Longrightarrow> list_emb P xs (y#ys)"
| list_emb_Cons2 [intro]: "P x y \<Longrightarrow> list_emb P xs ys \<Longrightarrow> list_emb P (x#xs) (y#ys)"

lemma list_emb_mono:
  assumes "\<And>x y. P x y \<longrightarrow> Q x y"
  shows "list_emb P xs ys \<longrightarrow> list_emb Q xs ys"
proof
  assume "list_emb P xs ys"
  then show "list_emb Q xs ys" by (induct) (auto simp: assms)
qed

lemma list_emb_Nil2 [simp]:
  assumes "list_emb P xs []" shows "xs = []"
  using assms by (cases rule: list_emb.cases) auto

lemma list_emb_refl:
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> P x x"
  shows "list_emb P xs xs"
  using assms by (induct xs) auto

lemma list_emb_Cons_Nil [simp]: "list_emb P (x#xs) [] = False"
proof -
  { assume "list_emb P (x#xs) []"
    from list_emb_Nil2 [OF this] have False by simp
  } moreover {
    assume False
    then have "list_emb P (x#xs) []" by simp
  } ultimately show ?thesis by blast
qed

lemma list_emb_append2 [intro]: "list_emb P xs ys \<Longrightarrow> list_emb P xs (zs @ ys)"
  by (induct zs) auto

lemma list_emb_prefix [intro]:
  assumes "list_emb P xs ys" shows "list_emb P xs (ys @ zs)"
  using assms
  by (induct arbitrary: zs) auto

lemma list_emb_ConsD:
  assumes "list_emb P (x#xs) ys"
  shows "\<exists>us v vs. ys = us @ v # vs \<and> P x v \<and> list_emb P xs vs"
using assms
proof (induct x \<equiv> "x # xs" ys arbitrary: x xs)
  case list_emb_Cons
  then show ?case by (metis append_Cons)
next
  case (list_emb_Cons2 x y xs ys)
  then show ?case by blast
qed

lemma list_emb_appendD:
  assumes "list_emb P (xs @ ys) zs"
  shows "\<exists>us vs. zs = us @ vs \<and> list_emb P xs us \<and> list_emb P ys vs"
using assms
proof (induction xs arbitrary: ys zs)
  case Nil then show ?case by auto
next
  case (Cons x xs)
  then obtain us v vs where
    zs: "zs = us @ v # vs" and p: "P x v" and lh: "list_emb P (xs @ ys) vs"
    by (auto dest: list_emb_ConsD)
  obtain sk\<^sub>0 :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" and sk\<^sub>1 :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
    sk: "\<forall>x\<^sub>0 x\<^sub>1. \<not> list_emb P (xs @ x\<^sub>0) x\<^sub>1 \<or> sk\<^sub>0 x\<^sub>0 x\<^sub>1 @ sk\<^sub>1 x\<^sub>0 x\<^sub>1 = x\<^sub>1 \<and> list_emb P xs (sk\<^sub>0 x\<^sub>0 x\<^sub>1) \<and> list_emb P x\<^sub>0 (sk\<^sub>1 x\<^sub>0 x\<^sub>1)"
    using Cons(1) by (metis (no_types))
  hence "\<forall>x\<^sub>2. list_emb P (x # xs) (x\<^sub>2 @ v # sk\<^sub>0 ys vs)" using p lh by auto
  thus ?case using lh zs sk by (metis (no_types) append_Cons append_assoc)
qed

lemma list_emb_strict_suffix:
  assumes "list_emb P xs ys" and "strict_suffix ys zs"
  shows "list_emb P xs zs"
  using assms(2) and list_emb_append2 [OF assms(1)] by (auto simp: strict_suffix_def)

lemma list_emb_suffix:
  assumes "list_emb P xs ys" and "suffix ys zs"
  shows "list_emb P xs zs"
using assms and list_emb_strict_suffix
unfolding strict_suffix_reflclp_conv[symmetric] by auto

lemma list_emb_length: "list_emb P xs ys \<Longrightarrow> length xs \<le> length ys"
  by (induct rule: list_emb.induct) auto

lemma list_emb_trans:
  assumes "\<And>x y z. \<lbrakk>x \<in> set xs; y \<in> set ys; z \<in> set zs; P x y; P y z\<rbrakk> \<Longrightarrow> P x z"
  shows "\<lbrakk>list_emb P xs ys; list_emb P ys zs\<rbrakk> \<Longrightarrow> list_emb P xs zs"
proof -
  assume "list_emb P xs ys" and "list_emb P ys zs"
  then show "list_emb P xs zs" using assms
  proof (induction arbitrary: zs)
    case list_emb_Nil show ?case by blast
  next
    case (list_emb_Cons xs ys y)
    from list_emb_ConsD [OF \<open>list_emb P (y#ys) zs\<close>] obtain us v vs
      where zs: "zs = us @ v # vs" and "P\<^sup>=\<^sup>= y v" and "list_emb P ys vs" by blast
    then have "list_emb P ys (v#vs)" by blast
    then have "list_emb P ys zs" unfolding zs by (rule list_emb_append2)
    from list_emb_Cons.IH [OF this] and list_emb_Cons.prems show ?case by auto
  next
    case (list_emb_Cons2 x y xs ys)
    from list_emb_ConsD [OF \<open>list_emb P (y#ys) zs\<close>] obtain us v vs
      where zs: "zs = us @ v # vs" and "P y v" and "list_emb P ys vs" by blast
    with list_emb_Cons2 have "list_emb P xs vs" by auto
    moreover have "P x v"
    proof -
      from zs have "v \<in> set zs" by auto
      moreover have "x \<in> set (x#xs)" and "y \<in> set (y#ys)" by simp_all
      ultimately show ?thesis
        using \<open>P x y\<close> and \<open>P y v\<close> and list_emb_Cons2
        by blast
    qed
    ultimately have "list_emb P (x#xs) (v#vs)" by blast
    then show ?case unfolding zs by (rule list_emb_append2)
  qed
qed

lemma list_emb_set:
  assumes "list_emb P xs ys" and "x \<in> set xs"
  obtains y where "y \<in> set ys" and "P x y"
  using assms by (induct) auto

subsection \<open>Sublists (special case of homeomorphic embedding)\<close>

abbreviation sublisteq :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
  where "sublisteq xs ys \<equiv> list_emb (op =) xs ys"

lemma sublisteq_Cons2: "sublisteq xs ys \<Longrightarrow> sublisteq (x#xs) (x#ys)" by auto

lemma sublisteq_same_length:
  assumes "sublisteq xs ys" and "length xs = length ys" shows "xs = ys"
  using assms by (induct) (auto dest: list_emb_length)

lemma not_sublisteq_length [simp]: "length ys < length xs \<Longrightarrow> \<not> sublisteq xs ys"
  by (metis list_emb_length linorder_not_less)

lemma sublisteq_Cons': "sublisteq (x#xs) ys \<Longrightarrow> sublisteq xs ys"
  by (induct xs, simp, blast dest: list_emb_ConsD)

lemma sublisteq_Cons2':
  assumes "sublisteq (x#xs) (x#ys)" shows "sublisteq xs ys"
  using assms by (cases) (rule sublisteq_Cons')

lemma sublisteq_Cons2_neq:
  assumes "sublisteq (x#xs) (y#ys)"
  shows "x \<noteq> y \<Longrightarrow> sublisteq (x#xs) ys"
  using assms by (cases) auto

lemma sublisteq_Cons2_iff [simp, code]:
  "sublisteq (x#xs) (y#ys) = (if x = y then sublisteq xs ys else sublisteq (x#xs) ys)"
  by (metis list_emb_Cons sublisteq_Cons2 sublisteq_Cons2' sublisteq_Cons2_neq)

lemma sublisteq_append': "sublisteq (zs @ xs) (zs @ ys) \<longleftrightarrow> sublisteq xs ys"
  by (induct zs) simp_all

lemma sublisteq_refl [simp, intro!]: "sublisteq xs xs" by (induct xs) simp_all

lemma sublisteq_antisym:
  assumes "sublisteq xs ys" and "sublisteq ys xs"
  shows "xs = ys"
using assms
proof (induct)
  case list_emb_Nil
  from list_emb_Nil2 [OF this] show ?case by simp
next
  case list_emb_Cons2
  thus ?case by simp
next
  case list_emb_Cons
  hence False using sublisteq_Cons' by fastforce
  thus ?case ..
qed

lemma sublisteq_trans: "sublisteq xs ys \<Longrightarrow> sublisteq ys zs \<Longrightarrow> sublisteq xs zs"
  by (rule list_emb_trans [of _ _ _ "op ="]) auto

lemma sublisteq_append_le_same_iff: "sublisteq (xs @ ys) ys \<longleftrightarrow> xs = []"
  by (auto dest: list_emb_length)

lemma list_emb_append_mono:
  "\<lbrakk> list_emb P xs xs'; list_emb P ys ys' \<rbrakk> \<Longrightarrow> list_emb P (xs@ys) (xs'@ys')"
  apply (induct rule: list_emb.induct)
    apply (metis eq_Nil_appendI list_emb_append2)
   apply (metis append_Cons list_emb_Cons)
  apply (metis append_Cons list_emb_Cons2)
  done

subsection \<open>Appending elements\<close>

lemma sublisteq_append [simp]:
  "sublisteq (xs @ zs) (ys @ zs) \<longleftrightarrow> sublisteq xs ys" (is "?l = ?r")
proof
  { fix xs' ys' xs ys zs :: "'a list" assume "sublisteq xs' ys'"
    then have "xs' = xs @ zs & ys' = ys @ zs \<longrightarrow> sublisteq xs ys"
    proof (induct arbitrary: xs ys zs)
      case list_emb_Nil show ?case by simp
    next
      case (list_emb_Cons xs' ys' x)
      { assume "ys=[]" then have ?case using list_emb_Cons(1) by auto }
      moreover
      { fix us assume "ys = x#us"
        then have ?case using list_emb_Cons(2) by(simp add: list_emb.list_emb_Cons) }
      ultimately show ?case by (auto simp:Cons_eq_append_conv)
    next
      case (list_emb_Cons2 x y xs' ys')
      { assume "xs=[]" then have ?case using list_emb_Cons2(1) by auto }
      moreover
      { fix us vs assume "xs=x#us" "ys=x#vs" then have ?case using list_emb_Cons2 by auto}
      moreover
      { fix us assume "xs=x#us" "ys=[]" then have ?case using list_emb_Cons2(2) by bestsimp }
      ultimately show ?case using \<open>op = x y\<close> by (auto simp: Cons_eq_append_conv)
    qed }
  moreover assume ?l
  ultimately show ?r by blast
next
  assume ?r then show ?l by (metis list_emb_append_mono sublisteq_refl)
qed

lemma sublisteq_drop_many: "sublisteq xs ys \<Longrightarrow> sublisteq xs (zs @ ys)"
  by (induct zs) auto

lemma sublisteq_rev_drop_many: "sublisteq xs ys \<Longrightarrow> sublisteq xs (ys @ zs)"
  by (metis append_Nil2 list_emb_Nil list_emb_append_mono)

subsection \<open>Relation to standard list operations\<close>

lemma sublisteq_map:
  assumes "sublisteq xs ys" shows "sublisteq (map f xs) (map f ys)"
  using assms by (induct) auto

lemma sublisteq_filter_left [simp]: "sublisteq (filter P xs) xs"
  by (induct xs) auto

lemma sublisteq_filter [simp]:
  assumes "sublisteq xs ys" shows "sublisteq (filter P xs) (filter P ys)"
  using assms by induct auto

lemma "sublisteq xs ys \<longleftrightarrow> (\<exists>N. xs = sublist ys N)" (is "?L = ?R")
proof
  assume ?L
  then show ?R
  proof (induct)
    case list_emb_Nil show ?case by (metis sublist_empty)
  next
    case (list_emb_Cons xs ys x)
    then obtain N where "xs = sublist ys N" by blast
    then have "xs = sublist (x#ys) (Suc ` N)"
      by (clarsimp simp add:sublist_Cons inj_image_mem_iff)
    then show ?case by blast
  next
    case (list_emb_Cons2 x y xs ys)
    then obtain N where "xs = sublist ys N" by blast
    then have "x#xs = sublist (x#ys) (insert 0 (Suc ` N))"
      by (clarsimp simp add:sublist_Cons inj_image_mem_iff)
    moreover from list_emb_Cons2 have "x = y" by simp
    ultimately show ?case by blast
  qed
next
  assume ?R
  then obtain N where "xs = sublist ys N" ..
  moreover have "sublisteq (sublist ys N) ys"
  proof (induct ys arbitrary: N)
    case Nil show ?case by simp
  next
    case Cons then show ?case by (auto simp: sublist_Cons)
  qed
  ultimately show ?L by simp
qed

end


(*  Title:      HOL/Induct/QuoDataType.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   2004  University of Cambridge
*)

section\<open>Defining an Initial Algebra by Quotienting a Free Algebra\<close>

theory QuoDataType imports Main begin

subsection\<open>Defining the Free Algebra\<close>

text\<open>Messages with encryption and decryption as free constructors.\<close>
datatype
     freemsg = NONCE  nat
             | MPAIR  freemsg freemsg
             | CRYPT  nat freemsg
             | DECRYPT  nat freemsg

text\<open>The equivalence relation, which makes encryption and decryption inverses
provided the keys are the same.

The first two rules are the desired equations. The next four rules
make the equations applicable to subterms. The last two rules are symmetry
and transitivity.\<close>

inductive_set
  msgrel :: "(freemsg * freemsg) set"
  and msg_rel :: "[freemsg, freemsg] => bool"  (infixl "\<sim>" 50)
  where
    "X \<sim> Y == (X,Y) \<in> msgrel"
  | CD:    "CRYPT K (DECRYPT K X) \<sim> X"
  | DC:    "DECRYPT K (CRYPT K X) \<sim> X"
  | NONCE: "NONCE N \<sim> NONCE N"
  | MPAIR: "\<lbrakk>X \<sim> X'; Y \<sim> Y'\<rbrakk> \<Longrightarrow> MPAIR X Y \<sim> MPAIR X' Y'"
  | CRYPT: "X \<sim> X' \<Longrightarrow> CRYPT K X \<sim> CRYPT K X'"
  | DECRYPT: "X \<sim> X' \<Longrightarrow> DECRYPT K X \<sim> DECRYPT K X'"
  | SYM:   "X \<sim> Y \<Longrightarrow> Y \<sim> X"
  | TRANS: "\<lbrakk>X \<sim> Y; Y \<sim> Z\<rbrakk> \<Longrightarrow> X \<sim> Z"

text\<open>Proving that it is an equivalence relation\<close>

lemma msgrel_refl: "X \<sim> X"
  by (induct X) (blast intro: msgrel.intros)+

theorem equiv_msgrel: "equiv UNIV msgrel"
proof -
  have "refl msgrel" by (simp add: refl_on_def msgrel_refl)
  moreover have "sym msgrel" by (simp add: sym_def, blast intro: msgrel.SYM)
  moreover have "trans msgrel" by (simp add: trans_def, blast intro: msgrel.TRANS)
  ultimately show ?thesis by (simp add: equiv_def)
qed

subsection\<open>Some Functions on the Free Algebra\<close>

subsubsection\<open>The Set of Nonces\<close>

text\<open>A function to return the set of nonces present in a message.  It will
be lifted to the initial algebra, to serve as an example of that process.\<close>
primrec freenonces :: "freemsg \<Rightarrow> nat set" where
  "freenonces (NONCE N) = {N}"
| "freenonces (MPAIR X Y) = freenonces X \<union> freenonces Y"
| "freenonces (CRYPT K X) = freenonces X"
| "freenonces (DECRYPT K X) = freenonces X"

text\<open>This theorem lets us prove that the nonces function respects the
equivalence relation.  It also helps us prove that Nonce
  (the abstract constructor) is injective\<close>
theorem msgrel_imp_eq_freenonces: "U \<sim> V \<Longrightarrow> freenonces U = freenonces V"
  by (induct set: msgrel) auto

subsubsection\<open>The Left Projection\<close>

text\<open>A function to return the left part of the top pair in a message.  It will
be lifted to the initial algebra, to serve as an example of that process.\<close>
primrec freeleft :: "freemsg \<Rightarrow> freemsg" where
  "freeleft (NONCE N) = NONCE N"
| "freeleft (MPAIR X Y) = X"
| "freeleft (CRYPT K X) = freeleft X"
| "freeleft (DECRYPT K X) = freeleft X"

text\<open>This theorem lets us prove that the left function respects the
equivalence relation.  It also helps us prove that MPair
  (the abstract constructor) is injective\<close>
theorem msgrel_imp_eqv_freeleft:
     "U \<sim> V \<Longrightarrow> freeleft U \<sim> freeleft V"
  by (induct set: msgrel) (auto intro: msgrel.intros)

subsubsection\<open>The Right Projection\<close>

text\<open>A function to return the right part of the top pair in a message.\<close>
primrec freeright :: "freemsg \<Rightarrow> freemsg" where
  "freeright (NONCE N) = NONCE N"
| "freeright (MPAIR X Y) = Y"
| "freeright (CRYPT K X) = freeright X"
| "freeright (DECRYPT K X) = freeright X"

text\<open>This theorem lets us prove that the right function respects the
equivalence relation.  It also helps us prove that MPair
  (the abstract constructor) is injective\<close>
theorem msgrel_imp_eqv_freeright:
     "U \<sim> V \<Longrightarrow> freeright U \<sim> freeright V"
  by (induct set: msgrel) (auto intro: msgrel.intros)

subsubsection\<open>The Discriminator for Constructors\<close>

text\<open>A function to distinguish nonces, mpairs and encryptions\<close>
primrec freediscrim :: "freemsg \<Rightarrow> int" where
  "freediscrim (NONCE N) = 0"
| "freediscrim (MPAIR X Y) = 1"
| "freediscrim (CRYPT K X) = freediscrim X + 2"
| "freediscrim (DECRYPT K X) = freediscrim X - 2"

text\<open>This theorem helps us prove @{term "Nonce N \<noteq> MPair X Y"}\<close>
theorem msgrel_imp_eq_freediscrim:
     "U \<sim> V \<Longrightarrow> freediscrim U = freediscrim V"
  by (induct set: msgrel) auto

subsection\<open>The Initial Algebra: A Quotiented Message Type\<close>

definition "Msg = UNIV//msgrel"

typedef msg = Msg
  morphisms Rep_Msg Abs_Msg
  unfolding Msg_def by (auto simp add: quotient_def)

text\<open>The abstract message constructors\<close>
definition
  Nonce :: "nat \<Rightarrow> msg" where
  "Nonce N = Abs_Msg(msgrel``{NONCE N})"

definition
  MPair :: "[msg,msg] \<Rightarrow> msg" where
   "MPair X Y =
       Abs_Msg (\<Union>U \<in> Rep_Msg X. \<Union>V \<in> Rep_Msg Y. msgrel``{MPAIR U V})"

definition
  Crypt :: "[nat,msg] \<Rightarrow> msg" where
   "Crypt K X =
       Abs_Msg (\<Union>U \<in> Rep_Msg X. msgrel``{CRYPT K U})"

definition
  Decrypt :: "[nat,msg] \<Rightarrow> msg" where
   "Decrypt K X =
       Abs_Msg (\<Union>U \<in> Rep_Msg X. msgrel``{DECRYPT K U})"

text\<open>Reduces equality of equivalence classes to the @{term msgrel} relation:
  @{term "(msgrel `` {x} = msgrel `` {y}) = ((x,y) \<in> msgrel)"}\<close>
lemmas equiv_msgrel_iff = eq_equiv_class_iff [OF equiv_msgrel UNIV_I UNIV_I]

declare equiv_msgrel_iff [simp]

text\<open>All equivalence classes belong to set of representatives\<close>

lemma inj_on_Abs_Msg: "inj_on Abs_Msg Msg"
apply (rule inj_on_inverseI)
apply (erule Abs_Msg_inverse)
done

text\<open>Reduces equality on abstractions to equality on representatives\<close>
declare inj_on_Abs_Msg [THEN inj_on_eq_iff, simp]

declare Abs_Msg_inverse [simp]

subsubsection\<open>Characteristic Equations for the Abstract Constructors\<close>

lemma MPair: "MPair (Abs_Msg(msgrel``{U})) (Abs_Msg(msgrel``{V})) =
              Abs_Msg (msgrel``{MPAIR U V})"
proof -
  have "(\<lambda>U V. msgrel `` {MPAIR U V}) respects2 msgrel"
    by (auto simp add: congruent2_def msgrel.MPAIR)
  thus ?thesis
    by (simp add: MPair_def UN_equiv_class2 [OF equiv_msgrel equiv_msgrel])
qed

lemma Crypt: "Crypt K (Abs_Msg(msgrel``{U})) = Abs_Msg (msgrel``{CRYPT K U})"
proof -
  have "(\<lambda>U. msgrel `` {CRYPT K U}) respects msgrel"
    by (auto simp add: congruent_def msgrel.CRYPT)
  thus ?thesis
    by (simp add: Crypt_def UN_equiv_class [OF equiv_msgrel])
qed

lemma Decrypt:
     "Decrypt K (Abs_Msg(msgrel``{U})) = Abs_Msg (msgrel``{DECRYPT K U})"
proof -
  have "(\<lambda>U. msgrel `` {DECRYPT K U}) respects msgrel"
    by (auto simp add: congruent_def msgrel.DECRYPT)
  thus ?thesis
    by (simp add: Decrypt_def UN_equiv_class [OF equiv_msgrel])
qed

text\<open>Case analysis on the representation of a msg as an equivalence class.\<close>
lemma eq_Abs_Msg [case_names Abs_Msg, cases type: msg]:
     "(!!U. z = Abs_Msg(msgrel``{U}) ==> P) ==> P"
apply (rule Rep_Msg [of z, unfolded Msg_def, THEN quotientE])
apply (drule arg_cong [where f=Abs_Msg])
apply (auto simp add: Rep_Msg_inverse intro: msgrel_refl)
done

text\<open>Establishing these two equations is the point of the whole exercise\<close>
theorem CD_eq [simp]: "Crypt K (Decrypt K X) = X"
by (cases X, simp add: Crypt Decrypt CD)

theorem DC_eq [simp]: "Decrypt K (Crypt K X) = X"
by (cases X, simp add: Crypt Decrypt DC)

subsection\<open>The Abstract Function to Return the Set of Nonces\<close>

definition
  nonces :: "msg \<Rightarrow> nat set" where
   "nonces X = (\<Union>U \<in> Rep_Msg X. freenonces U)"

lemma nonces_congruent: "freenonces respects msgrel"
by (auto simp add: congruent_def msgrel_imp_eq_freenonces)

text\<open>Now prove the four equations for @{term nonces}\<close>

lemma nonces_Nonce [simp]: "nonces (Nonce N) = {N}"
by (simp add: nonces_def Nonce_def
              UN_equiv_class [OF equiv_msgrel nonces_congruent])

lemma nonces_MPair [simp]: "nonces (MPair X Y) = nonces X \<union> nonces Y"
apply (cases X, cases Y)
apply (simp add: nonces_def MPair
                 UN_equiv_class [OF equiv_msgrel nonces_congruent])
done

lemma nonces_Crypt [simp]: "nonces (Crypt K X) = nonces X"
apply (cases X)
apply (simp add: nonces_def Crypt
                 UN_equiv_class [OF equiv_msgrel nonces_congruent])
done

lemma nonces_Decrypt [simp]: "nonces (Decrypt K X) = nonces X"
apply (cases X)
apply (simp add: nonces_def Decrypt
                 UN_equiv_class [OF equiv_msgrel nonces_congruent])
done

subsection\<open>The Abstract Function to Return the Left Part\<close>

definition
  left :: "msg \<Rightarrow> msg" where
   "left X = Abs_Msg (\<Union>U \<in> Rep_Msg X. msgrel``{freeleft U})"

lemma left_congruent: "(\<lambda>U. msgrel `` {freeleft U}) respects msgrel"
by (auto simp add: congruent_def msgrel_imp_eqv_freeleft)

text\<open>Now prove the four equations for @{term left}\<close>

lemma left_Nonce [simp]: "left (Nonce N) = Nonce N"
by (simp add: left_def Nonce_def
              UN_equiv_class [OF equiv_msgrel left_congruent])

lemma left_MPair [simp]: "left (MPair X Y) = X"
apply (cases X, cases Y)
apply (simp add: left_def MPair
                 UN_equiv_class [OF equiv_msgrel left_congruent])
done

lemma left_Crypt [simp]: "left (Crypt K X) = left X"
apply (cases X)
apply (simp add: left_def Crypt
                 UN_equiv_class [OF equiv_msgrel left_congruent])
done

lemma left_Decrypt [simp]: "left (Decrypt K X) = left X"
apply (cases X)
apply (simp add: left_def Decrypt
                 UN_equiv_class [OF equiv_msgrel left_congruent])
done

subsection\<open>The Abstract Function to Return the Right Part\<close>

definition
  right :: "msg \<Rightarrow> msg" where
   "right X = Abs_Msg (\<Union>U \<in> Rep_Msg X. msgrel``{freeright U})"

lemma right_congruent: "(\<lambda>U. msgrel `` {freeright U}) respects msgrel"
by (auto simp add: congruent_def msgrel_imp_eqv_freeright)

text\<open>Now prove the four equations for @{term right}\<close>

lemma right_Nonce [simp]: "right (Nonce N) = Nonce N"
by (simp add: right_def Nonce_def
              UN_equiv_class [OF equiv_msgrel right_congruent])

lemma right_MPair [simp]: "right (MPair X Y) = Y"
apply (cases X, cases Y)
apply (simp add: right_def MPair
                 UN_equiv_class [OF equiv_msgrel right_congruent])
done

lemma right_Crypt [simp]: "right (Crypt K X) = right X"
apply (cases X)
apply (simp add: right_def Crypt
                 UN_equiv_class [OF equiv_msgrel right_congruent])
done

lemma right_Decrypt [simp]: "right (Decrypt K X) = right X"
apply (cases X)
apply (simp add: right_def Decrypt
                 UN_equiv_class [OF equiv_msgrel right_congruent])
done

subsection\<open>Injectivity Properties of Some Constructors\<close>

lemma NONCE_imp_eq: "NONCE m \<sim> NONCE n \<Longrightarrow> m = n"
by (drule msgrel_imp_eq_freenonces, simp)

text\<open>Can also be proved using the function @{term nonces}\<close>
lemma Nonce_Nonce_eq [iff]: "(Nonce m = Nonce n) = (m = n)"
by (auto simp add: Nonce_def msgrel_refl dest: NONCE_imp_eq)

lemma MPAIR_imp_eqv_left: "MPAIR X Y \<sim> MPAIR X' Y' \<Longrightarrow> X \<sim> X'"
by (drule msgrel_imp_eqv_freeleft, simp)

lemma MPair_imp_eq_left:
  assumes eq: "MPair X Y = MPair X' Y'" shows "X = X'"
proof -
  from eq
  have "left (MPair X Y) = left (MPair X' Y')" by simp
  thus ?thesis by simp
qed

lemma MPAIR_imp_eqv_right: "MPAIR X Y \<sim> MPAIR X' Y' \<Longrightarrow> Y \<sim> Y'"
by (drule msgrel_imp_eqv_freeright, simp)

lemma MPair_imp_eq_right: "MPair X Y = MPair X' Y' \<Longrightarrow> Y = Y'"
apply (cases X, cases X', cases Y, cases Y')
apply (simp add: MPair)
apply (erule MPAIR_imp_eqv_right)
done

theorem MPair_MPair_eq [iff]: "(MPair X Y = MPair X' Y') = (X=X' & Y=Y')"
by (blast dest: MPair_imp_eq_left MPair_imp_eq_right)

lemma NONCE_neqv_MPAIR: "NONCE m \<sim> MPAIR X Y \<Longrightarrow> False"
by (drule msgrel_imp_eq_freediscrim, simp)

theorem Nonce_neq_MPair [iff]: "Nonce N \<noteq> MPair X Y"
apply (cases X, cases Y)
apply (simp add: Nonce_def MPair)
apply (blast dest: NONCE_neqv_MPAIR)
done

text\<open>Example suggested by a referee\<close>
theorem Crypt_Nonce_neq_Nonce: "Crypt K (Nonce M) \<noteq> Nonce N"
by (auto simp add: Nonce_def Crypt dest: msgrel_imp_eq_freediscrim)

text\<open>...and many similar results\<close>
theorem Crypt2_Nonce_neq_Nonce: "Crypt K (Crypt K' (Nonce M)) \<noteq> Nonce N"
by (auto simp add: Nonce_def Crypt dest: msgrel_imp_eq_freediscrim)

theorem Crypt_Crypt_eq [iff]: "(Crypt K X = Crypt K X') = (X=X')"
proof
  assume "Crypt K X = Crypt K X'"
  hence "Decrypt K (Crypt K X) = Decrypt K (Crypt K X')" by simp
  thus "X = X'" by simp
next
  assume "X = X'"
  thus "Crypt K X = Crypt K X'" by simp
qed

theorem Decrypt_Decrypt_eq [iff]: "(Decrypt K X = Decrypt K X') = (X=X')"
proof
  assume "Decrypt K X = Decrypt K X'"
  hence "Crypt K (Decrypt K X) = Crypt K (Decrypt K X')" by simp
  thus "X = X'" by simp
next
  assume "X = X'"
  thus "Decrypt K X = Decrypt K X'" by simp
qed

lemma msg_induct [case_names Nonce MPair Crypt Decrypt, cases type: msg]:
  assumes N: "\<And>N. P (Nonce N)"
      and M: "\<And>X Y. \<lbrakk>P X; P Y\<rbrakk> \<Longrightarrow> P (MPair X Y)"
      and C: "\<And>K X. P X \<Longrightarrow> P (Crypt K X)"
      and D: "\<And>K X. P X \<Longrightarrow> P (Decrypt K X)"
  shows "P msg"
proof (cases msg)
  case (Abs_Msg U)
  have "P (Abs_Msg (msgrel `` {U}))"
  proof (induct U)
    case (NONCE N)
    with N show ?case by (simp add: Nonce_def)
  next
    case (MPAIR X Y)
    with M [of "Abs_Msg (msgrel `` {X})" "Abs_Msg (msgrel `` {Y})"]
    show ?case by (simp add: MPair)
  next
    case (CRYPT K X)
    with C [of "Abs_Msg (msgrel `` {X})"]
    show ?case by (simp add: Crypt)
  next
    case (DECRYPT K X)
    with D [of "Abs_Msg (msgrel `` {X})"]
    show ?case by (simp add: Decrypt)
  qed
  with Abs_Msg show ?thesis by (simp only:)
qed

subsection\<open>The Abstract Discriminator\<close>

text\<open>However, as \<open>Crypt_Nonce_neq_Nonce\<close> above illustrates, we don't
need this function in order to prove discrimination theorems.\<close>

definition
  discrim :: "msg \<Rightarrow> int" where
   "discrim X = the_elem (\<Union>U \<in> Rep_Msg X. {freediscrim U})"

lemma discrim_congruent: "(\<lambda>U. {freediscrim U}) respects msgrel"
by (auto simp add: congruent_def msgrel_imp_eq_freediscrim)

text\<open>Now prove the four equations for @{term discrim}\<close>

lemma discrim_Nonce [simp]: "discrim (Nonce N) = 0"
by (simp add: discrim_def Nonce_def
              UN_equiv_class [OF equiv_msgrel discrim_congruent])

lemma discrim_MPair [simp]: "discrim (MPair X Y) = 1"
apply (cases X, cases Y)
apply (simp add: discrim_def MPair
                 UN_equiv_class [OF equiv_msgrel discrim_congruent])
done

lemma discrim_Crypt [simp]: "discrim (Crypt K X) = discrim X + 2"
apply (cases X)
apply (simp add: discrim_def Crypt
                 UN_equiv_class [OF equiv_msgrel discrim_congruent])
done

lemma discrim_Decrypt [simp]: "discrim (Decrypt K X) = discrim X - 2"
apply (cases X)
apply (simp add: discrim_def Decrypt
                 UN_equiv_class [OF equiv_msgrel discrim_congruent])
done

end


(******************************************************************************)
(* Project: Isabelle/UTP Toolkit                                              *)
(* File: Infinity.thy                                                         *)
(* Authors: Frank Zeyda and Simon Foster (University of York, UK)             *)
(* Emails: frank.zeyda@york.ac.uk and simon.foster@york.ac.uk                 *)
(******************************************************************************)

section \<open> Infinity Supplement \<close>

theory Infinity
imports HOL.Real
  "HOL-Library.Infinite_Set"
  "Optics.Two"
begin

text \<open>
  This theory introduces a type class \<open>infinite\<close> that guarantees that the
  underlying universe of the type is infinite. It also provides useful theorems
  to prove infinity of the universes for various HOL types.
\<close>

subsection \<open> Type class \<open>infinite\<close> \<close>

text \<open>
  The type class postulates that the universe (carrier) of a type is infinite.
\<close>

class infinite =
  assumes infinite_UNIV [simp]: "infinite (UNIV :: 'a set)"

subsection \<open> Infinity Theorems \<close>

text \<open> Useful theorems to prove that a type's @{const UNIV} is infinite. \<close>

text \<open>
  Note that @{thm [source] infinite_UNIV_nat} is already a simplification rule
  by default.
\<close>

lemmas infinite_UNIV_int [simp]

theorem infinite_UNIV_real [simp]:
"infinite (UNIV :: real set)"
  by (rule infinite_UNIV_char_0)

theorem infinite_UNIV_fun1 [simp]:
"infinite (UNIV :: 'a set) \<Longrightarrow>
 card (UNIV :: 'b set) \<noteq> Suc 0 \<Longrightarrow>
 infinite (UNIV :: ('a \<Rightarrow> 'b) set)"
  apply (erule contrapos_nn)
  apply (erule finite_fun_UNIVD1)
  apply (assumption)
  done

theorem infinite_UNIV_fun2 [simp]:
"infinite (UNIV :: 'b set) \<Longrightarrow>
 infinite (UNIV :: ('a \<Rightarrow> 'b) set)"
  apply (erule contrapos_nn)
  apply (erule finite_fun_UNIVD2)
  done

theorem infinite_UNIV_set [simp]:
"infinite (UNIV :: 'a set) \<Longrightarrow>
 infinite (UNIV :: 'a set set)"
  apply (erule contrapos_nn)
  apply (simp add: Finite_Set.finite_set)
  done

theorem infinite_UNIV_prod1 [simp]:
"infinite (UNIV :: 'a set) \<Longrightarrow>
 infinite (UNIV :: ('a \<times> 'b) set)"
  apply (erule contrapos_nn)
  apply (simp add: finite_prod)
  done

theorem infinite_UNIV_prod2 [simp]:
"infinite (UNIV :: 'b set) \<Longrightarrow>
 infinite (UNIV :: ('a \<times> 'b) set)"
  apply (erule contrapos_nn)
  apply (simp add: finite_prod)
  done

theorem infinite_UNIV_sum1 [simp]:
"infinite (UNIV :: 'a set) \<Longrightarrow>
 infinite (UNIV :: ('a + 'b) set)"
  apply (erule contrapos_nn)
  apply (simp)
  done

theorem infinite_UNIV_sum2 [simp]:
"infinite (UNIV :: 'b set) \<Longrightarrow>
 infinite (UNIV :: ('a + 'b) set)"
  apply (erule contrapos_nn)
  apply (simp)
  done

theorem infinite_UNIV_option [simp]:
"infinite (UNIV :: 'a set) \<Longrightarrow>
 infinite (UNIV :: 'a option set)"
  apply (erule contrapos_nn)
  apply (simp)
  done

theorem infinite_image [intro]:
"infinite A \<Longrightarrow> inj_on f A \<Longrightarrow> infinite (f ` A)"
  apply (metis finite_imageD)
  done

theorem infinite_transfer (*[intro]*) :
"infinite B \<Longrightarrow> B \<subseteq> f ` A \<Longrightarrow> infinite A"
  using infinite_super
  apply (blast)
  done

subsection \<open> Instantiations \<close>

text \<open>
  The instantiations for product and sum types have stronger caveats than in
  principle needed. Namely, it would be sufficient for one type of a product
  or sum to be infinite. A corresponding rule, however, cannot be formulated
  using type classes. Generally, classes are not entirely adequate for the
  purpose of deriving the infinity of HOL types, which is perhaps why a class
  such as @{class infinite} was omitted from the Isabelle/HOL library.
\<close>

instance nat :: infinite by (intro_classes, simp)
instance int :: infinite by (intro_classes, simp)
instance real :: infinite by (intro_classes, simp)
instance "fun" :: (type, infinite) infinite by (intro_classes, simp)
instance set :: (infinite) infinite by (intro_classes, simp)
instance prod :: (infinite, infinite) infinite by (intro_classes, simp)
instance sum :: (infinite, infinite) infinite by (intro_classes, simp)
instance list :: (type) infinite by (intro_classes, simp)
instance option :: (infinite) infinite by (intro_classes, simp)

subclass (in infinite) two  by (intro_classes, auto)

end


(*
    File:     IDirProds.thy
    Author:   Joseph Thommes, TU München
*)
section \<open>Internal direct product\<close>

theory IDirProds
  imports Generated_Groups_Extend General_Auxiliary
begin

subsection \<open>Complementarity\<close>

text \<open>We introduce the notion of complementarity, that plays a central role in the internal
direct group product and prove some basic properties about it.\<close>

definition (in group) complementary :: "'a set \<Rightarrow> 'a set \<Rightarrow> bool" where
  "complementary H1 H2 \<longleftrightarrow> H1 \<inter> H2 = {\<one>}"

lemma (in group) complementary_symm: "complementary A B \<longleftrightarrow> complementary B A"
  unfolding complementary_def by blast

lemma (in group) subgroup_carrier_complementary:
  assumes "complementary H J" "subgroup I (G\<lparr>carrier := H\<rparr>)" "subgroup K (G\<lparr>carrier := J\<rparr>)"
  shows "complementary I K"
proof -
  have "\<one> \<in> I"  "\<one> \<in> K" using subgroup.one_closed assms by fastforce+
  moreover have "I \<inter> K \<subseteq> H \<inter> J" using subgroup.subset assms by force
  ultimately show ?thesis using assms unfolding complementary_def by blast
qed

lemma (in group) subgroup_subset_complementary:
  assumes "subgroup H G" "subgroup J G" "subgroup I G"
  and "I \<subseteq> J" "complementary H J"
shows "complementary H I"
  by (intro subgroup_carrier_complementary[OF assms(5), of H I] subgroup_incl, use assms in auto)

lemma (in group) complementary_subgroup_iff:
  assumes "subgroup H G"
  shows "complementary A B \<longleftrightarrow> group.complementary (G\<lparr>carrier := H\<rparr>) A B"
proof -
  interpret H: group "G\<lparr>carrier := H\<rparr>" using subgroup.subgroup_is_group assms by blast
  have "\<one>\<^bsub>G\<^esub> = \<one>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub>" by simp
  then show ?thesis unfolding complementary_def H.complementary_def by simp
qed

lemma (in group) subgroups_card_coprime_imp_compl:
  assumes "subgroup H G" "subgroup J G" "coprime (card H) (card J)"
  shows "complementary H J" unfolding complementary_def
proof -
  interpret JH: subgroup "(H \<inter> J)" G using assms subgroups_Inter_pair by blast
  from subgroups_card_coprime_inter_card_one[OF assms] show "H \<inter> J = {\<one>}" using JH.one_closed
    by (metis card_1_singletonE singletonD)
qed

lemma (in group) prime_power_complementary_groups:
  assumes "Factorial_Ring.prime p" "Factorial_Ring.prime q" "p \<noteq> q"
  and "subgroup P G" "card P = p ^ x"
  and "subgroup Q G" "card Q = q ^ y"
  shows "complementary P Q"
proof -
  from assms have "coprime (card P) (card Q)"
    by (metis coprime_power_right_iff primes_coprime coprime_def)
  then show ?thesis using subgroups_card_coprime_imp_compl assms complementary_def by blast
qed

text \<open>With the previous work from the theory about set multiplication we can characterize
complementarity of two subgroups in abelian groups by the cardinality of their product.\<close>

lemma (in comm_group) compl_imp_diff_cosets:
  assumes "subgroup H G" "subgroup J G" "finite H" "finite J"
  and "complementary H J"
  shows "\<And>a b. \<lbrakk>a \<in> J; b \<in> J; a \<noteq> b\<rbrakk> \<Longrightarrow> (H #> a) \<noteq> (H #> b)"
proof (rule ccontr; safe)
  fix a b
  assume ab: "a \<in> J" "b \<in> J" "a \<noteq> b"
  then have [simp]: "a \<in> carrier G" "b \<in> carrier G" using assms subgroup.subset by auto
  assume "H #> a = H #> b"
  then have "a \<otimes> inv b \<in> H" using assms(1, 2) ab
    by (metis comm_group_axioms comm_group_def rcos_self
              subgroup.mem_carrier subgroup.rcos_module_imp)
  moreover have "a \<otimes> inv b \<in> J"
    by (rule subgroup.m_closed[OF assms(2) ab(1) subgroup.m_inv_closed[OF assms(2) ab(2)]])
  moreover have "a \<otimes> inv b \<noteq> \<one>" using ab inv_equality by fastforce
  ultimately have "H \<inter> J \<noteq> {\<one>}" by blast
  thus False using assms(5) unfolding complementary_def by blast
qed

lemma (in comm_group) finite_sub_card_eq_mult_imp_comp:
  assumes "subgroup H G" "subgroup J G" "finite H" "finite J"
  and "card (H <#> J) = (card J * card H)"
  shows "complementary H J"
  unfolding complementary_def
proof (rule ccontr)
  assume "H \<inter> J \<noteq> {\<one>}"
  have "\<one> \<in> H" using subgroup.one_closed assms(1) by blast
  moreover have "\<one> \<in> J" using subgroup.one_closed assms(2) by blast
  ultimately have "\<one> \<in> (H \<inter> J)" by blast

  then obtain a where a_def: "a \<in> (H \<inter> J) \<and> a \<noteq> \<one>" using \<open>H \<inter> J \<noteq> {\<one>}\<close> by blast
  then have aH: "a \<in> H" by blast
  then have a_inv_H: "inv a \<in> H \<and> inv a \<noteq> \<one>" using assms(1)
    by (meson a_def inv_eq_1_iff subgroup.mem_carrier subgroupE(3))
  from a_def have aJ: "a \<in> J" by blast
  then have a_inv_J: "inv a \<in> J \<and> inv a \<noteq> \<one>" using assms(2)
    by (meson a_def inv_eq_1_iff subgroup.mem_carrier subgroupE(3))
  from a_def have a_c: "a \<in> carrier G" using subgroup.subset[of J G] assms(2) by blast

  from set_mult_card_eq_impl_empty_inter'[of H J]
  have empty: "\<And>a b. \<lbrakk>a \<in> H; b \<in> H; a \<noteq> b\<rbrakk> \<Longrightarrow> (l_coset G a J) \<inter> (l_coset G b J) = {}"
    using assms subgroup.subset[of _ G] by simp

  have "\<one> \<in> \<one> <# J" using \<open>\<one> \<in> J\<close> unfolding l_coset_def by force
  moreover have "\<one> \<in> a <# J" using a_inv_J aJ a_c assms \<open>\<one> \<in> J\<close> coset_join3 by blast
  ultimately have "(l_coset G \<one> J) \<inter> (l_coset G a J) \<noteq> {}" by blast

  then show "False" using empty[of "\<one>" a] a_def aH \<open>\<one> \<in> H\<close> by blast
qed

lemma (in comm_group) finite_sub_comp_imp_card_eq_mult:
  assumes "subgroup H G" "subgroup J G" "finite H" "finite J"
  and "complementary H J"
shows "card (H <#> J) = card J * card H"
proof -
  have carr: "H \<subseteq> carrier G" "J \<subseteq> carrier G" using assms subgroup.subset by auto

  from coset_neq_imp_empty_inter[OF assms(1)] compl_imp_diff_cosets[OF assms(1,2)]
  have em_inter: "\<And>a b. \<lbrakk>a \<in> J; b \<in> J; a \<noteq> b\<rbrakk> \<Longrightarrow> (H #> a) \<inter> (H #> b) = {}"
    by (meson assms subgroup.mem_carrier)

  have "card (\<Union>a\<in>J. (H #> a)) = card J * card H" using assms(4) carr(2) em_inter
  proof (induction J rule: finite_induct)
    case empty
    then show ?case by auto
  next
    case i: (insert x F)
    then have cF:"card (\<Union> ((#>) H ` F)) = card F * card H" by blast
    have xc[simp]: "x \<in> carrier G" using i(4) by simp
    let ?J = "insert x F"
    from i(2, 4, 5) have em:"(H #> x) \<inter> (\<Union>y\<in>F. (H #> y)) = {}" by auto
    have "finite (H #> x)"
      by (meson carr(1) rcosetsI rcosets_finite assms(3) xc)
    moreover have "finite (H <#> F)" using set_mult_finite[OF assms(3) i(1) carr(1)] i(4) by blast
    moreover have "H <#> F = (\<Union>a\<in>F. (H #> a))"
      unfolding set_mult_def using r_coset_def[of G H] by auto
    ultimately have "card(H #> x) + card(\<Union>y\<in>F. (H #> y))
                   = card((H #> x) \<union> (\<Union>y\<in>F. (H #> y))) + card((H #> x) \<inter> (\<Union>y\<in>F. (H #> y)))"
      using card_Un_Int by auto
    then have "card(H #> x) + card(\<Union>y\<in>F. (H #> y)) = card((H #> x) \<union> (\<Union>y\<in>F. (H #> y)))"
      using i(5) em by simp
    moreover have "card (H #> x) = card H"
      using card_rcosets_equal[of _ H] rcosetsI[of H] carr(1) xc by metis
    moreover have "card (insert x F) * card H = card F * card H + card H"
      by (simp add: i)
    ultimately show ?case using cF by simp
  qed
  moreover have "H <#> J = (\<Union>a\<in>J. (H #> a))"
    unfolding set_mult_def using r_coset_def[of G H] by auto
  ultimately show "card (H <#> J) = card J * card H" by argo
qed

lemma (in comm_group) finite_sub_comp_iff_card_eq_mult:
  assumes "subgroup H G" "subgroup J G" "finite H" "finite J"
  shows "card (H <#> J) = card J * card H  \<longleftrightarrow> complementary H J"
  using finite_sub_comp_imp_card_eq_mult[OF assms] finite_sub_card_eq_mult_imp_comp[OF assms]
  by blast

subsection \<open>\<open>IDirProd\<close> - binary internal direct product\<close>

text \<open>We introduce the internal direct product formed by two subgroups (so in its binary form).\<close>

definition IDirProd :: "('a, 'b) monoid_scheme \<Rightarrow> 'a set \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "IDirProd G Y Z = generate G (Y \<union> Z)"

text \<open>Some trivial lemmas about the binary internal direct product.\<close>

lemma (in group) IDirProd_comm:
  "IDirProd G A B = IDirProd G B A"
  unfolding IDirProd_def by (simp add: sup_commute)

lemma (in group) IDirProd_empty_right:
  assumes "A \<subseteq> carrier G"
  shows "IDirProd G A {} = generate G A"
  unfolding IDirProd_def by simp

lemma (in group) IDirProd_empty_left:
  assumes "A \<subseteq> carrier G"
  shows "IDirProd G {} A = generate G A"
  unfolding IDirProd_def by simp

lemma (in group) IDirProd_one_right:
  assumes "A \<subseteq> carrier G"
  shows "IDirProd G A {\<one>} = generate G A"
  unfolding IDirProd_def
proof
  interpret sA: subgroup "(generate G A)" G using assms generate_is_subgroup by simp
  interpret sAone: subgroup "(generate G (A \<union> {\<one>}))" G using assms generate_is_subgroup by simp
  show "generate G (A \<union> {\<one>}) \<subseteq> generate G A"
    using generate_subgroup_incl[of "A \<union> {\<one>}" "generate G A"]
          generate.incl assms sA.one_closed sA.subgroup_axioms by fast
  show "generate G A \<subseteq> generate G (A \<union> {\<one>})"
    using mono_generate[of A "A \<union> {\<one>}"] by blast
qed

lemma (in group) IDirProd_one_left:
  assumes "A \<subseteq> carrier G"
  shows "IDirProd G {\<one>} A = generate G A"
  using IDirProd_one_right[of A] assms unfolding IDirProd_def by force

lemma (in group) IDirProd_is_subgroup:
  assumes "Y \<subseteq> carrier G" "Z \<subseteq> carrier G"
  shows "subgroup (IDirProd G Y Z) G"
  unfolding IDirProd_def using generate_is_subgroup[of "Y \<union> Z"] assms by simp

text \<open>Using the theory about set multiplication we can also show the connection of the underlying
set in the internal direct product with the set multiplication in the case of an abelian group.
Together with the facts about complementarity and the set multiplication we can characterize
complementarity by the cardinality of the internal direct product and vice versa.\<close>

lemma (in comm_group) IDirProd_eq_subgroup_mult:
  assumes "subgroup H G" "subgroup J G"
  shows "IDirProd G H J = H <#> J"
  unfolding IDirProd_def
  by (rule set_mult_eq_generate_subgroup[OF assms])

lemma (in comm_group) finite_sub_comp_iff_card_eq_IDirProd:
  assumes "subgroup H G" "subgroup J G" "finite H" "finite J"
  shows "card (IDirProd G H J) = card J * card H  \<longleftrightarrow> complementary H J"
  using finite_sub_comp_iff_card_eq_mult IDirProd_eq_subgroup_mult assms by presburger

subsection \<open>\<open>IDirProds\<close> - indexed internal direct product\<close>

text \<open>The indexed version of the internal direct product acting on a family of subgroups.\<close>

definition IDirProds :: "('a, 'b) monoid_scheme \<Rightarrow> ('c \<Rightarrow> 'a set) \<Rightarrow> 'c set \<Rightarrow> 'a set" where
  "IDirProds G S I = generate G (\<Union>(S ` I))"

text \<open>Lemmas about the indexed internal direct product.\<close>

lemma (in group) IDirProds_incl:
  assumes "i \<in> I"
  shows "S i \<subseteq> IDirProds G S I"
  unfolding IDirProds_def using assms generate.incl[of _ "\<Union>(S ` I)" G] by blast

lemma (in group) IDirProds_empty:
  "IDirProds G S {} = {\<one>}"
  unfolding IDirProds_def using generate_empty by simp

lemma (in group) IDirProds_is_subgroup:
  assumes "\<Union>(S ` I) \<subseteq> (carrier G)"
  shows "subgroup (IDirProds G S I) G"
  unfolding IDirProds_def using generate_is_subgroup[of "\<Union>(S ` I)"] assms by auto

lemma (in group) IDirProds_subgroup_id: "subgroup (S i) G \<Longrightarrow> IDirProds G S {i} = S i"
  by (simp add: generate_subgroup_id IDirProds_def)

lemma (in comm_group) IDirProds_Un:
  assumes "\<forall>i\<in>A. subgroup (S i) G" "\<forall>j\<in>B. subgroup (S j) G"
  shows   "IDirProds G S (A \<union> B) = IDirProds G S A <#> IDirProds G S B"
proof -
  have subset: "\<Union> (S ` A) \<subseteq> carrier G" "\<Union> (S ` B) \<subseteq> carrier G"
    using subgroup.subset assms(1, 2) by blast+
  have "IDirProds G S A <#> IDirProds G S B = IDirProd G (IDirProds G S A) (IDirProds G S B)"
    using assms by (intro IDirProd_eq_subgroup_mult [symmetric] IDirProds_is_subgroup subset)
  also have "\<dots> = generate G (\<Union> (S ` A) \<union> IDirProds G S B)"
    unfolding IDirProds_def IDirProd_def by (intro generate_idem' generate_incl subset)
  also have "\<dots> = generate G (\<Union>(S ` A) \<union> \<Union>(S ` B))"
    unfolding IDirProds_def IDirProd_def
    by (intro generate_idem'_right generate_incl subset)
  also have "\<Union>(S ` A) \<union> \<Union>(S ` B) = \<Union>(S ` (A \<union> B))"
    by blast
  also have "generate G \<dots> = IDirProds G S (A \<union> B)"
    unfolding IDirProds_def ..
  finally show ?thesis ..
qed

lemma (in comm_group) IDirProds_finite:
  assumes "finite I" "\<forall>i\<in>I. subgroup (S i) G" "\<forall>i\<in>I. finite (S i)"
  shows "finite (IDirProds G S I)" using assms
proof (induction I rule: finite_induct)
  case empty
  thus ?case using IDirProds_empty[of S] by simp
next
  case i: (insert x I)
  interpret Sx: subgroup "S x" G using i by blast
  have cx: "(S x) \<subseteq> carrier G" by force
  have cI: "\<Union>(S ` I) \<subseteq> carrier G" using i subgroup.subset by blast
  interpret subgroup "IDirProds G S I" G using IDirProds_is_subgroup[OF cI] .
  have cIP: "(IDirProds G S I) \<subseteq> carrier G" by force
  from i have f: "finite (S x)" "finite (IDirProds G S I)" "finite {x}" by blast+
  from IDirProds_Un[of "{x}" S I]
  have "IDirProds G S ({x} \<union> I) = IDirProds G S {x} <#> IDirProds G S I" using i by blast
  also have "\<dots> = S x <#> IDirProds G S I"
    using IDirProds_subgroup_id[of S x] Sx.subgroup_axioms by force
  also have "finite (\<dots>)" using set_mult_finite[OF f(1, 2) cx cIP] .
  finally show ?case unfolding insert_def by simp
qed

lemma (in comm_group) IDirProds_compl_imp_compl:
  assumes "\<forall>i \<in> I. subgroup (S i) G" and "subgroup H G"
  assumes "complementary H (IDirProds G S I)" "i \<in> I"
  shows   "complementary H (S i)"
proof -
  have "S i \<subseteq> IDirProds G S I" using assms IDirProds_incl by fast
  then have "H \<inter> (S i) \<subseteq> H \<inter> IDirProds G S I" by blast
  moreover have "\<one> \<in> H \<inter> (S i)" using subgroup.one_closed assms by auto
  ultimately show "complementary H (S i)" using assms(3) unfolding complementary_def by blast
qed

text \<open>Using the knowledge about the binary internal direct product, we can - in case that all
subgroups in the family have coprime orders - also derive the cardinality of the indexed internal
direct product.\<close>

lemma (in comm_group) IDirProds_card:
  assumes "finite I" "\<forall>i\<in>I. subgroup (S i) G"
          "\<forall>i\<in>I. finite (S i)" "pairwise (\<lambda>x y. coprime (card (S x)) (card (S y))) I"
  shows "card (IDirProds G S I) = (\<Prod>i \<in> I. card (S i))" using assms
proof (induction I rule: finite_induct)
  case empty
  then show ?case using IDirProds_empty[of S] by simp
next
  case i: (insert x I)
  have sx: "subgroup (S x) G" using i(4) by blast
  have cx: "(S x) \<subseteq> carrier G" using subgroup.subset[OF sx] .
  have fx: "finite (S x)" using i by blast
  have cI: "\<Union>(S ` I) \<subseteq> carrier G" using subgroup.subset[of _ G] i(4) by blast
  from generate_is_subgroup[OF this] have sIP: "subgroup (IDirProds G S I) G"
    unfolding IDirProds_def .
  then have cIP: "(IDirProds G S I) \<subseteq> carrier G" using subgroup.subset by blast
  have fIP: "finite (IDirProds G S I)" using IDirProds_finite[OF i(1)] i by blast

  from i have ih: "card (IDirProds G S I) = (\<Prod>i\<in>I. card (S i))" unfolding pairwise_def by blast
  hence cop: "coprime (card (IDirProds G S I)) (card (S x))"
  proof -
    have cFI0: "card (IDirProds G S I) \<noteq> 0" using finite_subgroup_card_neq_0[OF sIP fIP] .
    moreover have cx0: "card (S x) \<noteq> 0" using finite_subgroup_card_neq_0[OF sx fx] .
    moreover have  "prime_factors (card (IDirProds G S I)) \<inter> prime_factors (card (S x)) = {}"
    proof (rule ccontr)
      have n0: "\<And>i. i \<in> I \<Longrightarrow> card (S i) \<noteq> 0" using finite_subgroup_card_neq_0 i(4, 5) by blast
      assume "prime_factors (card (IDirProds G S I)) \<inter> prime_factors (card (S x)) \<noteq> {}"
      moreover have "prime_factors (card (IDirProds G S I)) = \<Union>(prime_factors ` (card \<circ> S) ` I)"
        using n0 prime_factors_Prod[OF i(1), of "card \<circ> S"] by (subst ih; simp)
      moreover have "\<And>i. i \<in> I \<Longrightarrow> prime_factors (card (S i)) \<inter> prime_factors (card (S x)) = {}"
      proof -
        fix i
        assume ind: "i \<in> I"
        then have coPx: "coprime (card (S i)) (card (S x))"
          using i(2, 6) unfolding pairwise_def by auto
        have "card (S i) \<noteq> 0" using n0 ind by blast
        from coprime_eq_empty_prime_inter[OF this cx0]
        show "prime_factors (card (S i)) \<inter> prime_factors (card (S x)) = {}" using coPx by blast
      qed
      ultimately show "False" by auto
    qed
    ultimately show ?thesis using coprime_eq_empty_prime_inter by blast
  qed
  have "card (IDirProds G S (insert x I)) = card (S x) * card (IDirProds G S I)"
  proof -
    from finite_sub_comp_iff_card_eq_IDirProd[OF sIP sx fIP fx]
         subgroups_card_coprime_imp_compl[OF sIP sx cop]
    have "card (IDirProd G (IDirProds G S I) (S x)) = card (S x) * card (IDirProds G S I)" by blast
    moreover have "generate G (\<Union> (S ` insert x I)) = generate G (generate G (\<Union> (S ` I)) \<union> S x)"
      by (simp add: Un_commute cI cx generate_idem'_right)
    ultimately show ?thesis unfolding IDirProds_def IDirProd_def by argo
  qed
  also have "\<dots> = card (S x) * prod (card \<circ> S) I" using ih by simp
  also have "\<dots> = prod (card \<circ> S) ({x} \<union> I)" using i.hyps by auto
  finally show ?case by simp
qed

subsection "Complementary family of subgroups"

text \<open>The notion of a complementary family is introduced. Note that the subgroups are complementary
not only to the other subgroups but to the product of the other subgroups.\<close>

definition (in group) compl_fam :: "('c \<Rightarrow> 'a set) \<Rightarrow> 'c set \<Rightarrow> bool" where
  "compl_fam S I = (\<forall>i \<in> I. complementary (S i) (IDirProds G S (I - {i})))"

text \<open>Some lemmas about \<open>compl_fam\<close>.\<close>

lemma (in group) compl_fam_empty[simp]: "compl_fam S {}"
  unfolding compl_fam_def by simp

lemma (in group) compl_fam_cong:
  assumes "compl_fam (f \<circ> g) A" "inj_on g A"
  shows "compl_fam f (g ` A)"
proof -
  have "((f \<circ> g) ` (A - {i})) =  (f ` (g ` A - {g i}))" if "i \<in> A" for i
    using assms that unfolding inj_on_def comp_def by blast
  thus ?thesis using assms unfolding compl_fam_def IDirProds_def complementary_def by simp
qed

text \<open>We now connect \<open>compl_fam\<close> with \<open>generate\<close> as this will be its main application.\<close>

lemma (in comm_group) compl_fam_imp_generate_inj:
  assumes "gs \<subseteq> carrier G" "compl_fam (\<lambda>g. generate G {g}) gs"
  shows "inj_on (\<lambda>g. generate G {g}) gs"
proof(rule, rule ccontr)
  fix x y
  assume xy: "x \<in> gs" "y \<in> gs" "x \<noteq> y"
  have gen: "generate G (\<Union>g\<in>gs - {y}. generate G {g}) = generate G (gs - {y})"
    by (intro generate_idem_Un, use assms in blast)
  assume g: "generate G {x} = generate G {y}"
  with xy have "generate G {y} \<subseteq> generate G (gs - {y})" using mono_generate[of "{x}" "gs - {y}"] by auto
  with xy have gyo: "generate G {y} = {\<one>}" using assms(2) generate.one gen
    unfolding compl_fam_def complementary_def IDirProds_def by blast
  hence yo: "y = \<one>" using generate_singleton_one by simp
  from gyo g generate_singleton_one have xo: "x = \<one>" by simp
  from xy yo xo show False by blast
qed

lemma (in comm_group) compl_fam_generate_subset:
  assumes "compl_fam (\<lambda>g. generate G {g}) gs"
          "gs \<subseteq> carrier G" "A \<subseteq> gs"
  shows "compl_fam (\<lambda>g. generate G {g}) A"
proof(unfold compl_fam_def complementary_def IDirProds_def, subst generate_idem_Un)
  show "\<And>i. A - {i} \<subseteq> carrier G" using assms by blast
  have "generate G {i} \<inter> generate G (A - {i}) = {\<one>}" if "i \<in> A" for i
  proof -
    have "\<one> \<in> generate G {i} \<inter> generate G (A - {i})" using generate.one by blast
    moreover have "generate G (A - {i}) \<subseteq> generate G (gs - {i})"
      by (intro mono_generate, use assms in fast)
    moreover have "generate G {i} \<inter> generate G (gs - {i}) = {\<one>}"
      using assms that generate_idem_Un[of "gs - {i}"]
      unfolding compl_fam_def IDirProds_def complementary_def by blast
    ultimately show ?thesis by blast
  qed
  thus "\<forall>i\<in>A. generate G {i} \<inter> generate G (A - {i}) = {\<one>}" by auto
qed

subsection \<open>\<open>is_idirprod\<close>\<close>

text \<open>In order to identify a group as the internal direct product of a family of subgroups, they all
have to be normal subgroups, complementary to the product of the rest of the subgroups and generate
all of the group - this is captured in the definition of \<open>is_idirprod\<close>.\<close>

definition (in group) is_idirprod :: "'a set \<Rightarrow> ('c \<Rightarrow> 'a set) \<Rightarrow> 'c set \<Rightarrow> bool" where
  "is_idirprod A S I = ((\<forall>i \<in> I. S i \<lhd> G) \<and> A = IDirProds G S I \<and> compl_fam S I)"

text \<open>Very basic lemmas about \<open>is_idirprod\<close>.\<close>

lemma (in comm_group) is_idirprod_subgroup_suffices:
  assumes "A = IDirProds G S I" "\<forall>i\<in>I. subgroup (S i) G" "compl_fam S I"
  shows "is_idirprod A S I"
  unfolding is_idirprod_def using assms subgroup_imp_normal by blast

lemma (in comm_group) is_idirprod_generate:
  assumes "A = generate G gs" "gs \<subseteq> carrier G" "compl_fam (\<lambda>g. generate G {g}) gs"
  shows "is_idirprod A (\<lambda>g. generate G {g}) gs"
proof(intro is_idirprod_subgroup_suffices)
  show "A = IDirProds G (\<lambda>g. generate G {g}) gs"
    using assms generate_idem_Un[OF assms(2)] unfolding IDirProds_def by argo
  show "\<forall>i\<in>gs. subgroup (generate G {i}) G" using assms generate_is_subgroup by auto
  show "compl_fam (\<lambda>g. generate G {g}) gs" by fact
qed

lemma (in comm_group) is_idirprod_imp_compl_fam[simp]:
  assumes "is_idirprod A S I"
  shows "compl_fam S I"
  using assms unfolding is_idirprod_def by blast

lemma (in comm_group) is_idirprod_generate_imp_generate[simp]:
  assumes "is_idirprod A (\<lambda>g. generate G {g}) gs"
  shows "A = generate G gs"
proof -
  have "gs \<subseteq> carrier G"
  proof
    show "g \<in> carrier G" if "g \<in> gs" for g
    proof -
      interpret g: subgroup "generate G {g}" G
        using assms that normal_imp_subgroup unfolding is_idirprod_def by blast
      show ?thesis using g.subset generate.incl by fast
    qed
  qed
  thus ?thesis using assms generate_idem_Un unfolding is_idirprod_def IDirProds_def by presburger
qed

end


theory Girth_Chromatic_Misc
imports
  Main
  "HOL-Library.Extended_Real"
begin

section \<open>Auxilliary lemmas and setup\<close>

text \<open>
  This section contains facts about general concepts which are not directly
  connected to the proof of the Chromatic-Girth theorem. At some point in time,
  most of them could be moved to the Isabelle base library.

  Also, a little bit of setup happens.
\<close>

subsection \<open>Numbers\<close>

lemma enat_in_Inf:
  fixes S :: "enat set"
  assumes "Inf S \<noteq> top"
  shows "Inf S \<in> S"
proof (rule ccontr)
  assume A: "~?thesis"

  obtain n where Inf_conv: "Inf S = enat n" using assms by (auto simp: top_enat_def)
  { fix s assume "s \<in> S"
    then have "Inf S \<le> s" by (rule complete_lattice_class.Inf_lower)
    moreover have "Inf S \<noteq> s" using A \<open>s \<in> S\<close> by auto
    ultimately have "Inf S < s" by simp
    with Inf_conv have "enat (Suc n) \<le> s" by (cases s) auto
  }
  then have "enat (Suc n) \<le> Inf S" by (simp add: le_Inf_iff)
  with Inf_conv show False by auto
qed

lemma enat_in_INF:
  fixes f :: "'a \<Rightarrow> enat"
  assumes "(INF x\<in> S. f x) \<noteq> top"
  obtains x where "x \<in> S" and "(INF x\<in> S. f x) = f x"
proof -
  from assms have "(INF x\<in> S. f x) \<in> f ` S"
    using enat_in_Inf [of "f ` S"] by auto
  then obtain x where "x \<in> S" "(INF x\<in> S. f x) = f x" by auto
  then show ?thesis ..
qed

lemma enat_less_INF_I:
  fixes f :: "'a \<Rightarrow> enat"
  assumes not_inf: "x \<noteq> \<infinity>" and less: "\<And>y. y \<in> S \<Longrightarrow> x < f y"
  shows "x < (INF y\<in>S. f y)"
  using assms by (auto simp: Suc_ile_eq[symmetric] INF_greatest)

lemma enat_le_Sup_iff:
  "enat k \<le> Sup M \<longleftrightarrow> k = 0 \<or> (\<exists>m \<in> M. enat k \<le> m)" (is "?L \<longleftrightarrow> ?R")
proof cases
  assume "k = 0" then show ?thesis by (auto simp: enat_0)
next
  assume "k \<noteq> 0"
  show ?thesis
  proof
    assume ?L
    then have "\<lbrakk>enat k \<le> (if finite M then Max M else \<infinity>); M \<noteq> {}\<rbrakk> \<Longrightarrow> \<exists>m\<in>M. enat k \<le> m"
      by (metis Max_in Sup_enat_def finite_enat_bounded linorder_linear)
    with \<open>k \<noteq> 0\<close> and \<open>?L\<close> show ?R
      unfolding Sup_enat_def
      by (cases "M={}") (auto simp add: enat_0[symmetric])
  next
    assume ?R then show ?L
      by (auto simp: enat_0 intro: complete_lattice_class.Sup_upper2)
  qed
qed

lemma enat_neq_zero_cancel_iff[simp]:
  "0 \<noteq> enat n \<longleftrightarrow> 0 \<noteq> n"
  "enat n \<noteq> 0 \<longleftrightarrow> n \<noteq> 0"
by (auto simp: enat_0[symmetric])

lemma natceiling_lessD: "nat(ceiling x) < n \<Longrightarrow> x < real n"
by linarith

lemma le_natceiling_iff:
  fixes n :: nat and r :: real
  shows "n \<le> r \<Longrightarrow> n \<le> nat(ceiling r)"
by linarith

lemma natceiling_le_iff:
  fixes n :: nat and r :: real
  shows "r \<le> n \<Longrightarrow> nat(ceiling r) \<le> n"
by linarith

lemma dist_real_noabs_less:
  fixes a b c :: real assumes "dist a b < c" shows "a - b < c"
using assms by (simp add: dist_real_def)

lemma n_choose_2_nat:
  fixes n :: nat shows "(n choose 2) = (n * (n - 1)) div 2"
proof -
  show ?thesis
  proof (cases "2 \<le> n")
    case True
    then obtain m where "n = Suc (Suc m)"
      by (metis add_Suc le_Suc_ex numeral_2_eq_2)
    moreover have "(n choose 2) = (fact n div fact (n - 2)) div 2"
      using \<open>2 \<le> n\<close> by (simp add: binomial_altdef_nat
        div_mult2_eq[symmetric] mult.commute numeral_2_eq_2)
    ultimately show ?thesis by (simp add: algebra_simps)
  qed (auto simp: binomial_eq_0)
qed

lemma powr_less_one:
  fixes x::real
  assumes "1 < x" "y < 0"
  shows "x powr y < 1"
using assms less_log_iff by force

lemma powr_le_one_le: "\<And>x y::real. 0 < x \<Longrightarrow> x \<le> 1 \<Longrightarrow> 1 \<le> y \<Longrightarrow> x powr y \<le> x"
proof -
  fix x y :: real
  assume "0 < x" "x \<le> 1" "1 \<le> y"
  have "x powr y = (1 / (1 / x)) powr y" using \<open>0 < x\<close> by (simp add: field_simps)
  also have "\<dots> = 1 / (1 / x) powr y" using \<open>0 < x\<close> by (simp add: powr_divide)
  also have "\<dots> \<le> 1 / (1 / x) powr 1" proof -
    have "1 \<le> 1 / x" using \<open>0 < x\<close> \<open>x \<le> 1\<close> by (auto simp: field_simps)
    then have "(1 / x) powr 1  \<le> (1 / x) powr y" using \<open>0 < x\<close>
      using \<open>1 \<le> y\<close> by ( simp only: powr_mono)
    then show ?thesis
      by (metis \<open>1 \<le> 1 / x\<close> \<open>1 \<le> y\<close> neg_le_iff_le powr_minus_divide powr_mono)
  qed
  also have "\<dots> \<le> x" using \<open>0 < x\<close> by (auto simp: field_simps)
  finally show "?thesis x y" .
qed

subsection \<open>Lists and Sets\<close>

lemma list_set_tl: "x \<in> set (tl xs) \<Longrightarrow> x \<in> set xs"
by (cases xs) auto

lemma list_exhaust3:
  obtains "xs = []" | x where "xs = [x]" | x y ys where "xs = x # y # ys"
by (metis list.exhaust)

lemma card_Ex_subset:
  "k \<le> card M \<Longrightarrow> \<exists>N. N \<subseteq> M \<and> card N = k"
by (induct rule: inc_induct) (auto simp: card_Suc_eq)

subsection \<open>Limits and eventually\<close>

text \<open>
  We employ filters and the @{term eventually} predicate to deal with the
  @{term "\<exists>N. \<forall>n\<ge>N. P n"} cases. To make this more convenient, introduce
  a shorter syntax.
\<close>

abbreviation evseq :: "(nat \<Rightarrow> bool) \<Rightarrow> bool" (binder "\<forall>\<^sup>\<infinity>" 10) where
  "evseq P \<equiv> eventually P sequentially"

lemma eventually_le_le:
  fixes P :: "'a => ('b :: preorder)"
  assumes "eventually (\<lambda>x. P x \<le> Q x) net"
  assumes "eventually (\<lambda>x. Q x \<le> R  x) net"
  shows "eventually (\<lambda>x. P x \<le> R x) net"
using assms by eventually_elim (rule order_trans)

lemma LIMSEQ_neg_powr:
  assumes s: "s < 0"
  shows "(%x. (real x) powr s) \<longlonglongrightarrow> 0"
by (rule tendsto_neg_powr[OF assms filterlim_real_sequentially])

lemma LIMSEQ_inv_powr:
  assumes "0 < c" "0 < d"
  shows "(\<lambda>n :: nat. (c / n) powr d) \<longlonglongrightarrow> 0"
proof (rule tendsto_zero_powrI)
  from \<open>0 < c\<close> have "\<And>x. 0 < x \<Longrightarrow> 0 < c / x" by simp
  then show "\<forall>\<^sup>\<infinity>n. 0 \<le> c / real n"
    using assms(1) by auto
  show "(\<lambda>x. c / real x) \<longlonglongrightarrow> 0"
    by (intro tendsto_divide_0[OF tendsto_const] filterlim_at_top_imp_at_infinity
              filterlim_real_sequentially tendsto_divide_0)
  show "0 < d" by (rule assms)
  show "(\<lambda>x. d) \<longlonglongrightarrow> d" by auto
qed

end