theory consistency_analysis
  imports embedding
begin
nitpick_params[assms=true, user_axioms=true, show_all, expect=genuine, format = 3]

section \<open>Consistency Analysis\<close>

subsection \<open>Consistency Analysis (classical)\<close>

abbreviation "consistency \<equiv> \<forall>\<phi>. \<sim>[\<^bold>\<turnstile>  \<^bold>\<sim>\<phi> \<^bold>\<and> \<phi>]"        (* (1) *)
abbreviation "star_consistency \<equiv> \<forall>\<phi>. \<sim>[\<^bold>\<turnstile> \<^bold>\<sim>\<phi> \<^bold>\<and> \<^bold>\<box>\<phi>]"  (* (2) *)
abbreviation "S_consistency \<equiv> \<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<box>\<phi>] \<longrightarrow> [\<^bold>\<turnstile> \<phi>]"  (* (3) *)
abbreviation "P_consistency_a \<equiv>  \<sim>[\<^bold>\<turnstile> \<^bold>\<box>\<^bold>\<bottom>]"            (* (4.a) *)
abbreviation "P_consistency_b \<equiv>  [\<^bold>\<turnstile> \<^bold>\<sim>\<^bold>\<box>\<^bold>\<bottom>]"            (* (4.b) *)

(* (i) *)
(* (1) is a tautology *)
lemma consistency by simp

(* (ii) *)
(* (2) and (4.a) are equivalent *)
lemma "star_consistency \<longleftrightarrow> P_consistency_a" by blast

(* (iii) *)
(* (3) implies (2) *)
lemma "S_consistency \<longrightarrow> star_consistency" by blast
lemma "star_consistency \<longrightarrow> S_consistency" nitpick oops (*countermodel found*)
(* (3) implies (4.a) *)
lemma "S_consistency \<longrightarrow> P_consistency_a" by blast
lemma "P_consistency_a \<longrightarrow> S_consistency" nitpick oops (*countermodel found*)

(* (iv) *)
(* (4.b) implies (4.a) *)
lemma "P_consistency_b \<longrightarrow> P_consistency_a" by simp
lemma "P_consistency_a \<longrightarrow> P_consistency_b" nitpick oops (*countermodel found*)
(* (4.b) implies (2) *)
lemma "P_consistency_b \<longrightarrow> star_consistency" by blast
lemma "star_consistency \<longrightarrow> P_consistency_b" nitpick oops (*countermodel found*)

(* (v) *)
(* (3) and (4.b) are incomparable *)
lemma "S_consistency \<longrightarrow> P_consistency_b" nitpick oops (*countermodel found*)
lemma "P_consistency_b \<longrightarrow> S_consistency" nitpick oops (*countermodel found*)

subsection \<open>Consistency Analysis (paraconsistent)\<close>

abbreviation neg :: "wo\<Rightarrow>wo" ("\<^bold>\<not>_" [54] 55) where "\<^bold>\<not>\<phi> \<equiv> \<^bold>\<not>\<^sup>p\<phi>" (* negation is paraconsistent *)
abbreviation circ :: "wo\<Rightarrow>wo" ("\<^bold>\<circ>_" [54] 55) where "\<^bold>\<circ>\<phi> \<equiv> \<^bold>\<circ>\<^sup>m\<^sup>b\<^sup>c\<phi>" (* logic is mbC *)

abbreviation "consistency_par \<equiv> \<forall>\<phi>. \<sim>[\<^bold>\<turnstile>  \<^bold>\<not>\<phi> \<^bold>\<and> \<phi>]"        (* (1) *)
abbreviation "star_consistency_par \<equiv> \<forall>\<phi>. \<sim>[\<^bold>\<turnstile> \<^bold>\<not>\<phi> \<^bold>\<and> \<^bold>\<box>\<phi>]"   (* (2) *)
abbreviation "P_consistency_b_par \<equiv>  [\<^bold>\<turnstile> \<^bold>\<not>\<^bold>\<box>\<^bold>\<bottom>]"             (* (4.b) *)
abbreviation "circ_consistency \<equiv> \<forall>\<phi>. [\<^bold>\<turnstile> \<^bold>\<circ>\<phi>]"               (* (5) *)

(* (i) *)
(* (1) is not a tautology *)
lemma consistency_par nitpick oops (*countermodel found*)

(* (ii) *)
(* (2) implies (1) *)
lemma "star_consistency_par \<longrightarrow> consistency_par" by blast
lemma "consistency_par \<longrightarrow> star_consistency_par" nitpick oops (*countermodel found*)

(* (iii) *)
(* (5) implies (1) *)
lemma "circ_consistency \<longrightarrow> consistency_par" by simp
lemma "consistency_par \<longrightarrow> circ_consistency" nitpick oops (*countermodel found*)

(* (iv) *)
(* (2) implies (4.a) *)
lemma "star_consistency_par \<longrightarrow> P_consistency_a" by blast
lemma "P_consistency_a \<longrightarrow> star_consistency_par" nitpick oops (*countermodel found*)

(* (v) *)
(* (3) implies (4.a) *)
lemma "S_consistency \<longrightarrow> P_consistency_a" by blast
lemma "P_consistency_a \<longrightarrow> S_consistency" nitpick oops (*countermodel found*)

(* (vi) *)
(* (2) and (3) are incomparable *)
lemma "star_consistency_par \<longrightarrow> S_consistency" nitpick oops (*countermodel found*)
lemma "S_consistency \<longrightarrow> star_consistency_par" nitpick oops (*countermodel found*)
(* (3) and (1) are incomparable *)
lemma "S_consistency \<longrightarrow> consistency_par" nitpick oops (*countermodel found*)
lemma "consistency_par \<longrightarrow> S_consistency" nitpick oops (*countermodel found*)
(* (4.a) and (1) are incomparable *)
lemma "P_consistency_a \<longrightarrow> consistency_par" nitpick oops (*countermodel found*)
lemma "consistency_par \<longrightarrow> P_consistency_a" nitpick oops (*countermodel found*)

(* (vii) *)
(* (4.b) and (1) are incomparable *)
lemma "P_consistency_b_par \<longrightarrow> consistency_par" nitpick oops (*countermodel found*)
lemma "consistency_par \<longrightarrow> P_consistency_b_par" nitpick oops (*countermodel found*)
(* (4.b) and (2) are incomparable *)
lemma "P_consistency_b_par \<longrightarrow> star_consistency_par" nitpick oops (*countermodel found*)
lemma "star_consistency_par \<longrightarrow> P_consistency_b_par" nitpick oops (*countermodel found*)
(* (4.b) and (3) are incomparable *)
lemma "P_consistency_b_par \<longrightarrow> S_consistency" nitpick oops (*countermodel found*)
lemma "S_consistency \<longrightarrow> P_consistency_b_par" nitpick oops (*countermodel found*)
(* (4.b) and (4.a) are incomparable *)
lemma "P_consistency_b_par \<longrightarrow> P_consistency_a" nitpick oops (*countermodel found*)
lemma "P_consistency_a \<longrightarrow> P_consistency_b_par" nitpick oops (*countermodel found*)

(* (viii) *)
(* (5) and (2) are incomparable *)
lemma "circ_consistency \<longrightarrow> star_consistency_par" nitpick oops (*countermodel found*)
lemma "star_consistency_par \<longrightarrow> circ_consistency" nitpick oops (*countermodel found*)
(* (5) and (3) are incomparable *)
lemma "circ_consistency \<longrightarrow> S_consistency" nitpick oops (*countermodel found*)
lemma "S_consistency \<longrightarrow> circ_consistency" nitpick oops (*countermodel found*)
(* (5) and (4.a) are incomparable *)
lemma "circ_consistency \<longrightarrow> P_consistency_a" nitpick oops (*countermodel found*)
lemma "P_consistency_a \<longrightarrow> circ_consistency" nitpick oops (*countermodel found*)
(* (5) and (4.b) are incomparable *)
lemma "circ_consistency \<longrightarrow> P_consistency_b_par" nitpick oops (*countermodel found*)
lemma "P_consistency_b_par \<longrightarrow> circ_consistency" nitpick oops (*countermodel found*)

end


section "Splay Tree"

theory Splay_Tree
imports
  "HOL-Library.Tree"
  "HOL-Data_Structures.Set_Specs"
  "HOL-Data_Structures.Cmp"
begin

declare sorted_wrt.simps(2)[simp del]

text\<open>Splay trees were invented by Sleator and Tarjan~\cite{SleatorT-JACM85}.\<close>

subsection "Function \<open>splay\<close>"

function splay :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"splay x Leaf = Leaf" |
"splay x (Node A x B) = Node A x B" |
"x<b \<Longrightarrow> splay x (Node (Node A x B) b C) = Node A x (Node B b C)" |
"x<b \<Longrightarrow> splay x (Node Leaf b A) = Node Leaf b A" |
"x<a \<Longrightarrow> x<b \<Longrightarrow> splay x (Node (Node Leaf a A) b B) = Node Leaf a (Node A b B)" |
"x<b \<Longrightarrow> x<c \<Longrightarrow> AB \<noteq> Leaf \<Longrightarrow>
 splay x (Node (Node AB b C) c D) =
 (case splay x AB of Node A a B \<Rightarrow> Node A a (Node B b (Node C c D)))" |
"a<x \<Longrightarrow> x<b \<Longrightarrow> splay x (Node (Node A a Leaf) b B) = Node A a (Node Leaf b B)" |
"a<x \<Longrightarrow> x<c \<Longrightarrow> BC \<noteq> Leaf \<Longrightarrow>
 splay x (Node (Node A a BC) c D) =
 (case splay x BC of Node B b C \<Rightarrow> Node (Node A a B) b (Node C c D))" |
"a<x \<Longrightarrow> splay x (Node A a (Node B x C)) = Node (Node A a B) x C" |
"a<x \<Longrightarrow> splay x (Node A a Leaf) = Node A a Leaf" |
"a<x \<Longrightarrow> x<c \<Longrightarrow> BC \<noteq> Leaf \<Longrightarrow>
 splay x (Node A a (Node BC c D)) =
 (case splay x BC of Node B b C \<Rightarrow> Node (Node A a B) b (Node C c D))" |
"a<x \<Longrightarrow> x<b \<Longrightarrow> splay x (Node A a (Node Leaf b C)) = Node (Node A a Leaf) b C" |
"a<x \<Longrightarrow> b<x \<Longrightarrow> splay x (Node A a (Node B b Leaf)) = Node (Node A a B) b Leaf" |
"a<x \<Longrightarrow> b<x \<Longrightarrow> CD \<noteq> Leaf \<Longrightarrow>
 splay x (Node A a (Node B b CD)) =
 (case splay x CD of Node C c D \<Rightarrow> Node (Node (Node A a B) b C) c D)"
apply(atomize_elim)
apply(auto)
(* 1 subgoal *)
apply (subst (asm) neq_Leaf_iff)
apply(auto)
apply (metis tree.exhaust le_less_linear less_linear)+
done

termination splay
by lexicographic_order

lemma splay_code: "splay x (Node AB b CD) =
  (case cmp x b of
   EQ \<Rightarrow> Node AB b CD |
   LT \<Rightarrow> (case AB of
          Leaf \<Rightarrow> Node AB b CD |
          Node A a B \<Rightarrow>
            (case cmp x a of EQ \<Rightarrow> Node A a (Node B b CD) |
             LT \<Rightarrow>  if A = Leaf then Node A a (Node B b CD)
                       else case splay x A of
                         Node A\<^sub>1 a' A\<^sub>2 \<Rightarrow> Node A\<^sub>1 a' (Node A\<^sub>2 a (Node B b CD)) |
             GT \<Rightarrow> if B = Leaf then Node A a (Node B b CD)
                       else case splay x B of
                         Node B\<^sub>1 b' B\<^sub>2 \<Rightarrow> Node (Node A a B\<^sub>1) b' (Node B\<^sub>2 b CD))) |
   GT \<Rightarrow> (case CD of
          Leaf \<Rightarrow> Node AB b CD |
          Node C c D \<Rightarrow>
            (case cmp x c of EQ \<Rightarrow> Node (Node AB b C) c D |
             LT \<Rightarrow> if C = Leaf then Node (Node AB b C) c D
                       else case splay x C of
                         Node C\<^sub>1 c' C\<^sub>2 \<Rightarrow> Node (Node AB b C\<^sub>1) c' (Node C\<^sub>2 c D) |
             GT \<Rightarrow> if D=Leaf then Node (Node AB b C) c D
                       else case splay x D of
                         Node D\<^sub>1 d D\<^sub>2 \<Rightarrow> Node (Node (Node AB b C) c D\<^sub>1) d D\<^sub>2)))"
by(auto split!: tree.split)

definition is_root :: "'a \<Rightarrow> 'a tree \<Rightarrow> bool" where
"is_root x t = (case t of Leaf \<Rightarrow> False | Node l a r \<Rightarrow> x = a)"

definition "isin t x = is_root x (splay x t)"

definition empty :: "'a tree" where
"empty = Leaf"

hide_const (open) insert

fun insert :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"insert x t =
  (if t = Leaf then Node Leaf x Leaf
   else case splay x t of
     Node l a r \<Rightarrow>
      case cmp x a of
        EQ \<Rightarrow> Node l a r |
        LT \<Rightarrow> Node l x (Node Leaf a r) |
        GT \<Rightarrow> Node (Node l a Leaf) x r)"

fun splay_max :: "'a tree \<Rightarrow> 'a tree" where
"splay_max Leaf = Leaf" |
"splay_max (Node A a Leaf) = Node A a Leaf" |
"splay_max (Node A a (Node B b CD)) =
  (if CD = Leaf then Node (Node A a B) b Leaf
   else case splay_max CD of
     Node C c D \<Rightarrow> Node (Node (Node A a B) b C) c D)"

lemma splay_max_code: "splay_max t = (case t of
  Leaf \<Rightarrow> t |
  Node la a ra \<Rightarrow> (case ra of
    Leaf \<Rightarrow> t |
    Node lb b rb \<Rightarrow>
      (if rb=Leaf then Node (Node la a lb) b rb
       else case splay_max rb of
              Node lc c rc \<Rightarrow> Node (Node (Node la a lb) b lc) c rc)))"
by(auto simp: neq_Leaf_iff split: tree.split)

definition delete :: "'a::linorder \<Rightarrow> 'a tree \<Rightarrow> 'a tree" where
"delete x t =
  (if t = Leaf then Leaf
   else case splay x t of Node l a r \<Rightarrow>
     if x \<noteq> a then Node l a r
     else if l = Leaf then r else case splay_max l of Node l' m r' \<Rightarrow> Node l' m r)"

subsection "Functional Correctness Proofs I"

text \<open>This subsection follows the automated method by Nipkow \cite{Nipkow-ITP16}.\<close>

lemma splay_Leaf_iff[simp]: "(splay a t = Leaf) = (t = Leaf)"
by(induction a t rule: splay.induct) (auto split: tree.splits)

lemma splay_max_Leaf_iff[simp]: "(splay_max t = Leaf) = (t = Leaf)"
by(induction t rule: splay_max.induct)(auto split: tree.splits)

subsubsection "Verification of @{const isin}"

lemma splay_elemsD:
  "splay x t = Node l a r \<Longrightarrow> sorted(inorder t) \<Longrightarrow>
  x \<in> set (inorder t) \<longleftrightarrow> x=a"
by(induction x t arbitrary: l a r rule: splay.induct)
  (auto simp: isin_simps ball_Un split: tree.splits)

lemma isin_set: "sorted(inorder t) \<Longrightarrow> isin t x = (x \<in> set (inorder t))"
by (auto simp: isin_def is_root_def dest: splay_elemsD split: tree.splits)

subsubsection "Verification of @{const insert}"

lemma inorder_splay: "inorder(splay x t) = inorder t"
by(induction x t rule: splay.induct)
  (auto simp: neq_Leaf_iff split: tree.split)

lemma sorted_splay:
  "sorted(inorder t) \<Longrightarrow> splay x t = Node l a r \<Longrightarrow>
  sorted(inorder l @ x # inorder r)"
unfolding inorder_splay[of x t, symmetric]
by(induction x t arbitrary: l a r rule: splay.induct)
  (auto simp: sorted_lems sorted_Cons_le sorted_snoc_le split: tree.splits)

lemma inorder_insert:
  "sorted(inorder t) \<Longrightarrow> inorder(insert x t) = ins_list x (inorder t)"
using inorder_splay[of x t, symmetric] sorted_splay[of t x]
by(auto simp: ins_list_simps ins_list_Cons ins_list_snoc neq_Leaf_iff split: tree.split)

subsubsection "Verification of @{const delete}"

lemma inorder_splay_maxD:
  "splay_max t = Node l a r \<Longrightarrow> sorted(inorder t) \<Longrightarrow>
  inorder l @ [a] = inorder t \<and> r = Leaf"
by(induction t arbitrary: l a r rule: splay_max.induct)
  (auto simp: sorted_lems split: tree.splits if_splits)

lemma inorder_delete:
  "sorted(inorder t) \<Longrightarrow> inorder(delete x t) = del_list x (inorder t)"
using inorder_splay[of x t, symmetric] sorted_splay[of t x]
by (auto simp: del_list_simps del_list_sorted_app delete_def
  del_list_notin_Cons inorder_splay_maxD split: tree.splits)

subsubsection "Overall Correctness"

interpretation splay: Set_by_Ordered
where empty = empty and isin = isin and insert = insert
and delete = delete and inorder = inorder and inv = "\<lambda>_. True"
proof (standard, goal_cases)
  case 2 thus ?case by(simp add: isin_set)
next
  case 3 thus ?case by(simp add: inorder_insert del: insert.simps)
next
  case 4 thus ?case by(simp add: inorder_delete)
qed (auto simp: empty_def)

subsection "Functional Correctness Proofs II"

text \<open>This subsection follows the traditional approach, is less automated
and is retained more for historic reasons.\<close>

lemma size_splay[simp]: "size (splay a t) = size t"
apply(induction a t rule: splay.induct)
apply auto
 apply(force split: tree.split)+
done

lemma size_if_splay: "splay a t = Node l u r \<Longrightarrow> size t = size l + size r + 1"
by (metis One_nat_def size_splay tree.size(4))

lemma splay_not_Leaf: "t \<noteq> Leaf \<Longrightarrow> \<exists>l x r. splay a t = Node l x r"
by (metis neq_Leaf_iff splay_Leaf_iff)

lemma set_splay: "set_tree(splay a t) = set_tree t"
proof(induction a t rule: splay.induct)
  case (6 a)
  with splay_not_Leaf[OF 6(3), of a] show ?case by(fastforce)
next
  case (8 _ a)
  with splay_not_Leaf[OF 8(3), of a] show ?case by(fastforce)
next
  case (11 _ a)
  with splay_not_Leaf[OF 11(3), of a] show ?case by(fastforce)
next
  case (14 _ a)
  with splay_not_Leaf[OF 14(3), of a] show ?case by(fastforce)
qed auto

lemma splay_bstL: "bst t \<Longrightarrow> splay a t = Node l e r \<Longrightarrow> x \<in> set_tree l \<Longrightarrow> x < a"
apply(induction a t arbitrary: l x r rule: splay.induct)
apply (auto split: tree.splits)
apply auto
done

lemma splay_bstR: "bst t \<Longrightarrow> splay a t = Node l e r \<Longrightarrow> x \<in> set_tree r \<Longrightarrow> a < x"
apply(induction a t arbitrary: l e x r rule: splay.induct)
apply auto
apply (fastforce split!: tree.splits)+
done

lemma bst_splay: "bst t \<Longrightarrow> bst(splay a t)"
proof(induction a t rule: splay.induct)
  case (6 a _ _ ll)
  with splay_not_Leaf[OF 6(3), of a] set_splay[of a ll,symmetric]
  show ?case by (fastforce)
next
  case (8 _ a _ t)
  with splay_not_Leaf[OF 8(3), of a] set_splay[of a t,symmetric]
  show ?case by fastforce
next
  case (11 _ a _ t)
  with splay_not_Leaf[OF 11(3), of a] set_splay[of a t,symmetric]
  show ?case by fastforce
next
  case (14 _ a _ t)
  with splay_not_Leaf[OF 14(3), of a] set_splay[of a t,symmetric]
  show ?case by fastforce
qed auto

subsubsection "Verification of Is-in Test"

text\<open>To test if an element \<open>a\<close> is in \<open>t\<close>, first perform
@{term"splay a t"}, then check if the root is \<open>a\<close>. One could
put this into one function that returns both a new tree and the test result.\<close>

lemma is_root_splay: "bst t \<Longrightarrow> is_root a (splay a t) \<longleftrightarrow> a \<in> set_tree t"
by(auto simp add: is_root_def splay_to_root split: tree.split)

subsubsection "Verification of @{const insert}"

lemma set_insert: "set_tree(insert a t) = Set.insert a (set_tree t)"
apply(cases t)
 apply simp
using set_splay[of a t]
by(simp split: tree.split) fastforce

lemma bst_insert: "bst t \<Longrightarrow> bst(insert a t)"
apply(cases t)
 apply simp
using bst_splay[of t a] splay_bstL[of t a] splay_bstR[of t a]
by(auto simp: ball_Un split: tree.split)

subsubsection "Verification of \<open>splay_max\<close>"

lemma size_splay_max: "size(splay_max t) = size t"
apply(induction t rule: splay_max.induct)
  apply(simp)
 apply(simp)
apply(clarsimp split: tree.split)
done

lemma set_splay_max: "set_tree(splay_max t) = set_tree t"
apply(induction t rule: splay_max.induct)
   apply(simp)
  apply(simp)
apply(force split: tree.split)
done

lemma bst_splay_max: "bst t \<Longrightarrow> bst (splay_max t)"
proof(induction t rule: splay_max.induct)
  case (3 l b rl c rr)
  { fix rrl' d' rrr'
    have "splay_max rr = Node rrl' d' rrr'
       \<Longrightarrow> \<forall>x \<in> set_tree(Node rrl' d' rrr'). c < x"
      using "3.prems" set_splay_max[of rr]
      by (clarsimp split: tree.split simp: ball_Un)
  }
  with 3 show ?case by (fastforce split: tree.split simp: ball_Un)
qed auto

lemma splay_max_Leaf: "splay_max t = Node l a r \<Longrightarrow> r = Leaf"
by(induction t arbitrary: l rule: splay_max.induct)
  (auto split: tree.splits if_splits)

text\<open>For sanity purposes only:\<close>

lemma splay_max_eq_splay:
  "bst t \<Longrightarrow> \<forall>x \<in> set_tree t. x \<le> a \<Longrightarrow> splay_max t = splay a t"
proof(induction a t rule: splay.induct)
  case (2 a l r)
  show ?case
  proof (cases r)
    case Leaf with 2 show ?thesis by simp
  next
    case Node with 2 show ?thesis by(auto)
  qed
qed (auto simp: neq_Leaf_iff)

lemma splay_max_eq_splay_ex: assumes "bst t" shows "\<exists>a. splay_max t = splay a t"
proof(cases t)
  case Leaf thus ?thesis by simp
next
  case Node
  hence "splay_max t = splay (Max(set_tree t)) t"
    using assms by (auto simp: splay_max_eq_splay)
  thus ?thesis by auto
qed

subsubsection "Verification of @{const delete}"

lemma set_delete: assumes "bst t"
shows "set_tree (delete a t) = set_tree t - {a}"
proof(cases t)
  case Leaf thus ?thesis by(simp add: delete_def)
next
  case (Node l x r)
  obtain l' x' r' where sp[simp]: "splay a (Node l x r) = Node l' x' r'"
    by (metis neq_Leaf_iff splay_Leaf_iff)
  show ?thesis
  proof cases
    assume [simp]: "x' = a"
    show ?thesis
    proof cases
      assume "l' = Leaf"
      thus ?thesis
        using Node assms set_splay[of a "Node l x r"] bst_splay[of "Node l x r" a]
        by(simp add: delete_def split: tree.split prod.split)(fastforce)
    next
      assume "l' \<noteq> Leaf"
      moreover then obtain l'' m r'' where "splay_max l' = Node l'' m r''"
        using splay_max_Leaf_iff tree.exhaust by blast
      moreover have "a \<notin> set_tree l'"
        by (metis (no_types) Node assms less_irrefl sp splay_bstL)
      ultimately show ?thesis
        using Node assms set_splay[of a "Node l x r"] bst_splay[of "Node l x r" a]
          splay_max_Leaf[of l' l'' m r''] set_splay_max[of l']
        by(clarsimp simp: delete_def split: tree.split) auto
    qed
  next
    assume "x' \<noteq> a"
    thus ?thesis using Node assms set_splay[of a "Node l x r"] splay_to_root[OF _ sp]
      by (simp add: delete_def)
  qed
qed

lemma bst_delete: assumes "bst t" shows "bst (delete a t)"
proof(cases t)
  case Leaf thus ?thesis by(simp add: delete_def)
next
  case (Node l x r)
  obtain l' x' r' where sp[simp]: "splay a (Node l x r) = Node l' x' r'"
    by (metis neq_Leaf_iff splay_Leaf_iff)
  show ?thesis
  proof cases
    assume [simp]: "x' = a"
    show ?thesis
    proof cases
      assume "l' = Leaf"
      thus ?thesis using Node assms bst_splay[of "Node l x r" a]
        by(simp add: delete_def split: tree.split prod.split)
    next
      assume "l' \<noteq> Leaf"
      thus ?thesis
        using Node assms set_splay[of a "Node l x r"] bst_splay[of "Node l x r" a]
          bst_splay_max[of l'] set_splay_max[of l']
        by(clarsimp simp: delete_def split: tree.split)
          (metis (no_types) insertI1 less_trans)
    qed
  next
    assume "x' \<noteq> a"
    thus ?thesis using Node assms bst_splay[of "Node l x r" a]
      by(auto simp: delete_def split: tree.split prod.split)
  qed
qed

end


(*  Title:      ZF/ex/Group.thy *)

section \<open>Groups\<close>

theory Group imports ZF begin

text\<open>Based on work by Clemens Ballarin, Florian Kammueller, L C Paulson and
Markus Wenzel.\<close>

subsection \<open>Monoids\<close>

(*First, we must simulate a record declaration:
record monoid =
  carrier :: i
  mult :: "[i,i] => i" (infixl "\<cdot>\<index>" 70)
  one :: i ("\<one>\<index>")
*)

definition
  carrier :: "i => i" where
  "carrier(M) == fst(M)"

definition
  mmult :: "[i, i, i] => i" (infixl \<open>\<cdot>\<index>\<close> 70) where
  "mmult(M,x,y) == fst(snd(M)) ` <x,y>"

definition
  one :: "i => i" (\<open>\<one>\<index>\<close>) where
  "one(M) == fst(snd(snd(M)))"

definition
  update_carrier :: "[i,i] => i" where
  "update_carrier(M,A) == <A,snd(M)>"

definition
  m_inv :: "i => i => i" (\<open>inv\<index> _\<close> [81] 80) where
  "inv\<^bsub>G\<^esub> x == (THE y. y \<in> carrier(G) & y \<cdot>\<^bsub>G\<^esub> x = \<one>\<^bsub>G\<^esub> & x \<cdot>\<^bsub>G\<^esub> y = \<one>\<^bsub>G\<^esub>)"

locale monoid = fixes G (structure)
  assumes m_closed [intro, simp]:
         "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> x \<cdot> y \<in> carrier(G)"
      and m_assoc:
         "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk>
          \<Longrightarrow> (x \<cdot> y) \<cdot> z = x \<cdot> (y \<cdot> z)"
      and one_closed [intro, simp]: "\<one> \<in> carrier(G)"
      and l_one [simp]: "x \<in> carrier(G) \<Longrightarrow> \<one> \<cdot> x = x"
      and r_one [simp]: "x \<in> carrier(G) \<Longrightarrow> x \<cdot> \<one> = x"

text\<open>Simulating the record\<close>
lemma carrier_eq [simp]: "carrier(<A,Z>) = A"
  by (simp add: carrier_def)

lemma mult_eq [simp]: "mmult(<A,M,Z>, x, y) = M ` <x,y>"
  by (simp add: mmult_def)

lemma one_eq [simp]: "one(<A,M,I,Z>) = I"
  by (simp add: one_def)

lemma update_carrier_eq [simp]: "update_carrier(<A,Z>,B) = <B,Z>"
  by (simp add: update_carrier_def)

lemma carrier_update_carrier [simp]: "carrier(update_carrier(M,B)) = B"
  by (simp add: update_carrier_def)

lemma mult_update_carrier [simp]: "mmult(update_carrier(M,B),x,y) = mmult(M,x,y)"
  by (simp add: update_carrier_def mmult_def)

lemma one_update_carrier [simp]: "one(update_carrier(M,B)) = one(M)"
  by (simp add: update_carrier_def one_def)

lemma (in monoid) inv_unique:
  assumes eq: "y \<cdot> x = \<one>"  "x \<cdot> y' = \<one>"
    and G: "x \<in> carrier(G)"  "y \<in> carrier(G)"  "y' \<in> carrier(G)"
  shows "y = y'"
proof -
  from G eq have "y = y \<cdot> (x \<cdot> y')" by simp
  also from G have "... = (y \<cdot> x) \<cdot> y'" by (simp add: m_assoc)
  also from G eq have "... = y'" by simp
  finally show ?thesis .
qed

text \<open>
  A group is a monoid all of whose elements are invertible.
\<close>

locale group = monoid +
  assumes inv_ex:
     "\<And>x. x \<in> carrier(G) \<Longrightarrow> \<exists>y \<in> carrier(G). y \<cdot> x = \<one> & x \<cdot> y = \<one>"

lemma (in group) is_group [simp]: "group(G)" by (rule group_axioms)

theorem groupI:
  fixes G (structure)
  assumes m_closed [simp]:
      "\<And>x y. \<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> x \<cdot> y \<in> carrier(G)"
    and one_closed [simp]: "\<one> \<in> carrier(G)"
    and m_assoc:
      "\<And>x y z. \<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk> \<Longrightarrow>
      (x \<cdot> y) \<cdot> z = x \<cdot> (y \<cdot> z)"
    and l_one [simp]: "\<And>x. x \<in> carrier(G) \<Longrightarrow> \<one> \<cdot> x = x"
    and l_inv_ex: "\<And>x. x \<in> carrier(G) \<Longrightarrow> \<exists>y \<in> carrier(G). y \<cdot> x = \<one>"
  shows "group(G)"
proof -
  have l_cancel [simp]:
    "\<And>x y z. \<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk> \<Longrightarrow>
    (x \<cdot> y = x \<cdot> z) \<longleftrightarrow> (y = z)"
  proof
    fix x y z
    assume G: "x \<in> carrier(G)"  "y \<in> carrier(G)"  "z \<in> carrier(G)"
    {
      assume eq: "x \<cdot> y = x \<cdot> z"
      with G l_inv_ex obtain x_inv where xG: "x_inv \<in> carrier(G)"
        and l_inv: "x_inv \<cdot> x = \<one>" by fast
      from G eq xG have "(x_inv \<cdot> x) \<cdot> y = (x_inv \<cdot> x) \<cdot> z"
        by (simp add: m_assoc)
      with G show "y = z" by (simp add: l_inv)
    next
      assume eq: "y = z"
      with G show "x \<cdot> y = x \<cdot> z" by simp
    }
  qed
  have r_one:
    "\<And>x. x \<in> carrier(G) \<Longrightarrow> x \<cdot> \<one> = x"
  proof -
    fix x
    assume x: "x \<in> carrier(G)"
    with l_inv_ex obtain x_inv where xG: "x_inv \<in> carrier(G)"
      and l_inv: "x_inv \<cdot> x = \<one>" by fast
    from x xG have "x_inv \<cdot> (x \<cdot> \<one>) = x_inv \<cdot> x"
      by (simp add: m_assoc [symmetric] l_inv)
    with x xG show "x \<cdot> \<one> = x" by simp
  qed
  have inv_ex:
    "!!x. x \<in> carrier(G) ==> \<exists>y \<in> carrier(G). y \<cdot> x = \<one> & x \<cdot> y = \<one>"
  proof -
    fix x
    assume x: "x \<in> carrier(G)"
    with l_inv_ex obtain y where y: "y \<in> carrier(G)"
      and l_inv: "y \<cdot> x = \<one>" by fast
    from x y have "y \<cdot> (x \<cdot> y) = y \<cdot> \<one>"
      by (simp add: m_assoc [symmetric] l_inv r_one)
    with x y have r_inv: "x \<cdot> y = \<one>"
      by simp
    from x y show "\<exists>y \<in> carrier(G). y \<cdot> x = \<one> & x \<cdot> y = \<one>"
      by (fast intro: l_inv r_inv)
  qed
  show ?thesis
    by (blast intro: group.intro monoid.intro group_axioms.intro
                     assms r_one inv_ex)
qed

lemma (in group) inv [simp]:
  "x \<in> carrier(G) \<Longrightarrow> inv x \<in> carrier(G) & inv x \<cdot> x = \<one> & x \<cdot> inv x = \<one>"
  apply (frule inv_ex)
  apply (unfold Bex_def m_inv_def)
  apply (erule exE)
  apply (rule theI)
  apply (rule ex1I, assumption)
   apply (blast intro: inv_unique)
  done

lemma (in group) inv_closed [intro!]:
  "x \<in> carrier(G) \<Longrightarrow> inv x \<in> carrier(G)"
  by simp

lemma (in group) l_inv:
  "x \<in> carrier(G) \<Longrightarrow> inv x \<cdot> x = \<one>"
  by simp

lemma (in group) r_inv:
  "x \<in> carrier(G) \<Longrightarrow> x \<cdot> inv x = \<one>"
  by simp

subsection \<open>Cancellation Laws and Basic Properties\<close>

lemma (in group) l_cancel [simp]:
  assumes "x \<in> carrier(G)" "y \<in> carrier(G)" "z \<in> carrier(G)"
  shows "(x \<cdot> y = x \<cdot> z) \<longleftrightarrow> (y = z)"
proof
  assume eq: "x \<cdot> y = x \<cdot> z"
  hence  "(inv x \<cdot> x) \<cdot> y = (inv x \<cdot> x) \<cdot> z"
    by (simp only: m_assoc inv_closed assms)
  thus "y = z" by (simp add: assms)
next
  assume eq: "y = z"
  then show "x \<cdot> y = x \<cdot> z" by simp
qed

lemma (in group) r_cancel [simp]:
  assumes "x \<in> carrier(G)" "y \<in> carrier(G)" "z \<in> carrier(G)"
  shows "(y \<cdot> x = z \<cdot> x) \<longleftrightarrow> (y = z)"
proof
  assume eq: "y \<cdot> x = z \<cdot> x"
  then have "y \<cdot> (x \<cdot> inv x) = z \<cdot> (x \<cdot> inv x)"
    by (simp only: m_assoc [symmetric] inv_closed assms)
  thus "y = z" by (simp add: assms)
next
  assume eq: "y = z"
  thus  "y \<cdot> x = z \<cdot> x" by simp
qed

lemma (in group) inv_comm:
  assumes "x \<cdot> y = \<one>"
      and G: "x \<in> carrier(G)"  "y \<in> carrier(G)"
  shows "y \<cdot> x = \<one>"
proof -
  from G have "x \<cdot> y \<cdot> x = x \<cdot> \<one>" by (auto simp add: assms)
  with G show ?thesis by (simp del: r_one add: m_assoc)
qed

lemma (in group) inv_equality:
     "\<lbrakk>y \<cdot> x = \<one>; x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> inv x = y"
apply (simp add: m_inv_def)
apply (rule the_equality)
 apply (simp add: inv_comm [of y x])
apply (rule r_cancel [THEN iffD1], auto)
done

lemma (in group) inv_one [simp]:
  "inv \<one> = \<one>"
  by (auto intro: inv_equality)

lemma (in group) inv_inv [simp]: "x \<in> carrier(G) \<Longrightarrow> inv (inv x) = x"
  by (auto intro: inv_equality)

text\<open>This proof is by cancellation\<close>
lemma (in group) inv_mult_group:
  "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> inv (x \<cdot> y) = inv y \<cdot> inv x"
proof -
  assume G: "x \<in> carrier(G)"  "y \<in> carrier(G)"
  then have "inv (x \<cdot> y) \<cdot> (x \<cdot> y) = (inv y \<cdot> inv x) \<cdot> (x \<cdot> y)"
    by (simp add: m_assoc l_inv) (simp add: m_assoc [symmetric] l_inv)
  with G show ?thesis by (simp_all del: inv add: inv_closed)
qed

subsection \<open>Substructures\<close>

locale subgroup = fixes H and G (structure)
  assumes subset: "H \<subseteq> carrier(G)"
    and m_closed [intro, simp]: "\<lbrakk>x \<in> H; y \<in> H\<rbrakk> \<Longrightarrow> x \<cdot> y \<in> H"
    and  one_closed [simp]: "\<one> \<in> H"
    and m_inv_closed [intro,simp]: "x \<in> H \<Longrightarrow> inv x \<in> H"

lemma (in subgroup) mem_carrier [simp]:
  "x \<in> H \<Longrightarrow> x \<in> carrier(G)"
  using subset by blast

lemma subgroup_imp_subset:
  "subgroup(H,G) \<Longrightarrow> H \<subseteq> carrier(G)"
  by (rule subgroup.subset)

lemma (in subgroup) group_axiomsI [intro]:
  assumes "group(G)"
  shows "group_axioms (update_carrier(G,H))"
proof -
  interpret group G by fact
  show ?thesis by (force intro: group_axioms.intro l_inv r_inv)
qed

lemma (in subgroup) is_group [intro]:
  assumes "group(G)"
  shows "group (update_carrier(G,H))"
proof -
  interpret group G by fact
  show ?thesis
  by (rule groupI) (auto intro: m_assoc l_inv mem_carrier)
qed

text \<open>
  Since \<^term>\<open>H\<close> is nonempty, it contains some element \<^term>\<open>x\<close>.  Since
  it is closed under inverse, it contains \<open>inv x\<close>.  Since
  it is closed under product, it contains \<open>x \<cdot> inv x = \<one>\<close>.
\<close>

text \<open>
  Since \<^term>\<open>H\<close> is nonempty, it contains some element \<^term>\<open>x\<close>.  Since
  it is closed under inverse, it contains \<open>inv x\<close>.  Since
  it is closed under product, it contains \<open>x \<cdot> inv x = \<one>\<close>.
\<close>

lemma (in group) one_in_subset:
  "\<lbrakk>H \<subseteq> carrier(G); H \<noteq> 0; \<forall>a \<in> H. inv a \<in> H; \<forall>a\<in>H. \<forall>b\<in>H. a \<cdot> b \<in> H\<rbrakk>
   \<Longrightarrow> \<one> \<in> H"
by (force simp add: l_inv)

text \<open>A characterization of subgroups: closed, non-empty subset.\<close>

declare monoid.one_closed [simp] group.inv_closed [simp]
  monoid.l_one [simp] monoid.r_one [simp] group.inv_inv [simp]

lemma subgroup_nonempty:
  "~ subgroup(0,G)"
  by (blast dest: subgroup.one_closed)

subsection \<open>Direct Products\<close>

definition
  DirProdGroup :: "[i,i] => i"  (infixr \<open>\<Otimes>\<close> 80) where
  "G \<Otimes> H == <carrier(G) \<times> carrier(H),
              (\<lambda><<g,h>, <g', h'>>
                   \<in> (carrier(G) \<times> carrier(H)) \<times> (carrier(G) \<times> carrier(H)).
                <g \<cdot>\<^bsub>G\<^esub> g', h \<cdot>\<^bsub>H\<^esub> h'>),
              <\<one>\<^bsub>G\<^esub>, \<one>\<^bsub>H\<^esub>>, 0>"

lemma DirProdGroup_group:
  assumes "group(G)" and "group(H)"
  shows "group (G \<Otimes> H)"
proof -
  interpret G: group G by fact
  interpret H: group H by fact
  show ?thesis by (force intro!: groupI G.m_assoc H.m_assoc G.l_inv H.l_inv
          simp add: DirProdGroup_def)
qed

lemma carrier_DirProdGroup [simp]:
     "carrier (G \<Otimes> H) = carrier(G) \<times> carrier(H)"
  by (simp add: DirProdGroup_def)

lemma one_DirProdGroup [simp]:
     "\<one>\<^bsub>G \<Otimes> H\<^esub> = <\<one>\<^bsub>G\<^esub>, \<one>\<^bsub>H\<^esub>>"
  by (simp add: DirProdGroup_def)

lemma mult_DirProdGroup [simp]:
     "[|g \<in> carrier(G); h \<in> carrier(H); g' \<in> carrier(G); h' \<in> carrier(H)|]
      ==> <g, h> \<cdot>\<^bsub>G \<Otimes> H\<^esub> <g', h'> = <g \<cdot>\<^bsub>G\<^esub> g', h \<cdot>\<^bsub>H\<^esub> h'>"
  by (simp add: DirProdGroup_def)

lemma inv_DirProdGroup [simp]:
  assumes "group(G)" and "group(H)"
  assumes g: "g \<in> carrier(G)"
      and h: "h \<in> carrier(H)"
  shows "inv \<^bsub>G \<Otimes> H\<^esub> <g, h> = <inv\<^bsub>G\<^esub> g, inv\<^bsub>H\<^esub> h>"
  apply (rule group.inv_equality [OF DirProdGroup_group])
  apply (simp_all add: assms group.l_inv)
  done

subsection \<open>Isomorphisms\<close>

definition
  hom :: "[i,i] => i" where
  "hom(G,H) ==
    {h \<in> carrier(G) -> carrier(H).
      (\<forall>x \<in> carrier(G). \<forall>y \<in> carrier(G). h ` (x \<cdot>\<^bsub>G\<^esub> y) = (h ` x) \<cdot>\<^bsub>H\<^esub> (h ` y))}"

lemma hom_mult:
  "\<lbrakk>h \<in> hom(G,H); x \<in> carrier(G); y \<in> carrier(G)\<rbrakk>
   \<Longrightarrow> h ` (x \<cdot>\<^bsub>G\<^esub> y) = h ` x \<cdot>\<^bsub>H\<^esub> h ` y"
  by (simp add: hom_def)

lemma hom_closed:
  "\<lbrakk>h \<in> hom(G,H); x \<in> carrier(G)\<rbrakk> \<Longrightarrow> h ` x \<in> carrier(H)"
  by (auto simp add: hom_def)

lemma (in group) hom_compose:
     "\<lbrakk>h \<in> hom(G,H); i \<in> hom(H,I)\<rbrakk> \<Longrightarrow> i O h \<in> hom(G,I)"
by (force simp add: hom_def comp_fun)

lemma hom_is_fun:
  "h \<in> hom(G,H) \<Longrightarrow> h \<in> carrier(G) -> carrier(H)"
  by (simp add: hom_def)

subsection \<open>Isomorphisms\<close>

definition
  iso :: "[i,i] => i"  (infixr \<open>\<cong>\<close> 60) where
  "G \<cong> H == hom(G,H) \<inter> bij(carrier(G), carrier(H))"

lemma (in group) iso_refl: "id(carrier(G)) \<in> G \<cong> G"
  by (simp add: iso_def hom_def id_type id_bij)

lemma (in group) iso_sym:
     "h \<in> G \<cong> H \<Longrightarrow> converse(h) \<in> H \<cong> G"
apply (simp add: iso_def bij_converse_bij, clarify)
apply (subgoal_tac "converse(h) \<in> carrier(H) \<rightarrow> carrier(G)")
 prefer 2 apply (simp add: bij_converse_bij bij_is_fun)
apply (auto intro: left_inverse_eq [of _ "carrier(G)" "carrier(H)"]
            simp add: hom_def bij_is_inj right_inverse_bij)
done

lemma (in group) iso_trans:
     "\<lbrakk>h \<in> G \<cong> H; i \<in> H \<cong> I\<rbrakk> \<Longrightarrow> i O h \<in> G \<cong> I"
  by (auto simp add: iso_def hom_compose comp_bij)

lemma DirProdGroup_commute_iso:
  assumes "group(G)" and "group(H)"
  shows "(\<lambda><x,y> \<in> carrier(G \<Otimes> H). <y,x>) \<in> (G \<Otimes> H) \<cong> (H \<Otimes> G)"
proof -
  interpret group G by fact
  interpret group H by fact
  show ?thesis by (auto simp add: iso_def hom_def inj_def surj_def bij_def)
qed

lemma DirProdGroup_assoc_iso:
  assumes "group(G)" and "group(H)" and "group(I)"
  shows "(\<lambda><<x,y>,z> \<in> carrier((G \<Otimes> H) \<Otimes> I). <x,<y,z>>)
          \<in> ((G \<Otimes> H) \<Otimes> I) \<cong> (G \<Otimes> (H \<Otimes> I))"
proof -
  interpret group G by fact
  interpret group H by fact
  interpret group I by fact
  show ?thesis
    by (auto intro: lam_type simp add: iso_def hom_def inj_def surj_def bij_def)
qed

text\<open>Basis for homomorphism proofs: we assume two groups \<^term>\<open>G\<close> and
  \<^term>\<open>H\<close>, with a homomorphism \<^term>\<open>h\<close> between them\<close>
locale group_hom = G: group G + H: group H
  for G (structure) and H (structure) and h +
  assumes homh: "h \<in> hom(G,H)"
  notes hom_mult [simp] = hom_mult [OF homh]
    and hom_closed [simp] = hom_closed [OF homh]
    and hom_is_fun [simp] = hom_is_fun [OF homh]

lemma (in group_hom) one_closed [simp]:
  "h ` \<one> \<in> carrier(H)"
  by simp

lemma (in group_hom) hom_one [simp]:
  "h ` \<one> = \<one>\<^bsub>H\<^esub>"
proof -
  have "h ` \<one> \<cdot>\<^bsub>H\<^esub> \<one>\<^bsub>H\<^esub> = (h ` \<one>) \<cdot>\<^bsub>H\<^esub> (h ` \<one>)"
    by (simp add: hom_mult [symmetric] del: hom_mult)
  then show ?thesis by (simp del: H.r_one)
qed

lemma (in group_hom) inv_closed [simp]:
  "x \<in> carrier(G) \<Longrightarrow> h ` (inv x) \<in> carrier(H)"
  by simp

lemma (in group_hom) hom_inv [simp]:
  "x \<in> carrier(G) \<Longrightarrow> h ` (inv x) = inv\<^bsub>H\<^esub> (h ` x)"
proof -
  assume x: "x \<in> carrier(G)"
  then have "h ` x \<cdot>\<^bsub>H\<^esub> h ` (inv x) = \<one>\<^bsub>H\<^esub>"
    by (simp add: hom_mult [symmetric] G.r_inv del: hom_mult)
  also from x have "... = h ` x \<cdot>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h ` x)"
    by (simp add: hom_mult [symmetric] H.r_inv del: hom_mult)
  finally have "h ` x \<cdot>\<^bsub>H\<^esub> h ` (inv x) = h ` x \<cdot>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h ` x)" .
  with x show ?thesis by (simp del: H.inv)
qed

subsection \<open>Commutative Structures\<close>

text \<open>
  Naming convention: multiplicative structures that are commutative
  are called \emph{commutative}, additive structures are called
  \emph{Abelian}.
\<close>

subsection \<open>Definition\<close>

locale comm_monoid = monoid +
  assumes m_comm: "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> x \<cdot> y = y \<cdot> x"

lemma (in comm_monoid) m_lcomm:
  "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G); z \<in> carrier(G)\<rbrakk> \<Longrightarrow>
   x \<cdot> (y \<cdot> z) = y \<cdot> (x \<cdot> z)"
proof -
  assume xyz: "x \<in> carrier(G)"  "y \<in> carrier(G)"  "z \<in> carrier(G)"
  from xyz have "x \<cdot> (y \<cdot> z) = (x \<cdot> y) \<cdot> z" by (simp add: m_assoc)
  also from xyz have "... = (y \<cdot> x) \<cdot> z" by (simp add: m_comm)
  also from xyz have "... = y \<cdot> (x \<cdot> z)" by (simp add: m_assoc)
  finally show ?thesis .
qed

lemmas (in comm_monoid) m_ac = m_assoc m_comm m_lcomm

locale comm_group = comm_monoid + group

lemma (in comm_group) inv_mult:
  "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk> \<Longrightarrow> inv (x \<cdot> y) = inv x \<cdot> inv y"
  by (simp add: m_ac inv_mult_group)

lemma (in group) subgroup_self: "subgroup (carrier(G),G)"
by (simp add: subgroup_def)

lemma (in group) subgroup_imp_group:
  "subgroup(H,G) \<Longrightarrow> group (update_carrier(G,H))"
by (simp add: subgroup.is_group)

lemma (in group) subgroupI:
  assumes subset: "H \<subseteq> carrier(G)" and non_empty: "H \<noteq> 0"
    and "!!a. a \<in> H ==> inv a \<in> H"
    and "!!a b. [|a \<in> H; b \<in> H|] ==> a \<cdot> b \<in> H"
  shows "subgroup(H,G)"
proof (simp add: subgroup_def assms)
  show "\<one> \<in> H"
    by (rule one_in_subset) (auto simp only: assms)
qed

subsection \<open>Bijections of a Set, Permutation Groups, Automorphism Groups\<close>

definition
  BijGroup :: "i=>i" where
  "BijGroup(S) ==
    <bij(S,S),
     \<lambda><g,f> \<in> bij(S,S) \<times> bij(S,S). g O f,
     id(S), 0>"

subsection \<open>Bijections Form a Group\<close>

theorem group_BijGroup: "group(BijGroup(S))"
apply (simp add: BijGroup_def)
apply (rule groupI)
    apply (simp_all add: id_bij comp_bij comp_assoc)
 apply (simp add: id_bij bij_is_fun left_comp_id [of _ S S] fun_is_rel)
apply (blast intro: left_comp_inverse bij_is_inj bij_converse_bij)
done

subsection\<open>Automorphisms Form a Group\<close>

lemma Bij_Inv_mem: "\<lbrakk>f \<in> bij(S,S);  x \<in> S\<rbrakk> \<Longrightarrow> converse(f) ` x \<in> S"
by (blast intro: apply_funtype bij_is_fun bij_converse_bij)

lemma inv_BijGroup: "f \<in> bij(S,S) \<Longrightarrow> m_inv (BijGroup(S), f) = converse(f)"
apply (rule group.inv_equality)
apply (rule group_BijGroup)
apply (simp_all add: BijGroup_def bij_converse_bij
          left_comp_inverse [OF bij_is_inj])
done

lemma iso_is_bij: "h \<in> G \<cong> H ==> h \<in> bij(carrier(G), carrier(H))"
by (simp add: iso_def)

definition
  auto :: "i=>i" where
  "auto(G) == iso(G,G)"

definition
  AutoGroup :: "i=>i" where
  "AutoGroup(G) == update_carrier(BijGroup(carrier(G)), auto(G))"

lemma (in group) id_in_auto: "id(carrier(G)) \<in> auto(G)"
  by (simp add: iso_refl auto_def)

lemma (in group) subgroup_auto:
      "subgroup (auto(G)) (BijGroup (carrier(G)))"
proof (rule subgroup.intro)
  show "auto(G) \<subseteq> carrier (BijGroup (carrier(G)))"
    by (auto simp add: auto_def BijGroup_def iso_def)
next
  fix x y
  assume "x \<in> auto(G)" "y \<in> auto(G)"
  thus "x \<cdot>\<^bsub>BijGroup (carrier(G))\<^esub> y \<in> auto(G)"
    by (auto simp add: BijGroup_def auto_def iso_def bij_is_fun
                       group.hom_compose comp_bij)
next
  show "\<one>\<^bsub>BijGroup (carrier(G))\<^esub> \<in> auto(G)" by (simp add:  BijGroup_def id_in_auto)
next
  fix x
  assume "x \<in> auto(G)"
  thus "inv\<^bsub>BijGroup (carrier(G))\<^esub> x \<in> auto(G)"
    by (simp add: auto_def inv_BijGroup iso_is_bij iso_sym)
qed

theorem (in group) AutoGroup: "group (AutoGroup(G))"
by (simp add: AutoGroup_def subgroup.is_group subgroup_auto group_BijGroup)

subsection\<open>Cosets and Quotient Groups\<close>

definition
  r_coset  :: "[i,i,i] => i"  (infixl \<open>#>\<index>\<close> 60) where
  "H #>\<^bsub>G\<^esub> a == \<Union>h\<in>H. {h \<cdot>\<^bsub>G\<^esub> a}"

definition
  l_coset  :: "[i,i,i] => i"  (infixl \<open><#\<index>\<close> 60) where
  "a <#\<^bsub>G\<^esub> H == \<Union>h\<in>H. {a \<cdot>\<^bsub>G\<^esub> h}"

definition
  RCOSETS  :: "[i,i] => i"  (\<open>rcosets\<index> _\<close> [81] 80) where
  "rcosets\<^bsub>G\<^esub> H == \<Union>a\<in>carrier(G). {H #>\<^bsub>G\<^esub> a}"

definition
  set_mult :: "[i,i,i] => i"  (infixl \<open><#>\<index>\<close> 60) where
  "H <#>\<^bsub>G\<^esub> K == \<Union>h\<in>H. \<Union>k\<in>K. {h \<cdot>\<^bsub>G\<^esub> k}"

definition
  SET_INV  :: "[i,i] => i"  (\<open>set'_inv\<index> _\<close> [81] 80) where
  "set_inv\<^bsub>G\<^esub> H == \<Union>h\<in>H. {inv\<^bsub>G\<^esub> h}"

locale normal = subgroup + group +
  assumes coset_eq: "(\<forall>x \<in> carrier(G). H #> x = x <# H)"

notation
  normal  (infixl \<open>\<lhd>\<close> 60)

subsection \<open>Basic Properties of Cosets\<close>

lemma (in group) coset_mult_assoc:
     "\<lbrakk>M \<subseteq> carrier(G); g \<in> carrier(G); h \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (M #> g) #> h = M #> (g \<cdot> h)"
by (force simp add: r_coset_def m_assoc)

lemma (in group) coset_mult_one [simp]: "M \<subseteq> carrier(G) \<Longrightarrow> M #> \<one> = M"
by (force simp add: r_coset_def)

lemma (in group) solve_equation:
    "\<lbrakk>subgroup(H,G); x \<in> H; y \<in> H\<rbrakk> \<Longrightarrow> \<exists>h\<in>H. y = h \<cdot> x"
apply (rule bexI [of _ "y \<cdot> (inv x)"])
apply (auto simp add: subgroup.m_closed subgroup.m_inv_closed m_assoc
                      subgroup.subset [THEN subsetD])
done

lemma (in group) repr_independence:
     "\<lbrakk>y \<in> H #> x;  x \<in> carrier(G); subgroup(H,G)\<rbrakk> \<Longrightarrow> H #> x = H #> y"
by (auto simp add: r_coset_def m_assoc [symmetric]
                   subgroup.subset [THEN subsetD]
                   subgroup.m_closed solve_equation)

lemma (in group) coset_join2:
     "\<lbrakk>x \<in> carrier(G);  subgroup(H,G);  x\<in>H\<rbrakk> \<Longrightarrow> H #> x = H"
  \<comment> \<open>Alternative proof is to put \<^term>\<open>x=\<one>\<close> in \<open>repr_independence\<close>.\<close>
by (force simp add: subgroup.m_closed r_coset_def solve_equation)

lemma (in group) r_coset_subset_G:
     "\<lbrakk>H \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk> \<Longrightarrow> H #> x \<subseteq> carrier(G)"
by (auto simp add: r_coset_def)

lemma (in group) rcosI:
     "\<lbrakk>h \<in> H; H \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk> \<Longrightarrow> h \<cdot> x \<in> H #> x"
by (auto simp add: r_coset_def)

lemma (in group) rcosetsI:
     "\<lbrakk>H \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk> \<Longrightarrow> H #> x \<in> rcosets H"
by (auto simp add: RCOSETS_def)

text\<open>Really needed?\<close>
lemma (in group) transpose_inv:
     "\<lbrakk>x \<cdot> y = z;  x \<in> carrier(G);  y \<in> carrier(G);  z \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (inv x) \<cdot> z = y"
by (force simp add: m_assoc [symmetric])

subsection \<open>Normal subgroups\<close>

lemma normal_imp_subgroup: "H \<lhd> G ==> subgroup(H,G)"
  by (simp add: normal_def subgroup_def)

lemma (in group) normalI:
  "subgroup(H,G) \<Longrightarrow> (\<forall>x \<in> carrier(G). H #> x = x <# H) \<Longrightarrow> H \<lhd> G"
  by (simp add: normal_def normal_axioms_def)

lemma (in normal) inv_op_closed1:
     "\<lbrakk>x \<in> carrier(G); h \<in> H\<rbrakk> \<Longrightarrow> (inv x) \<cdot> h \<cdot> x \<in> H"
apply (insert coset_eq)
apply (auto simp add: l_coset_def r_coset_def)
apply (drule bspec, assumption)
apply (drule equalityD1 [THEN subsetD], blast, clarify)
apply (simp add: m_assoc)
apply (simp add: m_assoc [symmetric])
done

lemma (in normal) inv_op_closed2:
     "\<lbrakk>x \<in> carrier(G); h \<in> H\<rbrakk> \<Longrightarrow> x \<cdot> h \<cdot> (inv x) \<in> H"
apply (subgoal_tac "inv (inv x) \<cdot> h \<cdot> (inv x) \<in> H")
apply simp
apply (blast intro: inv_op_closed1)
done

text\<open>Alternative characterization of normal subgroups\<close>
lemma (in group) normal_inv_iff:
     "(N \<lhd> G) \<longleftrightarrow>
      (subgroup(N,G) & (\<forall>x \<in> carrier(G). \<forall>h \<in> N. x \<cdot> h \<cdot> (inv x) \<in> N))"
      (is "_ \<longleftrightarrow> ?rhs")
proof
  assume N: "N \<lhd> G"
  show ?rhs
    by (blast intro: N normal.inv_op_closed2 normal_imp_subgroup)
next
  assume ?rhs
  hence sg: "subgroup(N,G)"
    and closed: "\<And>x. x\<in>carrier(G) \<Longrightarrow> \<forall>h\<in>N. x \<cdot> h \<cdot> inv x \<in> N" by auto
  hence sb: "N \<subseteq> carrier(G)" by (simp add: subgroup.subset)
  show "N \<lhd> G"
  proof (intro normalI [OF sg], simp add: l_coset_def r_coset_def, clarify)
    fix x
    assume x: "x \<in> carrier(G)"
    show "(\<Union>h\<in>N. {h \<cdot> x}) = (\<Union>h\<in>N. {x \<cdot> h})"
    proof
      show "(\<Union>h\<in>N. {h \<cdot> x}) \<subseteq> (\<Union>h\<in>N. {x \<cdot> h})"
      proof clarify
        fix n
        assume n: "n \<in> N"
        show "n \<cdot> x \<in> (\<Union>h\<in>N. {x \<cdot> h})"
        proof (rule UN_I)
          from closed [of "inv x"]
          show "inv x \<cdot> n \<cdot> x \<in> N" by (simp add: x n)
          show "n \<cdot> x \<in> {x \<cdot> (inv x \<cdot> n \<cdot> x)}"
            by (simp add: x n m_assoc [symmetric] sb [THEN subsetD])
        qed
      qed
    next
      show "(\<Union>h\<in>N. {x \<cdot> h}) \<subseteq> (\<Union>h\<in>N. {h \<cdot> x})"
      proof clarify
        fix n
        assume n: "n \<in> N"
        show "x \<cdot> n \<in> (\<Union>h\<in>N. {h \<cdot> x})"
        proof (rule UN_I)
          show "x \<cdot> n \<cdot> inv x \<in> N" by (simp add: x n closed)
          show "x \<cdot> n \<in> {x \<cdot> n \<cdot> inv x \<cdot> x}"
            by (simp add: x n m_assoc sb [THEN subsetD])
        qed
      qed
    qed
  qed
qed

subsection\<open>More Properties of Cosets\<close>

lemma (in group) l_coset_subset_G:
     "\<lbrakk>H \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk> \<Longrightarrow> x <# H \<subseteq> carrier(G)"
by (auto simp add: l_coset_def subsetD)

lemma (in group) l_coset_swap:
     "\<lbrakk>y \<in> x <# H;  x \<in> carrier(G);  subgroup(H,G)\<rbrakk> \<Longrightarrow> x \<in> y <# H"
proof (simp add: l_coset_def)
  assume "\<exists>h\<in>H. y = x \<cdot> h"
    and x: "x \<in> carrier(G)"
    and sb: "subgroup(H,G)"
  then obtain h' where h': "h' \<in> H & x \<cdot> h' = y" by blast
  show "\<exists>h\<in>H. x = y \<cdot> h"
  proof
    show "x = y \<cdot> inv h'" using h' x sb
      by (auto simp add: m_assoc subgroup.subset [THEN subsetD])
    show "inv h' \<in> H" using h' sb
      by (auto simp add: subgroup.subset [THEN subsetD] subgroup.m_inv_closed)
  qed
qed

lemma (in group) l_coset_carrier:
     "\<lbrakk>y \<in> x <# H;  x \<in> carrier(G);  subgroup(H,G)\<rbrakk> \<Longrightarrow> y \<in> carrier(G)"
by (auto simp add: l_coset_def m_assoc
                   subgroup.subset [THEN subsetD] subgroup.m_closed)

lemma (in group) l_repr_imp_subset:
  assumes y: "y \<in> x <# H" and x: "x \<in> carrier(G)" and sb: "subgroup(H,G)"
  shows "y <# H \<subseteq> x <# H"
proof -
  from y
  obtain h' where "h' \<in> H" "x \<cdot> h' = y" by (auto simp add: l_coset_def)
  thus ?thesis using x sb
    by (auto simp add: l_coset_def m_assoc
                       subgroup.subset [THEN subsetD] subgroup.m_closed)
qed

lemma (in group) l_repr_independence:
  assumes y: "y \<in> x <# H" and x: "x \<in> carrier(G)" and sb: "subgroup(H,G)"
  shows "x <# H = y <# H"
proof
  show "x <# H \<subseteq> y <# H"
    by (rule l_repr_imp_subset,
        (blast intro: l_coset_swap l_coset_carrier y x sb)+)
  show "y <# H \<subseteq> x <# H" by (rule l_repr_imp_subset [OF y x sb])
qed

lemma (in group) setmult_subset_G:
     "\<lbrakk>H \<subseteq> carrier(G); K \<subseteq> carrier(G)\<rbrakk> \<Longrightarrow> H <#> K \<subseteq> carrier(G)"
by (auto simp add: set_mult_def subsetD)

lemma (in group) subgroup_mult_id: "subgroup(H,G) \<Longrightarrow> H <#> H = H"
apply (rule equalityI)
apply (auto simp add: subgroup.m_closed set_mult_def Sigma_def image_def)
apply (rule_tac x = x in bexI)
apply (rule bexI [of _ "\<one>"])
apply (auto simp add: subgroup.one_closed subgroup.subset [THEN subsetD])
done

subsubsection \<open>Set of inverses of an \<open>r_coset\<close>.\<close>

lemma (in normal) rcos_inv:
  assumes x:     "x \<in> carrier(G)"
  shows "set_inv (H #> x) = H #> (inv x)"
proof (simp add: r_coset_def SET_INV_def x inv_mult_group, safe intro!: equalityI)
  fix h
  assume h: "h \<in> H"
  {
    show "inv x \<cdot> inv h \<in> (\<Union>j\<in>H. {j \<cdot> inv x})"
    proof (rule UN_I)
      show "inv x \<cdot> inv h \<cdot> x \<in> H"
        by (simp add: inv_op_closed1 h x)
      show "inv x \<cdot> inv h \<in> {inv x \<cdot> inv h \<cdot> x \<cdot> inv x}"
        by (simp add: h x m_assoc)
    qed
  next
    show "h \<cdot> inv x \<in> (\<Union>j\<in>H. {inv x \<cdot> inv j})"
    proof (rule UN_I)
      show "x \<cdot> inv h \<cdot> inv x \<in> H"
        by (simp add: inv_op_closed2 h x)
      show "h \<cdot> inv x \<in> {inv x \<cdot> inv (x \<cdot> inv h \<cdot> inv x)}"
        by (simp add: h x m_assoc [symmetric] inv_mult_group)
    qed
  }
qed

subsubsection \<open>Theorems for \<open><#>\<close> with \<open>#>\<close> or \<open><#\<close>.\<close>

lemma (in group) setmult_rcos_assoc:
     "\<lbrakk>H \<subseteq> carrier(G); K \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> H <#> (K #> x) = (H <#> K) #> x"
by (force simp add: r_coset_def set_mult_def m_assoc)

lemma (in group) rcos_assoc_lcos:
     "\<lbrakk>H \<subseteq> carrier(G); K \<subseteq> carrier(G); x \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (H #> x) <#> K = H <#> (x <# K)"
by (force simp add: r_coset_def l_coset_def set_mult_def m_assoc)

lemma (in normal) rcos_mult_step1:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (H #> x) <#> (H #> y) = (H <#> (x <# H)) #> y"
by (simp add: setmult_rcos_assoc subset
              r_coset_subset_G l_coset_subset_G rcos_assoc_lcos)

lemma (in normal) rcos_mult_step2:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (H <#> (x <# H)) #> y = (H <#> (H #> x)) #> y"
by (insert coset_eq, simp add: normal_def)

lemma (in normal) rcos_mult_step3:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (H <#> (H #> x)) #> y = H #> (x \<cdot> y)"
  by (simp add: setmult_rcos_assoc coset_mult_assoc
              subgroup_mult_id subset normal_axioms normal.axioms)

lemma (in normal) rcos_sum:
     "\<lbrakk>x \<in> carrier(G); y \<in> carrier(G)\<rbrakk>
      \<Longrightarrow> (H #> x) <#> (H #> y) = H #> (x \<cdot> y)"
by (simp add: rcos_mult_step1 rcos_mult_step2 rcos_mult_step3)

lemma (in normal) rcosets_mult_eq: "M \<in> rcosets H \<Longrightarrow> H <#> M = M"
  \<comment> \<open>generalizes \<open>subgroup_mult_id\<close>\<close>
  by (auto simp add: RCOSETS_def subset
        setmult_rcos_assoc subgroup_mult_id normal_axioms normal.axioms)

subsubsection\<open>Two distinct right cosets are disjoint\<close>

definition
  r_congruent :: "[i,i] => i" (\<open>rcong\<index> _\<close> [60] 60) where
  "rcong\<^bsub>G\<^esub> H == {<x,y> \<in> carrier(G) * carrier(G). inv\<^bsub>G\<^esub> x \<cdot>\<^bsub>G\<^esub> y \<in> H}"

lemma (in subgroup) equiv_rcong:
   assumes "group(G)"
   shows "equiv (carrier(G), rcong H)"
proof -
  interpret group G by fact
  show ?thesis proof (simp add: equiv_def, intro conjI)
    show "rcong H \<subseteq> carrier(G) \<times> carrier(G)"
      by (auto simp add: r_congruent_def)
  next
    show "refl (carrier(G), rcong H)"
      by (auto simp add: r_congruent_def refl_def)
  next
    show "sym (rcong H)"
    proof (simp add: r_congruent_def sym_def, clarify)
      fix x y
      assume [simp]: "x \<in> carrier(G)" "y \<in> carrier(G)"
        and "inv x \<cdot> y \<in> H"
      hence "inv (inv x \<cdot> y) \<in> H" by simp
      thus "inv y \<cdot> x \<in> H" by (simp add: inv_mult_group)
    qed
  next
    show "trans (rcong H)"
    proof (simp add: r_congruent_def trans_def, clarify)
      fix x y z
      assume [simp]: "x \<in> carrier(G)" "y \<in> carrier(G)" "z \<in> carrier(G)"
        and "inv x \<cdot> y \<in> H" and "inv y \<cdot> z \<in> H"
      hence "(inv x \<cdot> y) \<cdot> (inv y \<cdot> z) \<in> H" by simp
      hence "inv x \<cdot> (y \<cdot> inv y) \<cdot> z \<in> H" by (simp add: m_assoc del: inv)
      thus "inv x \<cdot> z \<in> H" by simp
    qed
  qed
qed

text\<open>Equivalence classes of \<open>rcong\<close> correspond to left cosets.
  Was there a mistake in the definitions? I'd have expected them to
  correspond to right cosets.\<close>
lemma (in subgroup) l_coset_eq_rcong:
  assumes "group(G)"
  assumes a: "a \<in> carrier(G)"
  shows "a <# H = (rcong H) `` {a}"
proof -
  interpret group G by fact
  show ?thesis
    by (force simp add: r_congruent_def l_coset_def m_assoc [symmetric] a
      Collect_image_eq)
qed

lemma (in group) rcos_equation:
  assumes "subgroup(H, G)"
  shows
     "\<lbrakk>ha \<cdot> a = h \<cdot> b; a \<in> carrier(G);  b \<in> carrier(G);
        h \<in> H;  ha \<in> H;  hb \<in> H\<rbrakk>
      \<Longrightarrow> hb \<cdot> a \<in> (\<Union>h\<in>H. {h \<cdot> b})" (is "PROP ?P")
proof -
  interpret subgroup H G by fact
  show "PROP ?P"
    apply (rule UN_I [of "hb \<cdot> ((inv ha) \<cdot> h)"], simp)
    apply (simp add: m_assoc transpose_inv)
    done
qed

lemma (in group) rcos_disjoint:
  assumes "subgroup(H, G)"
  shows "\<lbrakk>a \<in> rcosets H; b \<in> rcosets H; a\<noteq>b\<rbrakk> \<Longrightarrow> a \<inter> b = 0" (is "PROP ?P")
proof -
  interpret subgroup H G by fact
  show "PROP ?P"
    apply (simp add: RCOSETS_def r_coset_def)
    apply (blast intro: rcos_equation assms sym)
    done
qed

subsection \<open>Order of a Group and Lagrange's Theorem\<close>

definition
  order :: "i => i" where
  "order(S) == |carrier(S)|"

lemma (in group) rcos_self:
  assumes "subgroup(H, G)"
  shows "x \<in> carrier(G) \<Longrightarrow> x \<in> H #> x" (is "PROP ?P")
proof -
  interpret subgroup H G by fact
  show "PROP ?P"
    apply (simp add: r_coset_def)
    apply (rule_tac x="\<one>" in bexI) apply (auto)
    done
qed

lemma (in group) rcosets_part_G:
  assumes "subgroup(H, G)"
  shows "\<Union>(rcosets H) = carrier(G)"
proof -
  interpret subgroup H G by fact
  show ?thesis
    apply (rule equalityI)
    apply (force simp add: RCOSETS_def r_coset_def)
    apply (auto simp add: RCOSETS_def intro: rcos_self assms)
    done
qed

lemma (in group) cosets_finite:
     "\<lbrakk>c \<in> rcosets H;  H \<subseteq> carrier(G);  Finite (carrier(G))\<rbrakk> \<Longrightarrow> Finite(c)"
apply (auto simp add: RCOSETS_def)
apply (simp add: r_coset_subset_G [THEN subset_Finite])
done

text\<open>More general than the HOL version, which also requires \<^term>\<open>G\<close> to
      be finite.\<close>
lemma (in group) card_cosets_equal:
  assumes H:   "H \<subseteq> carrier(G)"
  shows "c \<in> rcosets H \<Longrightarrow> |c| = |H|"
proof (simp add: RCOSETS_def, clarify)
  fix a
  assume a: "a \<in> carrier(G)"
  show "|H #> a| = |H|"
  proof (rule eqpollI [THEN cardinal_cong])
    show "H #> a \<lesssim> H"
    proof (simp add: lepoll_def, intro exI)
      show "(\<lambda>y \<in> H#>a. y \<cdot> inv a) \<in> inj(H #> a, H)"
        by (auto intro: lam_type
                 simp add: inj_def r_coset_def m_assoc subsetD [OF H] a)
    qed
    show "H \<lesssim> H #> a"
    proof (simp add: lepoll_def, intro exI)
      show "(\<lambda>y\<in> H. y \<cdot> a) \<in> inj(H, H #> a)"
        by (auto intro: lam_type
                 simp add: inj_def r_coset_def  subsetD [OF H] a)
    qed
  qed
qed

lemma (in group) rcosets_subset_PowG:
     "subgroup(H,G) \<Longrightarrow> rcosets H \<subseteq> Pow(carrier(G))"
apply (simp add: RCOSETS_def)
apply (blast dest: r_coset_subset_G subgroup.subset)
done

theorem (in group) lagrange:
     "\<lbrakk>Finite(carrier(G)); subgroup(H,G)\<rbrakk>
      \<Longrightarrow> |rcosets H| #* |H| = order(G)"
apply (simp (no_asm_simp) add: order_def rcosets_part_G [symmetric])
apply (subst mult_commute)
apply (rule card_partition)
   apply (simp add: rcosets_subset_PowG [THEN subset_Finite])
  apply (simp add: rcosets_part_G)
 apply (simp add: card_cosets_equal [OF subgroup.subset])
apply (simp add: rcos_disjoint)
done

subsection \<open>Quotient Groups: Factorization of a Group\<close>

definition
  FactGroup :: "[i,i] => i" (infixl \<open>Mod\<close> 65) where
    \<comment> \<open>Actually defined for groups rather than monoids\<close>
  "G Mod H ==
     <rcosets\<^bsub>G\<^esub> H, \<lambda><K1,K2> \<in> (rcosets\<^bsub>G\<^esub> H) \<times> (rcosets\<^bsub>G\<^esub> H). K1 <#>\<^bsub>G\<^esub> K2, H, 0>"

lemma (in normal) setmult_closed:
     "\<lbrakk>K1 \<in> rcosets H; K2 \<in> rcosets H\<rbrakk> \<Longrightarrow> K1 <#> K2 \<in> rcosets H"
by (auto simp add: rcos_sum RCOSETS_def)

lemma (in normal) setinv_closed:
     "K \<in> rcosets H \<Longrightarrow> set_inv K \<in> rcosets H"
by (auto simp add: rcos_inv RCOSETS_def)

lemma (in normal) rcosets_assoc:
     "\<lbrakk>M1 \<in> rcosets H; M2 \<in> rcosets H; M3 \<in> rcosets H\<rbrakk>
      \<Longrightarrow> M1 <#> M2 <#> M3 = M1 <#> (M2 <#> M3)"
by (auto simp add: RCOSETS_def rcos_sum m_assoc)

lemma (in subgroup) subgroup_in_rcosets:
  assumes "group(G)"
  shows "H \<in> rcosets H"
proof -
  interpret group G by fact
  have "H #> \<one> = H"
    using _ subgroup_axioms by (rule coset_join2) simp_all
  then show ?thesis
    by (auto simp add: RCOSETS_def intro: sym)
qed

lemma (in normal) rcosets_inv_mult_group_eq:
     "M \<in> rcosets H \<Longrightarrow> set_inv M <#> M = H"
by (auto simp add: RCOSETS_def rcos_inv rcos_sum subgroup.subset normal_axioms normal.axioms)

theorem (in normal) factorgroup_is_group:
  "group (G Mod H)"
apply (simp add: FactGroup_def)
apply (rule groupI)
    apply (simp add: setmult_closed)
   apply (simp add: normal_imp_subgroup subgroup_in_rcosets)
  apply (simp add: setmult_closed rcosets_assoc)
 apply (simp add: normal_imp_subgroup
                  subgroup_in_rcosets rcosets_mult_eq)
apply (auto dest: rcosets_inv_mult_group_eq simp add: setinv_closed)
done

lemma (in normal) inv_FactGroup:
     "X \<in> carrier (G Mod H) \<Longrightarrow> inv\<^bsub>G Mod H\<^esub> X = set_inv X"
apply (rule group.inv_equality [OF factorgroup_is_group])
apply (simp_all add: FactGroup_def setinv_closed rcosets_inv_mult_group_eq)
done

text\<open>The coset map is a homomorphism from \<^term>\<open>G\<close> to the quotient group
  \<^term>\<open>G Mod H\<close>\<close>
lemma (in normal) r_coset_hom_Mod:
  "(\<lambda>a \<in> carrier(G). H #> a) \<in> hom(G, G Mod H)"
by (auto simp add: FactGroup_def RCOSETS_def hom_def rcos_sum intro: lam_type)

subsection\<open>The First Isomorphism Theorem\<close>

text\<open>The quotient by the kernel of a homomorphism is isomorphic to the
  range of that homomorphism.\<close>

definition
  kernel :: "[i,i,i] => i" where
    \<comment> \<open>the kernel of a homomorphism\<close>
  "kernel(G,H,h) == {x \<in> carrier(G). h ` x = \<one>\<^bsub>H\<^esub>}"

lemma (in group_hom) subgroup_kernel: "subgroup (kernel(G,H,h), G)"
apply (rule subgroup.intro)
apply (auto simp add: kernel_def group.intro)
done

text\<open>The kernel of a homomorphism is a normal subgroup\<close>
lemma (in group_hom) normal_kernel: "(kernel(G,H,h)) \<lhd> G"
apply (simp add: group.normal_inv_iff subgroup_kernel group.intro)
apply (simp add: kernel_def)
done

lemma (in group_hom) FactGroup_nonempty:
  assumes X: "X \<in> carrier (G Mod kernel(G,H,h))"
  shows "X \<noteq> 0"
proof -
  from X
  obtain g where "g \<in> carrier(G)"
             and "X = kernel(G,H,h) #> g"
    by (auto simp add: FactGroup_def RCOSETS_def)
  thus ?thesis
   by (auto simp add: kernel_def r_coset_def image_def intro: hom_one)
qed

lemma (in group_hom) FactGroup_contents_mem:
  assumes X: "X \<in> carrier (G Mod (kernel(G,H,h)))"
  shows "contents (h``X) \<in> carrier(H)"
proof -
  from X
  obtain g where g: "g \<in> carrier(G)"
             and "X = kernel(G,H,h) #> g"
    by (auto simp add: FactGroup_def RCOSETS_def)
  hence "h `` X = {h ` g}"
    by (auto simp add: kernel_def r_coset_def image_UN
                       image_eq_UN [OF hom_is_fun] g)
  thus ?thesis by (auto simp add: g)
qed

lemma mult_FactGroup:
     "[|X \<in> carrier(G Mod H); X' \<in> carrier(G Mod H)|]
      ==> X \<cdot>\<^bsub>(G Mod H)\<^esub> X' = X <#>\<^bsub>G\<^esub> X'"
by (simp add: FactGroup_def)

lemma (in normal) FactGroup_m_closed:
     "[|X \<in> carrier(G Mod H); X' \<in> carrier(G Mod H)|]
      ==> X <#>\<^bsub>G\<^esub> X' \<in> carrier(G Mod H)"
by (simp add: FactGroup_def setmult_closed)

lemma (in group_hom) FactGroup_hom:
     "(\<lambda>X \<in> carrier(G Mod (kernel(G,H,h))). contents (h``X))
      \<in> hom (G Mod (kernel(G,H,h)), H)"
proof (simp add: hom_def FactGroup_contents_mem lam_type mult_FactGroup normal.FactGroup_m_closed [OF normal_kernel], intro ballI)
  fix X and X'
  assume X:  "X  \<in> carrier (G Mod kernel(G,H,h))"
     and X': "X' \<in> carrier (G Mod kernel(G,H,h))"
  then
  obtain g and g'
           where "g \<in> carrier(G)" and "g' \<in> carrier(G)"
             and "X = kernel(G,H,h) #> g" and "X' = kernel(G,H,h) #> g'"
    by (auto simp add: FactGroup_def RCOSETS_def)
  hence all: "\<forall>x\<in>X. h ` x = h ` g" "\<forall>x\<in>X'. h ` x = h ` g'"
    and Xsub: "X \<subseteq> carrier(G)" and X'sub: "X' \<subseteq> carrier(G)"
    by (force simp add: kernel_def r_coset_def image_def)+
  hence "h `` (X <#> X') = {h ` g \<cdot>\<^bsub>H\<^esub> h ` g'}" using X X'
    by (auto dest!: FactGroup_nonempty
             simp add: set_mult_def image_eq_UN [OF hom_is_fun] image_UN
                       subsetD [OF Xsub] subsetD [OF X'sub])
  thus "contents (h `` (X <#> X')) = contents (h `` X) \<cdot>\<^bsub>H\<^esub> contents (h `` X')"
    by (simp add: all image_eq_UN [OF hom_is_fun] FactGroup_nonempty
                  X X' Xsub X'sub)
qed

text\<open>Lemma for the following injectivity result\<close>
lemma (in group_hom) FactGroup_subset:
     "\<lbrakk>g \<in> carrier(G); g' \<in> carrier(G); h ` g = h ` g'\<rbrakk>
      \<Longrightarrow>  kernel(G,H,h) #> g \<subseteq> kernel(G,H,h) #> g'"
apply (clarsimp simp add: kernel_def r_coset_def image_def)
apply (rename_tac y)
apply (rule_tac x="y \<cdot> g \<cdot> inv g'" in bexI)
apply (simp_all add: G.m_assoc)
done

lemma (in group_hom) FactGroup_inj:
     "(\<lambda>X\<in>carrier (G Mod kernel(G,H,h)). contents (h `` X))
      \<in> inj(carrier (G Mod kernel(G,H,h)), carrier(H))"
proof (simp add: inj_def FactGroup_contents_mem lam_type, clarify)
  fix X and X'
  assume X:  "X  \<in> carrier (G Mod kernel(G,H,h))"
     and X': "X' \<in> carrier (G Mod kernel(G,H,h))"
  then
  obtain g and g'
           where gX: "g \<in> carrier(G)"  "g' \<in> carrier(G)"
              "X = kernel(G,H,h) #> g" "X' = kernel(G,H,h) #> g'"
    by (auto simp add: FactGroup_def RCOSETS_def)
  hence all: "\<forall>x\<in>X. h ` x = h ` g" "\<forall>x\<in>X'. h ` x = h ` g'"
    and Xsub: "X \<subseteq> carrier(G)" and X'sub: "X' \<subseteq> carrier(G)"
    by (force simp add: kernel_def r_coset_def image_def)+
  assume "contents (h `` X) = contents (h `` X')"
  hence h: "h ` g = h ` g'"
    by (simp add: all image_eq_UN [OF hom_is_fun] FactGroup_nonempty
                  X X' Xsub X'sub)
  show "X=X'" by (rule equalityI) (simp_all add: FactGroup_subset h gX)
qed

lemma (in group_hom) kernel_rcoset_subset:
  assumes g: "g \<in> carrier(G)"
  shows "kernel(G,H,h) #> g \<subseteq> carrier (G)"
    by (auto simp add: g kernel_def r_coset_def)

text\<open>If the homomorphism \<^term>\<open>h\<close> is onto \<^term>\<open>H\<close>, then so is the
homomorphism from the quotient group\<close>
lemma (in group_hom) FactGroup_surj:
  assumes h: "h \<in> surj(carrier(G), carrier(H))"
  shows "(\<lambda>X\<in>carrier (G Mod kernel(G,H,h)). contents (h `` X))
         \<in> surj(carrier (G Mod kernel(G,H,h)), carrier(H))"
proof (simp add: surj_def FactGroup_contents_mem lam_type, clarify)
  fix y
  assume y: "y \<in> carrier(H)"
  with h obtain g where g: "g \<in> carrier(G)" "h ` g = y"
    by (auto simp add: surj_def)
  hence "(\<Union>x\<in>kernel(G,H,h) #> g. {h ` x}) = {y}"
    by (auto simp add: y kernel_def r_coset_def)
  with g show "\<exists>x\<in>carrier(G Mod kernel(G, H, h)). contents(h `` x) = y"
        \<comment> \<open>The witness is \<^term>\<open>kernel(G,H,h) #> g\<close>\<close>
    by (force simp add: FactGroup_def RCOSETS_def
           image_eq_UN [OF hom_is_fun] kernel_rcoset_subset)
qed

text\<open>If \<^term>\<open>h\<close> is a homomorphism from \<^term>\<open>G\<close> onto \<^term>\<open>H\<close>, then the
 quotient group \<^term>\<open>G Mod (kernel(G,H,h))\<close> is isomorphic to \<^term>\<open>H\<close>.\<close>
theorem (in group_hom) FactGroup_iso:
  "h \<in> surj(carrier(G), carrier(H))
   \<Longrightarrow> (\<lambda>X\<in>carrier (G Mod kernel(G,H,h)). contents (h``X)) \<in> (G Mod (kernel(G,H,h))) \<cong> H"
by (simp add: iso_def FactGroup_hom FactGroup_inj bij_def FactGroup_surj)

end


theory Ordinal_Model_Base
  imports "../../ModelKit/ModelComponents"
begin

context ModelBase begin
ML \<open>val ord_model = mcomp
 { name = "Ordinal_Model",
   deps = mcomps [],
   variant = SOME (vari
    { tag_name = "ord",
      vcases =
        (@{term \<open>{0}\<close>},
         @{term "(\<lambda>j x. {j}) :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"},
         @{term "(\<lambda>\<mu> f. {\<mu>}) :: 'a \<Rightarrow> 'a \<Rightarrow> 'a"}),
      alpha_typ = @{term \<open>Ord\<close>}}),
   excludes_formulas = []}\<close>
end
local_setup \<open>snd o (mk_mcomp_class ord_model)\<close>

context Ordinal_Model
begin

definition mOrd :: \<open>'a \<Rightarrow> bool\<close>
  where "mOrd \<equiv> M \<triangle> \<^enum> ord"

definition mlt :: \<open>'a \<Rightarrow> 'a \<Rightarrow> bool\<close> (infix \<open>\<lless>\<close> 50)
  where "i \<lless> j \<equiv> i : mOrd \<and> j : mOrd \<and> snd i < snd j"

definition mzero :: \<open>'a\<close> (\<open>m0\<close>)
  where "m0 \<equiv> <ord,0>"

definition msucc' :: \<open>'a \<Rightarrow> 'a\<close>
  where "msucc' j \<equiv> <ord, succ (snd j)>"

definition msucc :: \<open>'a \<Rightarrow> 'a\<close>
  where "msucc j \<equiv> if j : mOrd then msucc' j
                               else Ordinal_Model_mdefault"

definition momega :: \<open>'a\<close> (\<open>m\<omega>\<close>)
  where "m\<omega> \<equiv> <ord, \<omega>>"

definition mLimit :: \<open>'a \<Rightarrow> bool\<close>
  where "mLimit j \<equiv> j : mOrd \<and> snd j : Limit"

theorem variants_ord_cases :
  shows "Variants ord 0 x = {0}"
    and "j : Ord   \<Longrightarrow> Variants ord (succ j) x = {succ j}"
    and "\<mu> : Limit \<Longrightarrow> Variants ord \<mu> f = {\<mu>}"
  using v_ord_0 v_ord_succ v_ord_limit by auto

corollary variants_ord :
  assumes j : "j : Ord"
  shows "Variants ord j x = {j}"
  by (rule ord_cases[OF j],
      use variants_ord_cases in auto)

corollary variants_ord_mem :
  assumes j : "j : Ord"
  shows "i \<in> Variants ord j x \<Longrightarrow> i = j"
  unfolding variants_ord[OF j]
     sng_iff[OF ord_setmem[OF j]] .

lemma ord_tierI_cases :
  shows "<ord, 0> \<in> Tier 0"
    and "j : Ord   \<Longrightarrow> <ord,succ j> \<in> Tier (succ j)"
    and "u : Limit \<Longrightarrow> <ord, u> \<in> Tier u"
 using tier0I[OF ord_tag] tier_succI2[OF ord_tag] tier_limI2[OF ord_tag]
       variants_ord sng_iff[OF ord_setmem] zero_ord succ_ord limit_ord
 by auto

lemma ord_tierI_eq :
  assumes i : "i : Ord"
    shows "<ord, i> \<in> Tier i"
  by (rule ord_cases[OF i],
      use ord_tierI_cases in auto)

lemma ord_tierI :
  assumes i : "i : Ord" and j : "j : Ord"
      and ij: "i \<le> j"
    shows "<ord, i> \<in> Tier j"
  by (rule leqE[OF i j ij],
      use ord_tierI_eq[OF i] tier_increasing[OF i j] in auto)

lemma ord_tierD :
  assumes i : "i : Ord" and j : "j : Ord"
  shows "<ord,i> \<in> Tier j \<Longrightarrow> i \<le> j"
proof (induct rule: trans_induct3[OF j])
  case 1
  hence "i \<in> Variants ord 0 \<emptyset>"
    using tier0D(2) by simp
  hence "i = 0"
    using variants_ord_mem[OF zero_ord] by simp
  then show ?case
    using leq_zero_iff[OF i] by auto
next
  case ih:(2 j)
  show ?case
  proof (rule tier_succE_pair[OF ih(1) ih(3)])
    assume "<ord,i> \<in> Tier j"
    hence "i \<le> j" using ih(2) by simp
    thus "i \<le> succ j"
      using leq_succ_iff[OF i ih(1)] by auto
  next
    assume "i \<in> Variants ord (succ j) (Tier j \<ominus> ord)"
    hence "i = succ j"
      using variants_ord_mem[OF succ_ord[OF ih(1)]] by auto
    thus "i \<le> succ j"
      using leqI2[OF i succ_ord[OF ih(1)]] by auto
  qed
next
  case ih:(3 \<mu>)
  show ?case
  proof (rule tier_limE_pair[OF ih(1) ih(3)])
    fix j
    assume j:"j : Ord" "j < \<mu>"
       and ij:"<ord,i> \<in> Tier j"
    hence "i \<le> j"
      using ih(2) by auto
    thus "i \<le> \<mu>"
      using leqI1[OF j(1) limit_ord[OF ih(1)] j(2)]
            leq_trans2[OF i j(1) limit_ord[OF ih(1)]]
      by auto
  next
    assume "i \<in> Variants ord \<mu> (\<lambda>j<\<mu>. Tier j \<ominus> ord)"
    hence "i = \<mu>"
      using variants_ord_mem[OF limit_ord[OF ih(1)]] by auto
    thus "i \<le> \<mu>"
      by (rule leqI2[OF i limit_ord[OF ih(1)]])
  qed
qed

lemma ord_tier_iff :
  assumes i : "i : Ord" and j : "j : Ord"
    shows "<ord, i> \<in> Tier j \<longleftrightarrow> i \<le> j"
  using ord_tierI[OF i j] ord_tierD[OF i j]
  by auto

end
end


(*  Title:      ZF/Cardinal_AC.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1994  University of Cambridge

These results help justify infinite-branching datatypes
*)

section\<open>Cardinal Arithmetic Using AC\<close>

theory Cardinal_AC imports CardinalArith Zorn begin

subsection\<open>Strengthened Forms of Existing Theorems on Cardinals\<close>

lemma cardinal_eqpoll: "|A| \<approx> A"
apply (rule AC_well_ord [THEN exE])
apply (erule well_ord_cardinal_eqpoll)
done

text\<open>The theorem \<^term>\<open>||A|| = |A|\<close>\<close>
lemmas cardinal_idem = cardinal_eqpoll [THEN cardinal_cong, simp]

lemma cardinal_eqE: "|X| = |Y| ==> X \<approx> Y"
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule well_ord_cardinal_eqE, assumption+)
done

lemma cardinal_eqpoll_iff: "|X| = |Y| \<longleftrightarrow> X \<approx> Y"
by (blast intro: cardinal_cong cardinal_eqE)

lemma cardinal_disjoint_Un:
     "[| |A|=|B|;  |C|=|D|;  A \<inter> C = 0;  B \<inter> D = 0 |]
      ==> |A \<union> C| = |B \<union> D|"
by (simp add: cardinal_eqpoll_iff eqpoll_disjoint_Un)

lemma lepoll_imp_cardinal_le: "A \<lesssim> B ==> |A| \<le> |B|"
apply (rule AC_well_ord [THEN exE])
apply (erule well_ord_lepoll_imp_cardinal_le, assumption)
done

lemma cadd_assoc: "(i \<oplus> j) \<oplus> k = i \<oplus> (j \<oplus> k)"
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule well_ord_cadd_assoc, assumption+)
done

lemma cmult_assoc: "(i \<otimes> j) \<otimes> k = i \<otimes> (j \<otimes> k)"
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule well_ord_cmult_assoc, assumption+)
done

lemma cadd_cmult_distrib: "(i \<oplus> j) \<otimes> k = (i \<otimes> k) \<oplus> (j \<otimes> k)"
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule AC_well_ord [THEN exE])
apply (rule well_ord_cadd_cmult_distrib, assumption+)
done

lemma InfCard_square_eq: "InfCard(|A|) ==> A*A \<approx> A"
apply (rule AC_well_ord [THEN exE])
apply (erule well_ord_InfCard_square_eq, assumption)
done

subsection \<open>The relationship between cardinality and le-pollence\<close>

lemma Card_le_imp_lepoll:
  assumes "|A| \<le> |B|" shows "A \<lesssim> B"
proof -
  have "A \<approx> |A|"
    by (rule cardinal_eqpoll [THEN eqpoll_sym])
  also have "... \<lesssim> |B|"
    by (rule le_imp_subset [THEN subset_imp_lepoll]) (rule assms)
  also have "... \<approx> B"
    by (rule cardinal_eqpoll)
  finally show ?thesis .
qed

lemma le_Card_iff: "Card(K) ==> |A| \<le> K \<longleftrightarrow> A \<lesssim> K"
apply (erule Card_cardinal_eq [THEN subst], rule iffI,
       erule Card_le_imp_lepoll)
apply (erule lepoll_imp_cardinal_le)
done

lemma cardinal_0_iff_0 [simp]: "|A| = 0 \<longleftrightarrow> A = 0"
apply auto
apply (drule cardinal_0 [THEN ssubst])
apply (blast intro: eqpoll_0_iff [THEN iffD1] cardinal_eqpoll_iff [THEN iffD1])
done

lemma cardinal_lt_iff_lesspoll:
  assumes i: "Ord(i)" shows "i < |A| \<longleftrightarrow> i \<prec> A"
proof
  assume "i < |A|"
  hence  "i \<prec> |A|"
    by (blast intro: lt_Card_imp_lesspoll Card_cardinal)
  also have "...  \<approx> A"
    by (rule cardinal_eqpoll)
  finally show "i \<prec> A" .
next
  assume "i \<prec> A"
  also have "...  \<approx> |A|"
    by (blast intro: cardinal_eqpoll eqpoll_sym)
  finally have "i \<prec> |A|" .
  thus  "i < |A|" using i
    by (force intro: cardinal_lt_imp_lt lesspoll_cardinal_lt)
qed

lemma cardinal_le_imp_lepoll: " i \<le> |A| ==> i \<lesssim> A"
  by (blast intro: lt_Ord Card_le_imp_lepoll Ord_cardinal_le le_trans)

subsection\<open>Other Applications of AC\<close>

lemma surj_implies_inj:
  assumes f: "f \<in> surj(X,Y)" shows "\<exists>g. g \<in> inj(Y,X)"
proof -
  from f AC_Pi [of Y "%y. f-``{y}"]
  obtain z where z: "z \<in> (\<Prod>y\<in>Y. f -`` {y})"
    by (auto simp add: surj_def) (fast dest: apply_Pair)
  show ?thesis
    proof
      show "z \<in> inj(Y, X)" using z surj_is_fun [OF f]
        by (blast dest: apply_type Pi_memberD
                  intro: apply_equality Pi_type f_imp_injective)
    qed
qed

text\<open>Kunen's Lemma 10.20\<close>
lemma surj_implies_cardinal_le:
  assumes f: "f \<in> surj(X,Y)" shows "|Y| \<le> |X|"
proof (rule lepoll_imp_cardinal_le)
  from f [THEN surj_implies_inj] obtain g where "g \<in> inj(Y,X)" ..
  thus "Y \<lesssim> X"
    by (auto simp add: lepoll_def)
qed

text\<open>Kunen's Lemma 10.21\<close>
lemma cardinal_UN_le:
  assumes K: "InfCard(K)"
  shows "(!!i. i\<in>K ==> |X(i)| \<le> K) ==> |\<Union>i\<in>K. X(i)| \<le> K"
proof (simp add: K InfCard_is_Card le_Card_iff)
  have [intro]: "Ord(K)" by (blast intro: InfCard_is_Card Card_is_Ord K)
  assume "!!i. i\<in>K ==> X(i) \<lesssim> K"
  hence "!!i. i\<in>K ==> \<exists>f. f \<in> inj(X(i), K)" by (simp add: lepoll_def)
  with AC_Pi obtain f where f: "f \<in> (\<Prod>i\<in>K. inj(X(i), K))"
    by force
  { fix z
    assume z: "z \<in> (\<Union>i\<in>K. X(i))"
    then obtain i where i: "i \<in> K" "Ord(i)" "z \<in> X(i)"
      by (blast intro: Ord_in_Ord [of K])
    hence "(\<mu> i. z \<in> X(i)) \<le> i" by (fast intro: Least_le)
    hence "(\<mu> i. z \<in> X(i)) < K" by (best intro: lt_trans1 ltI i)
    hence "(\<mu> i. z \<in> X(i)) \<in> K" and "z \<in> X(\<mu> i. z \<in> X(i))"
      by (auto intro: LeastI ltD i)
  } note mems = this
  have "(\<Union>i\<in>K. X(i)) \<lesssim> K \<times> K"
    proof (unfold lepoll_def)
      show "\<exists>f. f \<in> inj(\<Union>RepFun(K, X), K \<times> K)"
        apply (rule exI)
        apply (rule_tac c = "%z. \<langle>\<mu> i. z \<in> X(i), f ` (\<mu> i. z \<in> X(i)) ` z\<rangle>"
                    and d = "%\<langle>i,j\<rangle>. converse (f`i) ` j" in lam_injective)
        apply (force intro: f inj_is_fun mems apply_type Perm.left_inverse)+
        done
    qed
  also have "... \<approx> K"
    by (simp add: K InfCard_square_eq InfCard_is_Card Card_cardinal_eq)
  finally show "(\<Union>i\<in>K. X(i)) \<lesssim> K" .
qed

text\<open>The same again, using \<^term>\<open>csucc\<close>\<close>
lemma cardinal_UN_lt_csucc:
     "[| InfCard(K);  \<And>i. i\<in>K \<Longrightarrow> |X(i)| < csucc(K) |]
      ==> |\<Union>i\<in>K. X(i)| < csucc(K)"
by (simp add: Card_lt_csucc_iff cardinal_UN_le InfCard_is_Card Card_cardinal)

text\<open>The same again, for a union of ordinals.  In use, j(i) is a bit like rank(i),
  the least ordinal j such that i:Vfrom(A,j).\<close>
lemma cardinal_UN_Ord_lt_csucc:
     "[| InfCard(K);  \<And>i. i\<in>K \<Longrightarrow> j(i) < csucc(K) |]
      ==> (\<Union>i\<in>K. j(i)) < csucc(K)"
apply (rule cardinal_UN_lt_csucc [THEN Card_lt_imp_lt], assumption)
apply (blast intro: Ord_cardinal_le [THEN lt_trans1] elim: ltE)
apply (blast intro!: Ord_UN elim: ltE)
apply (erule InfCard_is_Card [THEN Card_is_Ord, THEN Card_csucc])
done

subsection\<open>The Main Result for Infinite-Branching Datatypes\<close>

text\<open>As above, but the index set need not be a cardinal. Work
backwards along the injection from \<^term>\<open>W\<close> into \<^term>\<open>K\<close>, given
that \<^term>\<open>W\<noteq>0\<close>.\<close>

lemma inj_UN_subset:
  assumes f: "f \<in> inj(A,B)" and a: "a \<in> A"
  shows "(\<Union>x\<in>A. C(x)) \<subseteq> (\<Union>y\<in>B. C(if y \<in> range(f) then converse(f)`y else a))"
proof (rule UN_least)
  fix x
  assume x: "x \<in> A"
  hence fx: "f ` x \<in> B" by (blast intro: f inj_is_fun [THEN apply_type])
  have "C(x) \<subseteq> C(if f ` x \<in> range(f) then converse(f) ` (f ` x) else a)"
    using f x by (simp add: inj_is_fun [THEN apply_rangeI])
  also have "... \<subseteq> (\<Union>y\<in>B. C(if y \<in> range(f) then converse(f) ` y else a))"
    by (rule UN_upper [OF fx])
  finally show "C(x) \<subseteq> (\<Union>y\<in>B. C(if y \<in> range(f) then converse(f)`y else a))" .
qed

theorem le_UN_Ord_lt_csucc:
  assumes IK: "InfCard(K)" and WK: "|W| \<le> K" and j: "\<And>w. w\<in>W \<Longrightarrow> j(w) < csucc(K)"
  shows "(\<Union>w\<in>W. j(w)) < csucc(K)"
proof -
  have CK: "Card(K)"
    by (simp add: InfCard_is_Card IK)
  then obtain f where f: "f \<in> inj(W, K)" using WK
    by(auto simp add: le_Card_iff lepoll_def)
  have OU: "Ord(\<Union>w\<in>W. j(w))" using j
    by (blast elim: ltE)
  note lt_subset_trans [OF _ _ OU, trans]
  show ?thesis
    proof (cases "W=0")
      case True  \<comment> \<open>solve the easy 0 case\<close>
      thus ?thesis by (simp add: CK Card_is_Ord Card_csucc Ord_0_lt_csucc)
    next
      case False
        then obtain x where x: "x \<in> W" by blast
        have "(\<Union>x\<in>W. j(x)) \<subseteq> (\<Union>k\<in>K. j(if k \<in> range(f) then converse(f) ` k else x))"
          by (rule inj_UN_subset [OF f x])
        also have "... < csucc(K)" using IK
          proof (rule cardinal_UN_Ord_lt_csucc)
            fix k
            assume "k \<in> K"
            thus "j(if k \<in> range(f) then converse(f) ` k else x) < csucc(K)" using f x j
              by (simp add: inj_converse_fun [THEN apply_type])
          qed
        finally show ?thesis .
    qed
qed

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_sort_StoogeSortCount
imports "../../Test_Base"
begin

datatype ('a, 'b) pair = pair2 "'a" "'b"

datatype 'a list = nil2 | cons2 "'a" "'a list"

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun take :: "int => 'a list => 'a list" where
"take y z =
   (if y <= 0 then nil2 else
      (case z of
         nil2 => nil2
         | cons2 z2 xs => cons2 z2 (take (y - 1) xs)))"

fun sort2 :: "int => int => int list" where
"sort2 y z =
   (if y <= z then cons2 y (cons2 z (nil2)) else
      cons2 z (cons2 y (nil2)))"

fun reverse :: "'a list => 'a list" where
"reverse (nil2) = nil2"
| "reverse (cons2 z xs) = x (reverse xs) (cons2 z (nil2))"

fun length :: "'a list => int" where
"length (nil2) = 0"
| "length (cons2 z l) = 1 + (length l)"

fun drop :: "int => 'a list => 'a list" where
"drop y z =
   (if y <= 0 then z else
      (case z of
         nil2 => nil2
         | cons2 z2 xs1 => drop (y - 1) xs1))"

fun splitAt :: "int => 'a list =>
                (('a list), ('a list)) pair" where
"splitAt y z = pair2 (take y z) (drop y z)"

function stooge1sort2 :: "int list => int list"
         and stoogesort :: "int list => int list"
         and stooge1sort1 :: "int list => int list" where
"stooge1sort2 y =
   (case splitAt ((op div) (length y) 3) (reverse y) of
      pair2 ys2 zs2 => x (stoogesort zs2) (reverse ys2))"
| "stoogesort (nil2) = nil2"
| "stoogesort (cons2 z (nil2)) = cons2 z (nil2)"
| "stoogesort (cons2 z (cons2 y2 (nil2))) = sort2 z y2"
| "stoogesort (cons2 z (cons2 y2 (cons2 x3 x4))) =
     stooge1sort2
       (stooge1sort1 (stooge1sort2 (cons2 z (cons2 y2 (cons2 x3 x4)))))"
| "stooge1sort1 y =
     (case splitAt ((op div) (length y) 3) y of
        pair2 ys2 zs1 => x ys2 (stoogesort zs1))"
by pat_completeness auto

fun count :: "'a => 'a list => int" where
"count y (nil2) = 0"
| "count y (cons2 z2 ys) =
     (if (y = z2) then 1 + (count y ys) else count y ys)"

theorem property0 :
  "((count y (stoogesort xs)) = (count y xs))"
  oops

end


section \<open> Ground Mereology \<close>

(*<*)
theory M
  imports PM
begin
(*>*)

text \<open> The theory of \emph{ground mereology} adds to premereology the antisymmetry of parthood, and
defines proper parthood as nonidentical parthood.\footnote{For this axiomatization of ground mereology see,
for example, @{cite "varzi_parts_1996"} p. 261 and @{cite "casati_parts_1999"} p. 36. For discussion of the
antisymmetry of parthood see, for example, @{cite "cotnoir_antisymmetry_2010"}. For the definition of
proper parthood as nonidentical parthood, see for example, @{cite "leonard_calculus_1940"} p. 47.}
In other words, ground mereology assumes that parthood is a partial order.\<close>

locale M = PM +
  assumes part_antisymmetry: "P x y \<Longrightarrow> P y x \<Longrightarrow> x = y"
  assumes nip_eq: "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y"
begin

subsection \<open> Proper Parthood \<close>

lemma proper_implies_part: "PP x y \<Longrightarrow> P x y"
proof -
  assume "PP x y"
  with nip_eq have "P x y \<and> x \<noteq> y"..
  thus "P x y"..
qed

lemma proper_implies_distinct: "PP x y \<Longrightarrow> x \<noteq> y"
proof -
  assume "PP x y"
  with nip_eq have "P x y \<and> x \<noteq> y"..
  thus "x \<noteq> y"..
qed

lemma proper_implies_not_part: "PP x y \<Longrightarrow> \<not> P y x"
proof -
  assume "PP x y"
  hence "P x y" by (rule proper_implies_part)
  show "\<not> P y x"
  proof
    from `PP x y` have "x \<noteq> y" by (rule proper_implies_distinct)
    moreover assume "P y x"
    with `P x y` have "x = y" by (rule part_antisymmetry)
    ultimately show "False"..
  qed
qed

lemma proper_part_asymmetry: "PP x y \<Longrightarrow> \<not> PP y x"
proof -
  assume "PP x y"
  hence "P x y" by (rule proper_implies_part)
  from `PP x y` have "x \<noteq> y" by (rule proper_implies_distinct)
  show "\<not> PP y x"
  proof
    assume "PP y x"
    hence "P y x" by (rule proper_implies_part)
    with `P x y` have "x = y" by (rule part_antisymmetry)
    with `x \<noteq> y` show "False"..
  qed
qed

lemma proper_implies_overlap: "PP x y \<Longrightarrow> O x y"
proof -
  assume "PP x y"
  hence "P x y" by (rule proper_implies_part)
  thus "O x y" by (rule part_implies_overlap)
qed

end

text \<open> The rest of this section compares four alternative axiomatizations of ground mereology, and
verifies their equivalence. \<close>

text \<open> The first alternative axiomatization defines proper parthood as nonmutual instead of nonidentical parthood.\footnote{
See, for example, @{cite "varzi_parts_1996"} p. 261 and @{cite "casati_parts_1999"} p. 36. For the distinction
between nonmutual and nonidentical parthood, see @{cite "parsons_many_2014"} pp. 6-8.}
In the presence of antisymmetry, the two definitions of proper parthood are equivalent.\footnote{
See @{cite "cotnoir_antisymmetry_2010"} p. 398, @{cite "donnelly_using_2011"} p. 233,
@{cite "cotnoir_non-wellfounded_2012"} p. 191, @{cite "obojska_remarks_2013"} p. 344,
@{cite "cotnoir_does_2016"} p. 128 and @{cite "cotnoir_is_2018"}.} \<close>

locale M1 = PM +
  assumes nmp_eq: "PP x y \<longleftrightarrow> P x y \<and> \<not> P y x"
  assumes part_antisymmetry: "P x y \<Longrightarrow> P y x \<Longrightarrow> x = y"

sublocale M \<subseteq> M1
proof
  fix x y
  show nmp_eq: "PP x y \<longleftrightarrow> P x y \<and> \<not> P y x"
  proof
    assume "PP x y"
    with nip_eq have nip: "P x y \<and> x \<noteq> y"..
    hence "x \<noteq> y"..
    from nip have "P x y"..
    moreover have "\<not> P y x"
    proof
      assume "P y x"
      with `P x y` have "x = y" by (rule part_antisymmetry)
      with `x \<noteq> y` show "False"..
    qed
    ultimately show "P x y \<and> \<not> P y x"..
  next
    assume nmp: "P x y \<and> \<not> P y x"
    hence "\<not> P y x"..
    from nmp have "P x y"..
    moreover have "x \<noteq> y"
    proof
      assume "x = y"
      hence "\<not> P y y" using `\<not> P y x` by (rule subst)
      thus "False" using part_reflexivity..
    qed
    ultimately have "P x y \<and> x \<noteq> y"..
    with nip_eq show "PP x y"..
  qed
  show  "P x y \<Longrightarrow> P y x \<Longrightarrow> x = y" using part_antisymmetry.
qed

sublocale M1 \<subseteq> M
proof
  fix x y
  show nip_eq: "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y"
  proof
    assume "PP x y"
    with nmp_eq have nmp: "P x y \<and> \<not> P y x"..
    hence "\<not> P y x"..
    from nmp have "P x y"..
    moreover have "x \<noteq> y"
    proof
      assume "x = y"
      hence "\<not> P y y" using `\<not> P y x` by (rule subst)
      thus "False" using part_reflexivity..
    qed
    ultimately show "P x y \<and> x \<noteq> y"..
  next
    assume nip: "P x y \<and> x \<noteq> y"
    hence "x \<noteq> y"..
    from nip have "P x y"..
    moreover have "\<not> P y x"
    proof
      assume "P y x"
      with `P x y` have "x = y" by (rule part_antisymmetry)
      with `x \<noteq> y` show "False"..
    qed
    ultimately have "P x y \<and> \<not> P y x"..
    with nmp_eq show "PP x y"..
  qed
  show  "P x y \<Longrightarrow> P y x \<Longrightarrow> x = y" using part_antisymmetry.
qed

text \<open> Conversely, assuming the two definitions of proper parthood are equivalent entails the antisymmetry
of parthood, leading to the second alternative axiomatization, which assumes both equivalencies.\footnote{
For this point see especially @{cite "parsons_many_2014"} pp. 9-10.} \<close>

locale M2 = PM +
  assumes nip_eq: "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y"
  assumes nmp_eq: "PP x y \<longleftrightarrow> P x y \<and> \<not> P y x"

sublocale M \<subseteq> M2
proof
  fix x y
  show "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y" using nip_eq.
  show "PP x y \<longleftrightarrow> P x y \<and> \<not> P y x" using nmp_eq.
qed

sublocale M2 \<subseteq> M
proof
  fix x y
  show "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y" using nip_eq.
  show "P x y \<Longrightarrow> P y x \<Longrightarrow> x = y"
  proof -
    assume "P x y"
    assume "P y x"
    show "x = y"
    proof (rule ccontr)
      assume "x \<noteq> y"
      with `P x y` have "P x y \<and> x \<noteq> y"..
      with nip_eq have "PP x y"..
      with nmp_eq have "P x y \<and> \<not> P y x"..
      hence "\<not> P y x"..
      thus "False" using `P y x`..
    qed
  qed
qed

text \<open> In the context of the other axioms, antisymmetry is equivalent to the extensionality of parthood,
which gives the third alternative axiomatization.\footnote{For this point see @{cite "cotnoir_antisymmetry_2010"} p. 401
and @{cite "cotnoir_non-wellfounded_2012"} p. 191-2.} \<close>

locale M3 = PM +
  assumes nip_eq: "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y"
  assumes part_extensionality: "x = y \<longleftrightarrow> (\<forall> z. P z x \<longleftrightarrow> P z y)"

sublocale M \<subseteq> M3
proof
  fix x y
  show "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y" using nip_eq.
  show part_extensionality: "x = y \<longleftrightarrow> (\<forall> z. P z x \<longleftrightarrow> P z y)"
  proof
    assume "x = y"
    moreover have "\<forall> z. P z x \<longleftrightarrow> P z x" by simp
    ultimately show "\<forall> z. P z x \<longleftrightarrow> P z y" by (rule subst)
  next
    assume z: "\<forall> z. P z x \<longleftrightarrow> P z y"
    show "x = y"
    proof (rule part_antisymmetry)
      from z have "P y x \<longleftrightarrow> P y y"..
      moreover have "P y y" by (rule part_reflexivity)
      ultimately show "P y x"..
    next
      from z have "P x x \<longleftrightarrow> P x y"..
      moreover have "P x x" by (rule part_reflexivity)
      ultimately show "P x y"..
    qed
  qed
qed

sublocale M3 \<subseteq> M
proof
  fix x y
  show "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y" using nip_eq.
  show part_antisymmetry: "P x y \<Longrightarrow> P y x \<Longrightarrow> x = y"
  proof -
    assume "P x y"
    assume "P y x"
    have "\<forall> z. P z x \<longleftrightarrow> P z y"
    proof
      fix z
      show "P z x \<longleftrightarrow> P z y"
      proof
        assume "P z x"
        thus "P z y" using `P x y` by (rule part_transitivity)
      next
        assume "P z y"
        thus "P z x" using `P y x` by (rule part_transitivity)
      qed
    qed
    with part_extensionality show "x = y"..
  qed
qed

text \<open>The fourth axiomatization adopts proper parthood as primitive.\footnote{See, for example,
@{cite "simons_parts:_1987"}, p. 26 and @{cite "casati_parts_1999"} p. 37.} Improper parthood is
defined as proper parthood or identity.\<close>

locale M4 =
  assumes part_eq: "P x y \<longleftrightarrow> PP x y \<or> x = y"
  assumes  overlap_eq: "O x y \<longleftrightarrow> (\<exists> z. P z x \<and> P z y)"
  assumes proper_part_asymmetry: "PP x y \<Longrightarrow> \<not> PP y x"
  assumes proper_part_transitivity: "PP x y \<Longrightarrow> PP y z \<Longrightarrow> PP x z"
begin

lemma proper_part_irreflexivity: "\<not> PP x x"
proof
  assume "PP x x"
  hence "\<not> PP x x" by (rule proper_part_asymmetry)
  thus "False" using `PP x x`..
qed

end

sublocale M \<subseteq> M4
proof
  fix x y z
  show part_eq: "P x y \<longleftrightarrow> (PP x y \<or> x = y)"
  proof
    assume "P x y"
    show "PP x y \<or> x = y"
    proof cases
      assume "x = y"
      thus "PP x y \<or> x = y"..
    next
      assume "x \<noteq> y"
      with `P x y` have "P x y \<and> x \<noteq> y"..
      with nip_eq have "PP x y"..
      thus "PP x y \<or> x = y"..
    qed
  next
    assume "PP x y \<or> x = y"
    thus "P x y"
    proof
      assume "PP x y"
      thus "P x y" by (rule proper_implies_part)
    next
      assume "x = y"
      thus "P x y" by (rule identity_implies_part)
    qed
  qed
  show "O x y \<longleftrightarrow> (\<exists> z. P z x \<and> P z y)" using overlap_eq.
  show "PP x y \<Longrightarrow> \<not> PP y x" using proper_part_asymmetry.
  show proper_part_transitivity: "PP x y \<Longrightarrow> PP y z \<Longrightarrow> PP x z"
  proof -
    assume "PP x y"
    assume "PP y z"
    have "P x z \<and> x \<noteq> z"
    proof
      from `PP x y` have "P x y" by (rule proper_implies_part)
      moreover from `PP y z` have "P y z" by (rule proper_implies_part)
      ultimately show "P x z" by (rule part_transitivity)
    next
      show "x \<noteq> z"
      proof
        assume "x = z"
        hence "PP y x" using `PP y z` by (rule ssubst)
        hence "\<not> PP x y" by (rule proper_part_asymmetry)
        thus "False" using `PP x y`..
      qed
    qed
    with nip_eq show "PP x z"..
  qed
qed

sublocale M4 \<subseteq> M
proof
  fix x y z
  show proper_part_eq: "PP x y \<longleftrightarrow> P x y \<and> x \<noteq> y"
  proof
    assume "PP x y"
    hence "PP x y \<or> x = y"..
    with part_eq have "P x y"..
    moreover have "x \<noteq> y"
    proof
      assume "x = y"
      hence "PP y y" using `PP x y` by (rule subst)
      with proper_part_irreflexivity show "False"..
    qed
    ultimately show "P x y \<and> x \<noteq> y"..
  next
    assume rhs: "P x y \<and> x \<noteq> y"
    hence "x \<noteq> y"..
    from rhs have "P x y"..
    with part_eq have "PP x y \<or> x = y"..
    thus "PP x y"
    proof
      assume "PP x y"
      thus "PP x y".
    next
      assume "x = y"
      with `x \<noteq> y` show "PP x y"..
    qed
  qed
  show "P x x"
  proof -
    have "x = x" by (rule refl)
    hence "PP x x \<or> x = x"..
    with part_eq show "P x x"..
  qed
  show "O x y \<longleftrightarrow> (\<exists> z. P z x \<and> P z y)" using overlap_eq.
  show "P x y \<Longrightarrow> P y x \<Longrightarrow> x = y"
  proof -
    assume "P x y"
    assume "P y x"
    from part_eq have "PP x y \<or> x = y" using `P x y`..
    thus "x = y"
    proof
      assume "PP x y"
      hence "\<not> PP y x" by (rule proper_part_asymmetry)
      from part_eq have "PP y x \<or> y = x" using `P y x`..
      thus "x = y"
      proof
        assume "PP y x"
        with `\<not> PP y x` show "x = y"..
      next
        assume "y = x"
        thus "x = y"..
      qed
    qed
  qed
  show "P x y \<Longrightarrow> P y z \<Longrightarrow> P x z"
  proof -
    assume "P x y"
    assume "P y z"
    with part_eq have "PP y z \<or> y = z"..
    hence "PP x z \<or> x = z"
    proof
      assume "PP y z"
      from part_eq have "PP x y \<or> x = y" using `P x y`..
      hence "PP x z"
      proof
        assume "PP x y"
        thus "PP x z" using `PP y z` by (rule proper_part_transitivity)
      next
        assume "x = y"
        thus "PP x z" using `PP y z` by (rule ssubst)
      qed
      thus "PP x z \<or> x = z"..
    next
      assume "y = z"
      moreover from part_eq have "PP x y \<or> x = y" using `P x y`..
      ultimately show "PP x z \<or> x = z" by (rule subst)
    qed
    with part_eq show "P x z"..
  qed
qed

(*<*) end (*>*)