theory classical_axioms imports FOL
begin

lemma ax1:\<open>A\<longrightarrow>(B\<longrightarrow>A)\<close>
  apply (rule impI)
  apply (rule impI)
  apply assumption
  done

lemma ax2:\<open>(A\<longrightarrow>(B\<longrightarrow>C))\<longrightarrow>((A\<longrightarrow>B)\<longrightarrow>(A\<longrightarrow>C))\<close>
  apply (rule impI)
  apply (rule impI)
  apply (rule impI)
  apply (rule mp)
  apply (rule mp)
    apply assumption
 apply assumption
  apply (rule mp)
   apply assumption
 apply assumption
 done

lemma ax3:\<open>(A\<and>B)\<longrightarrow>A\<close>
  apply (rule impI)
  apply (rule conjE)
   apply assumption
  apply assumption
  done

lemma ax4:\<open>(A\<and>B)\<longrightarrow>B\<close>
  apply (rule impI)
  apply (rule conjE)
   apply assumption
  apply assumption
  done

lemma ax5:\<open>A\<longrightarrow>(B\<longrightarrow>(A\<and>B))\<close>
  apply (rule impI)
  apply (rule impI)
  apply (rule conjI)
   apply assumption
   apply assumption
  done

lemma ax6:\<open>A\<longrightarrow>(A\<or>B)\<close>
  apply (rule impI)
  apply (rule disjI1)
  apply assumption
  done

lemma ax7:\<open>B\<longrightarrow>(A\<or>B)\<close>
  apply (rule impI)
  apply (rule disjI2)
  apply assumption
  done

lemma ax8:\<open>(A\<longrightarrow>C)\<longrightarrow>(B\<longrightarrow>C)\<longrightarrow>(A\<or>B\<longrightarrow>C)\<close>
proof
  assume q:"(A\<longrightarrow>C)"
  show "(B \<longrightarrow> C) \<longrightarrow> A \<or> B \<longrightarrow> C"
  proof
    assume q2: "B \<longrightarrow> C"
    show "A \<or> B \<longrightarrow> C"
    apply (rule impI)
    apply (erule disjE)
    apply (rule mp ) (*[THEN swap]*)
    apply (rule q)
    apply assumption
    apply (rule mp )
    apply (rule q2)
    apply assumption
    done
  qed
qed

lemma ax9: "(A\<longrightarrow>B)\<longrightarrow>(A\<longrightarrow>~B)\<longrightarrow>~A"
apply (rule impI)
  apply (rule impI)
(*  apply (unfold not_def) *)
  apply (rule notI)
  apply (rule notE)
  apply (rule mp)
   apply assumption
   apply assumption
  apply (rule mp)
   apply assumption
   apply assumption
  done

lemma ax10: "A\<longrightarrow>~A\<longrightarrow>B"
apply (rule impI)
  apply (rule impI)
  apply (rule notE)
   apply assumption
  apply assumption
  done

lemma ax11: "A\<or>~A"
  apply (rule disjCI)
  apply (rule notnotD)
  apply assumption
  done

lemma ax12: \<open>(\<forall>x. A(x)) \<longrightarrow> A(q)\<close>
proof
  assume r: "\<forall>x. A(x)"
  show "A(q)"
    apply(rule_tac x="q" in allE)
    apply(rule r)
    apply assumption
    done
qed

lemma ax13: \<open>A(q) \<longrightarrow> (\<exists>x. A(x))\<close>
  apply(rule impI)
  apply(rule_tac x="q" in exI)
  apply assumption
  done

lemma B1: \<open>(\<forall>x. (A\<longrightarrow>B(x)))\<Longrightarrow>(A\<longrightarrow>(\<forall>x. B(x)))\<close>
  apply(rule impI)
  apply(rule allI)
  apply (rule mp)
  apply(rule allE)
  apply assumption
  apply assumption
  apply assumption
  done

lemma axB1: \<open>(\<forall>x. (A\<longrightarrow>B(x)))\<longrightarrow>(A\<longrightarrow>(\<forall>x. B(x)))\<close>
  apply(rule impI)
  apply(rule B1)
  apply assumption
  done

lemma B2: \<open>(\<forall>x. (B(x)\<longrightarrow>A))\<Longrightarrow>((\<exists>x. B(x))\<longrightarrow>A)\<close>
  apply(rule impI)
  apply(rule exE)
  apply assumption
  apply (rule mp)
  apply(rule allE)
  apply assumption
  apply assumption
  apply assumption
  done

lemma axB2: \<open>(\<forall>x. (B(x)\<longrightarrow>A))\<longrightarrow>((\<exists>x. B(x))\<longrightarrow>A)\<close>
  apply(rule impI)
  apply(rule B2)
  apply assumption
  done

lemma rB1: \<open>(\<And>z. (R \<longrightarrow> S(z))) \<Longrightarrow> (R \<longrightarrow> (\<forall>x. S(x)))\<close>
  (*apply auto*)
  apply(rule impI)
  apply(rule allI)
  apply(rule mp)
   apply assumption
   apply assumption
  done

lemma rB2: \<open>(\<And>x. (S(x) \<longrightarrow> R)) \<Longrightarrow> ((\<exists>x. S(x)) \<longrightarrow> R)\<close>
  (*apply auto*)
  apply(rule impI)
  apply(rule exE)
   apply assumption
  apply(rule mp)
  apply assumption
  apply assumption
  done

end


(*
    $Id: ex.thy,v 1.4 2012/01/04 14:35:44 webertj Exp $
    Author: Farhad Mehta
*)

header \<open> Recursive Functions and Induction: Zip \<close>

theory Zip
  imports Main
begin

text \<open>
Read the chapter about total recursive functions in the ``Tutorial on
Isabelle/HOL'' (@{text fun}, Chapter 3.5).
\<close>

text \<open>
In this exercise you will define a function @{text Zip} that merges two lists
by interleaving.
 Examples:
@{text "Zip [a1, a2, a3]  [b1, b2, b3] = [a1, b1, a2, b2, a3, b3]"}
 and
@{text "Zip [a1] [b1, b2, b3] = [a1, b1, b2, b3]"}.

Use three different approaches to define @{text Zip}:
\begin{enumerate}
\item by primitive recursion on the first list,
\item by primitive recursion on the second list,
\item by total recursion (using @{text fun}).
\end{enumerate}
\<close>

primrec zip1 :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"zip1 [] ys = ys" |
"zip1 (x#xs) ys = (if (0 < length ys)
                   then x#hd ys#zip1 xs (tl ys)
                   else (x#xs))"

lemma zip1_empty_ys_empty[simp]:"zip1 xs [] = xs"
  apply (induction xs) by auto

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

lemma zip2_empty_xs_empty[simp]:"zip2 [] ys = ys"
  apply (induction ys) by auto

fun zipr :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"zipr [] ys = ys" |
"zipr xs [] = xs" |
"zipr (x#xs) (y#ys) = x#y#zipr xs ys"

lemma zipr_xs_empty_xs[simp]:"zipr xs [] = xs"
  by (metis list.exhaust zipr.simps(1) zipr.simps(2))

text \<open>
Show that all three versions of @{text Zip} are equivalent.
\<close>

lemma zip2_eq_zipr:"zip2 xs ys = zipr xs ys"
  apply (induction xs arbitrary: ys)
   apply simp_all
  apply (case_tac ys) by auto

lemma zip1_eq_zipr:"zip1 xs ys = zipr xs ys"
  apply (induction ys arbitrary: xs)
   apply simp_all
  apply (case_tac xs) by auto

text \<open>
Show that @{text zipr} distributes over @{text append}.
\<close>

lemma "\<lbrakk>length p = length u; length q = length v\<rbrakk> \<Longrightarrow>
  zipr (p@q) (u@v) = zipr p u @ zipr q v"
  apply (induction p arbitrary: q u v)
   apply auto
  apply (case_tac u) by auto

text \<open>
{\bf Note:} For @{text fun}, the order of your equations is relevant.
If equations overlap, they will be disambiguated before they are added
to the logic.  You can have a look at these equations using @{text
"thm zipr.simps"}.
\<close>

end


theory Pow
  imports Main
begin

section {* Pow *}

fun pow :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
  "pow _ 0 = 1"
  | "pow a (Suc n') = a * pow a n'"

lemma test_pow: "pow x 0 = 1" by auto

theorem pow_0: "\<forall>x :: nat. pow x 0 = 1" by simp

end


theory Ch1InClass
imports Main
begin

primrec repeat :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat" where
  "repeat f 0 x = x" |
  "repeat f (Suc n) x = repeat f n (f x)"

abbreviation rep :: "(nat \<Rightarrow> nat) \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"
  ("_^_ _" [90,90,90] 89) where
    "f^n x \<equiv> repeat f n x"

lemma repeat_add[rule_format]:
  "\<forall> x. f^(a + b) x = f^b (f^a x)" (is "?P a")
proof (induction a)
  case 0
  show "?P 0"
  proof
    fix x
    show "f^(0 + b) x = f^b (f^0 x)" by simp
  qed
next
  case (Suc a')
  from Suc have IH: "\<forall> y. f^(a' + b) y = f^b (f^a' y)" .
  show "?P (Suc a')"
  proof
    fix x
    have "f^((Suc a') + b) x = f^(Suc (a' + b)) x" by simp
    also have "... = f^(a' + b) (f x)" by simp
    also from IH have "... = f^b (f^a' (f x))" ..
    also have "... = f^b (f^Suc a' x)" by simp
    finally show "f^(Suc a' + b) x = f^b (f^Suc a' x)" .
  qed
qed

theorem repeat_cycle: "f^n x = x \<longrightarrow> f^(m * n) x = x" (is "?P m")
proof (induction m)
  case 0
  show "?P 0"
  proof
    assume fnx: "f^n x = x"
    show "f^(0 * n) x = x" by simp
  qed
next
  case (Suc m') -- "case where m = Suc m'"
  show "?P (Suc m')"
  proof
    assume fnx: "f^n x = x"
    from Suc fnx have IH: "f^(m' * n) x = x" ..
    have "f^((Suc m') * n) x = f^(n + (m' * n)) x" by simp
    also have "... = f^(m' * n) (f^n x)" by (rule repeat_add)
    also from fnx have "... = f^(m' * n) x" by simp
    also from IH have "... = x" .
    finally show "f^(Suc m' * n) x = x" .
  qed
qed

primrec multirember :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
  "multirember a [] = []" |
  "multirember a (b#ls) = (if a = b then multirember a ls
                           else b#(multirember a ls))"

value "multirember (1::nat) [1,2]"

lemma multirember_not_member:
  "a \<notin> set (multirember a ls)" (is "?P ls")
proof (induction ls)
  case Nil
  show "?P []" by simp
next
  case (Cons x xs)
  show "?P (Cons x xs)"
  proof (cases "a = x")
    assume ax: "a = x"
    from ax
    have 1: "multirember a (x#xs) = multirember a xs" by simp
    from Cons have IH: "a \<notin> set (multirember a xs)" .
    from 1 IH show "a \<notin> set (multirember a (x # xs))" by simp
  next
    assume ax: "a \<noteq> x"
    from ax
    have 2: "multirember a (x#xs) = x#(multirember a xs)" by simp
    from Cons ax have 3: "a \<notin> set (x#multirember a xs)" by simp
    from 2 3 show "a \<notin> set (multirember a (x # xs))" by simp
  qed
qed

datatype 'a tree = Leaf | Node "'a tree" 'a "'a tree"

primrec height :: "'a tree \<Rightarrow> nat" where
  "height Leaf = 0" |
  "height (Node L x R) = 1 + max (height L) (height R)"

primrec leaves :: "'a tree \<Rightarrow> nat" where
  "leaves Leaf = 1" |
  "leaves (Node L x R) = leaves L + leaves R"

(* Finished here on 1/15/2014 *)

theorem height_less_leaves: "height t + 1 \<le> leaves t"
proof (induction t)
  case Leaf
  show "height Leaf + 1 \<le> leaves Leaf" sorry
next
  case (Node T1 a T2)
  show "height (Node T1 a T2) + 1 \<le> leaves (Node T1 a T2)" sorry
qed

primrec keys :: "nat tree \<Rightarrow> nat set" where
  "keys Leaf = {}" |
  "keys (Node L x R) = keys L \<union> {x} \<union> keys R"

inductive_set BST :: "(nat tree) set" where
  bst_leaf[intro!]: "Leaf \<in> BST" |
  bst_node[intro!]: "\<lbrakk> \<forall> y \<in> keys L. y \<le> x; \<forall> z \<in> keys R. x \<le> z;
                        L \<in> BST; R \<in> BST \<rbrakk>
                        \<Longrightarrow> (Node L x R) \<in> BST"

thm BST.induct

inductive_cases inv_bst_node[elim!]: "(Node L y R) \<in> BST"

thm inv_bst_node

(* hi there, this doesn't show up in latex *)
text{*
  this shows up in the latex output
*}

primrec bst_insert :: "nat \<Rightarrow> nat tree \<Rightarrow> nat tree" where
  "bst_insert x Leaf = Node Leaf x Leaf" |
  "bst_insert x (Node L y R) =
     (if x < y then Node (bst_insert x L) y R
      else if y < x then Node L y (bst_insert x R)
      else Node L y R)"

thm tree.induct
thm BST.induct

theorem insert_bst:
  assumes tbst: "T \<in> BST" shows "bst_insert x T \<in> BST"
using tbst
proof (induction rule: BST.induct)
  case bst_leaf
  show "bst_insert x Leaf \<in> BST" by auto
next
  case (bst_node L x' R)
  from bst_node
  oops

end


theory Ex023
  imports Main
begin

lemma "(A \<longrightarrow> B)  \<longleftrightarrow> (\<not>A \<or> B)"
proof -
  {
    assume a:"A \<longrightarrow> B"
    {
      assume b:"\<not>(\<not>A \<or> B)"
      {
        assume A
        with a have B by (rule mp)
        hence "\<not>A \<or> B" by (rule disjI2)
        with b have False by contradiction
      }
      hence "\<not>A" by (rule notI)
      hence "\<not>A \<or> B" by (rule disjI1)
      with b have False by contradiction
    }
    hence "\<not>\<not>(\<not>A \<or> B)" by (rule notI)
    hence "\<not>A \<or> B" by (rule notnotD)
  }
  moreover
  {
    assume c:"\<not>A \<or> B"
    {
      assume d:"\<not>(A \<longrightarrow> B)"
      {
        assume e:A
        {
          assume "\<not>A"
          with e have False by contradiction
        }
        note f=this
        {
          assume g:B
          {
            assume A
            have B by (rule g)
          }
          hence "A \<longrightarrow> B" by (rule impI)
          with d have False by contradiction
        }
        with c and f have False by (rule disjE)
        hence B by (rule FalseE)
      }
      hence "A \<longrightarrow> B" by (rule impI)
      with d have False by contradiction
    }
    hence "\<not>\<not>(A \<longrightarrow> B)" by (rule notI)
    hence "A \<longrightarrow> B" by (rule notnotD)
  }
  ultimately show ?thesis by (rule iffI)
qed


(*
    File:     Finite_Product_Extend.thy
    Author:   Joseph Thommes, TU München; Manuel Eberl, TU München
*)
section \<open>Finite Product\<close>

theory Finite_Product_Extend
  imports IDirProds
begin

text \<open>In this section, some general facts about \<open>finprod\<close> as well as some tailored for the rest of
this entry are proven.\<close>

text \<open>It is often needed to split a product in a single factor and the rest. Thus these two lemmas.\<close>

lemma (in comm_group) finprod_minus:
  assumes "a \<in> A" "f \<in> A \<rightarrow> carrier G" "finite A"
  shows "finprod G f A = f a \<otimes> finprod G f (A - {a})"
proof -
  from assms have "A = insert a (A - {a})" by blast
  then have "finprod G f A = finprod G f (insert a (A - {a}))" by simp
  also have "\<dots> = f a \<otimes> finprod G f (A - {a})" using assms by (intro finprod_insert, auto)
  finally show ?thesis .
qed

lemma (in comm_group) finprod_minus_symm:
  assumes "a \<in> A" "f \<in> A \<rightarrow> carrier G" "finite A"
  shows "finprod G f A = finprod G f (A - {a}) \<otimes> f a"
proof -
  from assms have "A = insert a (A - {a})" by blast
  then have "finprod G f A = finprod G f (insert a (A - {a}))" by simp
  also have "\<dots> = f a \<otimes> finprod G f (A - {a})" using assms by (intro finprod_insert, auto)
  also have "\<dots> = finprod G f (A - {a}) \<otimes> f a"
    by (intro m_comm, use assms in blast, intro finprod_closed, use assms in blast)
  finally show ?thesis .
qed

text \<open>This makes it very easy to show the following trivial fact.\<close>

lemma (in comm_group) finprod_singleton:
  assumes "f x \<in> carrier G" "finprod G f {x} = a"
  shows "f x = a"
proof -
  have "finprod G f {x} = f x \<otimes> finprod G f {}" using finprod_minus[of x "{x}" f] assms by auto
  thus ?thesis using assms by simp
qed

text \<open>The finite product is consistent and closed concerning subgroups.\<close>

lemma (in comm_group) finprod_subgroup:
  assumes "f \<in> S \<rightarrow> H" "subgroup H G"
  shows "finprod G f S = finprod (G\<lparr>carrier := H\<rparr>) f S"
proof (cases "finite S")
  case True
  interpret H: comm_group "G\<lparr>carrier := H\<rparr>" using subgroup_is_comm_group[OF assms(2)] .
  show ?thesis using True assms
  proof (induction S rule: finite_induct)
    case empty
    then show ?case using finprod_empty H.finprod_empty by simp
  next
    case i: (insert x F)
    then have "finprod G f F = finprod (G\<lparr>carrier := H\<rparr>) f F" by blast
    moreover have "finprod G f (insert x F) = f x \<otimes> finprod G f F"
    proof(intro finprod_insert[OF i(1, 2), of f])
      show "f \<in> F \<rightarrow> carrier G" "f x \<in> carrier G" using i(4) subgroup.subset[OF i(5)] by blast+
    qed
    ultimately have "finprod G f (insert x F) = f x \<otimes>\<^bsub>G\<lparr>carrier := H\<rparr>\<^esub> finprod (G\<lparr>carrier := H\<rparr>) f F"
      by auto
    moreover have "finprod (G\<lparr>carrier := H\<rparr>) f (insert x F) = \<dots>"
    proof(intro H.finprod_insert[OF i(1, 2)])
      show "f \<in> F \<rightarrow> carrier (G\<lparr>carrier := H\<rparr>)" "f x \<in> carrier (G\<lparr>carrier := H\<rparr>)" using i(4) by auto
    qed
    ultimately show ?case by simp
  qed
next
  case False
  then show ?thesis unfolding finprod_def by simp
qed

lemma (in comm_group) finprod_closed_subgroup:
  assumes "subgroup H G" "f \<in> A \<rightarrow> H"
  shows "finprod G f A \<in> H"
  using assms(2)
proof (induct A rule: infinite_finite_induct)
case (infinite A)
then show ?case using subgroup.one_closed[OF assms(1)] by auto
next
  case empty
  then show ?case using subgroup.one_closed[OF assms(1)] by auto
next
  case i: (insert x F)
  from finprod_insert[OF i(1, 2), of f] i have fi: "finprod G f (insert x F) = f x \<otimes> finprod G f F"
    using subgroup.subset[OF assms(1)] by blast
  from i have "finprod G f F \<in> H" "f x \<in> H" by blast+
  with fi show ?case using subgroup.m_closed[OF assms(1)] by presburger
qed

text \<open>It also does not matter if we exponentiate all elements taking part in the product or the
result of the product.\<close>

lemma (in comm_group) finprod_exp:
  assumes "A \<subseteq> carrier G" "f \<in> A \<rightarrow> carrier G"
  shows "(finprod G f A) [^] (k::int) = finprod G ((\<lambda>a. a [^] k) \<circ> f) A"
  using assms
proof(induction A rule: infinite_finite_induct)
  case i: (insert x F)
  hence ih: "finprod G f F [^] k = finprod G ((\<lambda>a. a [^] k) \<circ> f) F" by blast
  have fpc: "finprod G f F \<in> carrier G" by (intro finprod_closed, use i in auto)
  have fxc: "f x \<in> carrier G" using i by auto
  have "finprod G f (insert x F) = f x \<otimes> finprod G f F" by (intro finprod_insert, use i in auto)
  hence "finprod G f (insert x F) [^] k = (f x \<otimes> finprod G f F) [^] k" by simp
  also have "\<dots> = f x [^] k \<otimes> finprod G f F [^] k" using fpc fxc int_pow_distrib by blast
  also have "\<dots> = ((\<lambda>a. a [^] k) \<circ> f) x \<otimes> finprod G ((\<lambda>a. a [^] k) \<circ> f) F" using ih by simp
  also have "\<dots> = finprod G ((\<lambda>a. a [^] k) \<circ> f) (insert x F)"
    by (intro finprod_insert[symmetric], use i in auto)
  finally show ?case .
qed auto

text \<open>Some lemmas concerning different combinations of functions in the usage of \<open>finprod\<close>.\<close>

lemma (in comm_group) finprod_cong_split:
  assumes "\<And>a. a \<in> A \<Longrightarrow> f a \<otimes> g a = h a"
  and "f \<in> A \<rightarrow> carrier G" "g \<in> A \<rightarrow> carrier G" "h \<in> A \<rightarrow> carrier G"
  shows "finprod G h A = finprod G f A \<otimes> finprod G g A" using assms
proof(induct A rule: infinite_finite_induct)
  case (infinite A)
  then show ?case by simp
next
  case empty
  then show ?case by simp
next
  case i: (insert x F)
  then have iH: "finprod G h F = finprod G f F \<otimes> finprod G g F" by fast
  have f: "finprod G f (insert x F) = f x \<otimes> finprod G f F"
    by (intro finprod_insert[OF i(1, 2), of f]; use i(5) in simp)
  have g: "finprod G g (insert x F) = g x \<otimes> finprod G g F"
    by (intro finprod_insert[OF i(1, 2), of g]; use i(6) in simp)
  have h: "finprod G h (insert x F) = h x \<otimes> finprod G h F"
    by (intro finprod_insert[OF i(1, 2), of h]; use i(7) in simp)
  also have "\<dots> = h x \<otimes> (finprod G f F \<otimes> finprod G g F)" using iH by argo
  also have "\<dots> = f x \<otimes> g x \<otimes> (finprod G f F \<otimes> finprod G g F)" using i(4) by simp
  also have "\<dots> = f x \<otimes> finprod G f F \<otimes> (g x \<otimes> finprod G g F)" using m_comm m_assoc i(5-7) by simp
  also have "\<dots> = finprod G f (insert x F) \<otimes> finprod G g (insert x F)" using f g by argo
  finally show ?case .
qed

lemma (in comm_group) finprod_comp:
  assumes "inj_on g A" "(f \<circ> g) ` A \<subseteq> carrier G"
  shows "finprod G f (g ` A) = finprod G (f \<circ> g) A"
  using finprod_reindex[OF _ assms(1), of f] using assms(2) unfolding comp_def by blast

text \<open>The subgroup generated by a set of generators (in an abelian group) is exactly the set of
elements that can be written as a finite product using only powers of these elements.\<close>

lemma (in comm_group) generate_eq_finprod_PiE_image:
  assumes "finite gs" "gs \<subseteq> carrier G"
  shows "generate G gs = (\<lambda>x. finprod G x gs) ` Pi\<^sub>E gs (\<lambda>a. generate G {a})" (is "?g = ?fp")
proof
  show "?g \<subseteq> ?fp"
  proof
    fix x
    assume x: "x \<in> ?g"
    thus "x \<in> ?fp"
    proof (induction rule: generate.induct)
      case one
      show ?case
      proof
        let ?r = "restrict (\<lambda>_. \<one>) gs"
        show "?r \<in> (\<Pi>\<^sub>E a\<in>gs. generate G {a})" using generate.one by auto
        show "\<one> = finprod G ?r gs" by(intro finprod_one_eqI[symmetric], simp)
      qed
    next
      case g: (incl g)
      show ?case
      proof
        let ?r = "restrict ((\<lambda>_. \<one>)(g := g)) gs"
        show "?r \<in> (\<Pi>\<^sub>E a\<in>gs. generate G {a})" using generate.one generate.incl[of g "{g}" G]
          by fastforce
        show "g = finprod G ?r gs"
        proof -
          have "finprod G ?r gs = ?r g \<otimes> finprod G ?r (gs - {g})"
            by (intro finprod_minus, use assms g in auto)
          moreover have "?r g = g" using g by simp
          moreover have "finprod G ?r (gs - {g}) = \<one>" by(rule finprod_one_eqI; use g in simp)
          ultimately show ?thesis using assms g by auto
        qed
      qed
    next
      case g: (inv g)
      show ?case
      proof
        let ?r = "restrict ((\<lambda>_. \<one>)(g := inv g)) gs"
        show "?r \<in> (\<Pi>\<^sub>E a\<in>gs. generate G {a})" using generate.one generate.inv[of g "{g}" G]
          by fastforce
        show "inv g = finprod G ?r gs"
        proof -
          have "finprod G ?r gs = ?r g \<otimes> finprod G ?r (gs - {g})"
            by (intro finprod_minus, use assms g in auto)
          moreover have "?r g = inv g" using g by simp
          moreover have "finprod G ?r (gs - {g}) = \<one>" by(rule finprod_one_eqI; use g in simp)
          ultimately show ?thesis using assms g by auto
        qed
      qed
    next
      case gh: (eng g h)
      from gh obtain i where i: "i \<in> (\<Pi>\<^sub>E a\<in>gs. generate G {a})" "g = finprod G i gs" by blast
      from gh obtain j where j: "j \<in> (\<Pi>\<^sub>E a\<in>gs. generate G {a})" "h = finprod G j gs" by blast
      from i j have "g \<otimes> h = finprod G i gs \<otimes> finprod G j gs" by blast
      also have "\<dots> = finprod G (\<lambda>a. i a \<otimes> j a) gs"
      proof(intro finprod_multf[symmetric]; rule)
        fix x
        assume x: "x \<in> gs"
        have "i x \<in> generate G {x}" "j x \<in> generate G {x}"using i(1) j(1) x by blast+
        thus "i x \<in> carrier G" "j x \<in> carrier G" using generate_incl[of "{x}"] x assms(2) by blast+
      qed
      also have "\<dots> = finprod G (restrict (\<lambda>a. i a \<otimes> j a) gs) gs"
      proof(intro finprod_cong)
        have ip: "i g \<in> generate G {g}" if "g \<in> gs" for g using i that by auto
        have jp: "j g \<in> generate G {g}" if "g \<in> gs" for g using j that by auto
        have "i g \<otimes> j g \<in> generate G {g}" if "g \<in> gs" for g
          using generate.eng[OF ip[OF that] jp[OF that]] .
        thus "((\<lambda>a. i a \<otimes> j a) \<in> gs \<rightarrow> carrier G) = True" using generate_incl assms(2) by blast
      qed auto
      finally have "g \<otimes> h = finprod G (restrict (\<lambda>a. i a \<otimes> j a) gs) gs" .
      moreover have "(restrict (\<lambda>a. i a \<otimes> j a) gs) \<in> (\<Pi>\<^sub>E a\<in>gs. generate G {a})"
      proof -
        have ip: "i g \<in> generate G {g}" if "g \<in> gs" for g using i that by auto
        have jp: "j g \<in> generate G {g}" if "g \<in> gs" for g using j that by auto
        have "i g \<otimes> j g \<in> generate G {g}" if "g \<in> gs" for g
          using generate.eng[OF ip[OF that] jp[OF that]] .
        thus ?thesis by auto
      qed
      ultimately show ?case using i j by blast
    qed
  qed
  show "?fp \<subseteq> ?g"
  proof
    fix x
    assume x: "x \<in> ?fp"
    then obtain f where f: "f \<in> (Pi\<^sub>E gs (\<lambda>a. generate G {a}))" "x = finprod G f gs" by blast
    have sg: "subgroup ?g G" by(intro generate_is_subgroup, fact)
    have "finprod G f gs \<in> ?g"
    proof(intro finprod_closed_subgroup[OF sg])
      have "f g \<in> generate G gs" if "g \<in> gs" for g
      proof -
        have "f g \<in> generate G {g}" using f(1) that by auto
        moreover have "generate G {g} \<subseteq> generate G gs" by(intro mono_generate, use that in simp)
        ultimately show ?thesis by fast
      qed
      thus "f \<in> gs \<rightarrow> generate G gs" by simp
    qed
    thus "x \<in> ?g" using f by blast
  qed
qed

lemma (in comm_group) generate_eq_finprod_Pi_image:
  assumes "finite gs" "gs \<subseteq> carrier G"
  shows "generate G gs = (\<lambda>x. finprod G x gs) ` Pi gs (\<lambda>a. generate G {a})" (is "?g = ?fp")
proof -
  have "(\<lambda>x. finprod G x gs) ` Pi\<^sub>E gs (\<lambda>a. generate G {a})
      = (\<lambda>x. finprod G x gs) ` Pi gs (\<lambda>a. generate G {a})"
  proof
    have "Pi\<^sub>E gs (\<lambda>a. generate G {a}) \<subseteq> Pi gs (\<lambda>a. generate G {a})" by blast
    thus "(\<lambda>x. finprod G x gs) ` Pi\<^sub>E gs (\<lambda>a. generate G {a})
        \<subseteq> (\<lambda>x. finprod G x gs) ` Pi gs (\<lambda>a. generate G {a})" by blast
    show "(\<lambda>x. finprod G x gs) ` Pi gs (\<lambda>a. generate G {a})
        \<subseteq> (\<lambda>x. finprod G x gs) ` Pi\<^sub>E gs (\<lambda>a. generate G {a})"
    proof
      fix x
      assume x: "x \<in> (\<lambda>x. finprod G x gs) ` Pi gs (\<lambda>a. generate G {a})"
      then obtain f where f: "x = finprod G f gs" "f \<in> Pi gs (\<lambda>a. generate G {a})" by blast
      moreover have "finprod G f gs = finprod G (restrict f gs) gs"
      proof(intro finprod_cong)
        have "f g \<in> carrier G" if "g \<in> gs" for g
          using that f(2) mono_generate[of "{g}" gs] generate_incl[OF assms(2)] by fast
        thus "(f \<in> gs \<rightarrow> carrier G) = True" by blast
      qed auto
      moreover have "restrict f gs \<in> Pi\<^sub>E gs (\<lambda>a. generate G {a})" using f(2) by simp
      ultimately show "x \<in> (\<lambda>x. finprod G x gs) ` Pi\<^sub>E gs (\<lambda>a. generate G {a})" by blast
    qed
  qed
  with generate_eq_finprod_PiE_image[OF assms] show ?thesis by auto
qed

lemma (in comm_group) generate_eq_finprod_Pi_int_image:
  assumes "finite gs" "gs \<subseteq> carrier G"
  shows "generate G gs = (\<lambda>x. finprod G (\<lambda>g. g [^] x g) gs) ` Pi gs (\<lambda>_. (UNIV::int set))"
proof -
  from generate_eq_finprod_Pi_image[OF assms]
  have "generate G gs = (\<lambda>x. finprod G x gs) ` (\<Pi> a\<in>gs. generate G {a})" .
  also have "\<dots> = (\<lambda>x. finprod G (\<lambda>g. g [^] x g) gs) ` Pi gs (\<lambda>_. (UNIV::int set))"
  proof(rule; rule)
    fix x
    assume x: "x \<in> (\<lambda>x. finprod G x gs) ` (\<Pi> a\<in>gs. generate G {a})"
    then obtain f where f: "f \<in> (\<Pi> a\<in>gs. generate G {a})" "x = finprod G f gs" by blast
    hence "\<exists>k::int. f a = a [^] k" if "a \<in> gs" for a using generate_pow[of a] that assms(2) by blast
    hence "\<exists>(h::'a \<Rightarrow> int). \<forall>a\<in>gs. f a = a [^] h a" by meson
    then obtain h where h: "\<forall>a\<in>gs. f a = a [^] h a" "h \<in> gs \<rightarrow> (UNIV :: int set)" by auto
    have "finprod G (\<lambda>g. g [^] h g) gs = finprod G f gs"
      by (intro finprod_cong, use int_pow_closed h assms(2) in auto)
    with f have "x = finprod G (\<lambda>g. g [^] h g) gs" by argo
    with h(2) show "x \<in> (\<lambda>x. finprod G (\<lambda>g. g [^] x g) gs) ` (gs \<rightarrow> (UNIV::int set))" by auto
  next
    fix x
    assume x: "x \<in> (\<lambda>x. finprod G (\<lambda>g. g [^] x g) gs) ` (gs \<rightarrow> (UNIV::int set))"
    then obtain h where h: "x = finprod G (\<lambda>g. g [^] h g) gs" "h \<in> gs \<rightarrow> (UNIV :: int set)" by blast
    hence "\<exists>k\<in>generate G {a}. a [^] h a = k" if "a \<in> gs" for a
      using generate_pow[of a] that assms(2) by blast
    then obtain f where f: "\<forall>a\<in>gs. a [^] h a = f a" "f \<in> (\<Pi> a\<in>gs. generate G {a})" by fast
    have "finprod G f gs = finprod G (\<lambda>g. g [^] h g) gs"
    proof(intro finprod_cong)
      have "f a \<in> carrier G" if "a \<in> gs" for a
        using generate_incl[of "{a}"] assms(2) that f(2) by fast
      thus "(f \<in> gs \<rightarrow> carrier G) = True" by blast
    qed (use f in auto)
    with h have "x = finprod G f gs" by argo
    with f(2) show "x \<in> (\<lambda>x. finprod G x gs) ` (\<Pi> a\<in>gs. generate G {a})" by blast
  qed
  finally show ?thesis .
qed

lemma (in comm_group) IDirProds_eq_finprod_PiE:
  assumes "finite I" "\<And>i. i \<in> I \<Longrightarrow> subgroup (S i) G"
  shows "IDirProds G S I = (\<lambda>x. finprod G x I) ` (Pi\<^sub>E I S)" (is "?DP = ?fp")
proof
  show "?fp \<subseteq> ?DP"
  proof
    fix x
    assume x: "x \<in> ?fp"
    then obtain f where f: "f \<in> (Pi\<^sub>E I S)" "x = finprod G f I" by blast
    have sDP: "subgroup ?DP G"
      by (intro IDirProds_is_subgroup; use subgroup.subset[OF assms(2)] in blast)
    have "finprod G f I \<in> ?DP"
    proof(intro finprod_closed_subgroup[OF sDP])
      have "f i \<in> IDirProds G S I" if "i \<in> I" for i
      proof
        show "f i \<in> (S i)" using f(1) that by auto
        show "(S i) \<subseteq> IDirProds G S I" by (intro IDirProds_incl[OF that])
      qed
      thus "f \<in> I \<rightarrow> IDirProds G S I" by simp
    qed
    thus "x \<in> ?DP" using f by blast
  qed
  show "?DP \<subseteq> ?fp"
  proof(unfold IDirProds_def; rule subsetI)
    fix x
    assume x: "x \<in> generate G (\<Union>(S ` I))"
    thus "x \<in> ?fp" using assms
    proof (induction rule: generate.induct)
      case one
      define g where g: "g = (\<lambda>x. if x \<in> I then \<one> else undefined)"
      then have "g \<in> Pi\<^sub>E I S"
        using subgroup.one_closed[OF one(2)] by auto
      moreover have "finprod G g I = \<one>" by (intro finprod_one_eqI; use g in simp)
      ultimately show ?case unfolding image_def by (auto; metis)
    next
      case i: (incl h)
      from i obtain j where j: "j \<in> I" "h \<in> (S j)" by blast
      define hf where "hf = (\<lambda>x. (if x \<in> I then \<one> else undefined))(j := h)"
      with j have "hf \<in> Pi\<^sub>E I S"
        using subgroup.one_closed[OF i(3)] by force
      moreover have "finprod G hf I = h"
      proof -
        have "finprod G hf I = hf j \<otimes> finprod G hf (I - {j})"
          by (intro finprod_minus, use assms hf_def subgroup.subset[OF i(3)[OF j(1)]] j in auto)
        moreover have "hf j = h" using hf_def by simp
        moreover have "finprod G hf (I - {j}) = \<one>" by (rule finprod_one_eqI; use hf_def in simp)
        ultimately show ?thesis using subgroup.subset[OF i(3)[OF j(1)]] j(2) by auto
      qed
      ultimately show ?case unfolding image_def by (auto; metis)
    next
      case i: (inv h)
      from i obtain j where j: "j \<in> I" "h \<in> (S j)" by blast
      have ih: "inv h \<in> (S j)" using subgroup.m_inv_closed[OF i(3)[OF j(1)] j(2)] .
      define hf where "hf = (\<lambda>x. (if x \<in> I then \<one> else undefined))(j := inv h)"
      with j ih have "hf \<in> Pi\<^sub>E I S"
        using subgroup.one_closed[OF i(3)] by force
      moreover have "finprod G hf I = inv h"
      proof -
        have "finprod G hf I = hf j \<otimes> finprod G hf (I - {j})"
          by (intro finprod_minus, use assms hf_def subgroup.subset[OF i(3)[OF j(1)]] j in auto)
        moreover have "hf j = inv h" using hf_def by simp
        moreover have "finprod G hf (I - {j}) = \<one>" by (rule finprod_one_eqI; use hf_def in simp)
        ultimately show ?thesis using subgroup.subset[OF i(3)[OF j(1)]] j(2) by auto
      qed
      ultimately show ?case unfolding image_def by (auto; metis)
    next
      case e: (eng a b)
      from e obtain f where f: "f \<in> Pi\<^sub>E I S" "a = finprod G f I" by blast
      from e obtain g where g: "g \<in> Pi\<^sub>E I S" "b = finprod G g I" by blast
      from f g have "a \<otimes> b = finprod G f I \<otimes> finprod G g I" by blast
      also have "\<dots> = finprod G (\<lambda>a. f a \<otimes> g a) I"
      proof(intro finprod_multf[symmetric])
        have "\<Union>(S ` I) \<subseteq> carrier G" using subgroup.subset[OF e(6)] by blast
        thus "f \<in> I \<rightarrow> carrier G" "g \<in> I \<rightarrow> carrier G"
          using f(1) g(1) unfolding PiE_def Pi_def by auto
      qed
      also have "\<dots> = finprod G (restrict (\<lambda>a. f a \<otimes> g a) I) I"
      proof(intro finprod_cong)
        show "I = I" by simp
        show "\<And>i. i \<in> I =simp=> f i \<otimes> g i = (\<lambda>a\<in>I. f a \<otimes> g a) i" by simp
        have fp: "f i \<in> (S i)" if "i \<in> I" for i using f that by auto
        have gp: "g i \<in> (S i)" if "i \<in> I" for i using g that by auto
        have "f i \<otimes> g i \<in> (S i)" if "i \<in> I" for i
          using subgroup.m_closed[OF e(6)[OF that] fp[OF that] gp[OF that]] .
        thus "((\<lambda>a. f a \<otimes> g a) \<in> I \<rightarrow> carrier G) = True" using subgroup.subset[OF e(6)] by auto
      qed
      finally have "a \<otimes> b = finprod G (restrict (\<lambda>a. f a \<otimes> g a) I) I" .
      moreover have "(restrict (\<lambda>a. f a \<otimes> g a) I) \<in> Pi\<^sub>E I S"
      proof -
        have fp: "f i \<in> (S i)" if "i \<in> I" for i using f that by auto
        have gp: "g i \<in> (S i)" if "i \<in> I" for i using g that by auto
        have "f i \<otimes> g i \<in> (S i)" if "i \<in> I" for i
          using subgroup.m_closed[OF e(6)[OF that] fp[OF that] gp[OF that]] .
        thus ?thesis by auto
      qed
      ultimately show ?case using f g by blast
    qed
  qed
qed

lemma (in comm_group) IDirProds_eq_finprod_Pi:
  assumes "finite I" "\<And>i. i \<in> I \<Longrightarrow> subgroup (S i) G"
  shows "IDirProds G S I = (\<lambda>x. finprod G x I) ` (Pi I S)" (is "?DP = ?fp")
proof -
  have "(\<lambda>x. finprod G x I) ` (Pi I S) = (\<lambda>x. finprod G x I) ` (Pi\<^sub>E I S)"
  proof
    have "Pi\<^sub>E I S \<subseteq> Pi I S" by blast
    thus "(\<lambda>x. finprod G x I) ` Pi\<^sub>E I S \<subseteq> (\<lambda>x. finprod G x I) ` Pi I S" by blast
    show "(\<lambda>x. finprod G x I) ` Pi I S \<subseteq> (\<lambda>x. finprod G x I) ` Pi\<^sub>E I S"
    proof
      fix x
      assume x: "x \<in> (\<lambda>x. finprod G x I) ` Pi I S"
      then obtain f where f: "x = finprod G f I" "f \<in> Pi I S" by blast
      moreover have "finprod G f I = finprod G (restrict f I) I"
        by (intro finprod_cong; use f(2) subgroup.subset[OF assms(2)] in fastforce)
      moreover have "restrict f I \<in> Pi\<^sub>E I S" using f(2) by simp
      ultimately show "x \<in> (\<lambda>x. finprod G x I) ` Pi\<^sub>E I S" by blast
    qed
  qed
  with IDirProds_eq_finprod_PiE[OF assms] show ?thesis by auto
qed

text \<open>If we switch one element from a set of generators, the generated set stays the same if both
elements can be generated from the others together with the switched element respectively.\<close>

lemma (in comm_group) generate_one_switched_exp_eqI:
  assumes "A \<subseteq> carrier G" "a \<in> A" "B = (A - {a}) \<union> {b}"
  and "f \<in> A \<rightarrow> (UNIV::int set)" "g \<in> B \<rightarrow> (UNIV::int set)"
  and "a = finprod G (\<lambda>x. x [^] g x) B" "b = finprod G (\<lambda>x. x [^] f x) A"
  shows "generate G A = generate G B"
proof(intro generate_one_switched_eqI[OF assms(1, 2, 3)]; cases "finite A")
  case True
  hence fB: "finite B" using assms(3) by blast
  have cB: "B \<subseteq> carrier G"
  proof -
    have "b \<in> carrier G"
      by (subst assms(7), intro finprod_closed, use assms(1, 4) int_pow_closed in fast)
    thus ?thesis using assms(1, 3) by blast
  qed
  show "a \<in> generate G B"
  proof(subst generate_eq_finprod_Pi_image[OF fB cB], rule)
    show "a = finprod G (\<lambda>x. x [^] g x) B" by fact
    have "x [^] g x \<in> generate G {x}" if "x \<in> B" for x using generate_pow[of x] cB that by blast
    thus "(\<lambda>x. x [^] g x) \<in> (\<Pi> a\<in>B. generate G {a})" unfolding Pi_def by blast
  qed
  show "b \<in> generate G A"
  proof(subst generate_eq_finprod_Pi_image[OF True assms(1)], rule)
    show "b = finprod G (\<lambda>x. x [^] f x) A" by fact
    have "x [^] f x \<in> generate G {x}" if "x \<in> A" for x
      using generate_pow[of x] assms(1) that by blast
    thus "(\<lambda>x. x [^] f x) \<in> (\<Pi> a\<in>A. generate G {a})" unfolding Pi_def by blast
  qed
next
  case False
  hence b: "b = \<one>" using assms(7) unfolding finprod_def by simp
  from False assms(3) have "infinite B" by simp
  hence a: "a = \<one>" using assms(6) unfolding finprod_def by simp
  show "a \<in> generate G B" using generate.one a by blast
  show "b \<in> generate G A" using generate.one b by blast
qed

text \<open>We can characterize a complementary family of subgroups when the only way to form the neutral
element as a product of picked elements from each subgroup is to pick the neutral element from each
subgroup.\<close>

lemma (in comm_group) compl_fam_imp_triv_finprod:
  assumes "compl_fam S I" "finite I" "\<And>i. i \<in> I \<Longrightarrow> subgroup (S i) G"
  and "finprod G f I = \<one>" "f \<in> Pi I S"
  shows "\<forall>i\<in>I. f i = \<one>"
proof (rule ccontr; clarify)
  from assms(5) have f: "f i \<in> (S i)" if "i \<in> I" for i using that by fastforce
  fix i
  assume i: "i \<in> I"
  have si: "subgroup (S i) G" using assms(3)[OF i] .
  consider (triv) "(S i) = {\<one>}" | (not_triv) "(S i) \<noteq> {\<one>}" by blast
  thus "f i = \<one>"
  proof (cases)
    case triv
    then show ?thesis using f[OF i] by blast
  next
    case not_triv
    show ?thesis
    proof (rule ccontr)
      have fc: "f i \<in> carrier G" using f[OF i] subgroup.subset[OF si] by blast
      assume no: "f i \<noteq> \<one>"
      have fH: "f i \<in> (S i)" using f[OF i] .
      from subgroup.m_inv_closed[OF si this] have ifi: "inv (f i) \<in> (S i)" .
      moreover have "inv (f i) \<noteq> \<one>" using no fc by simp
      moreover have "inv (f i) = finprod G f (I - {i})"
      proof -
        have "\<one> = finprod G f I" using assms(4) by simp
        also have "\<dots> = finprod G f (insert i (I - {i}))"
        proof -
          have "I = insert i (I - {i})" using i by fast
          thus ?thesis by simp
        qed
        also have "\<dots> = f i \<otimes> finprod G f (I - {i})"
        proof(intro finprod_insert)
          show "finite (I - {i})" using assms(2) by blast
          show "i \<notin> I - {i}" by blast
          show "f \<in> I - {i} \<rightarrow> carrier G" using assms(3) f subgroup.subset by blast
          show "f i \<in> carrier G" by fact
        qed
        finally have o: "\<one> = f i \<otimes> finprod G f (I - {i})" .
        show ?thesis
        proof(intro inv_equality)
          show "f i \<in> carrier G" by fact
          show "finprod G f (I - {i}) \<in> carrier G"
            by (intro finprod_closed; use assms(3) f subgroup.subset in blast)
          from m_comm[OF this fc] o show "finprod G f (I - {i}) \<otimes> f i = \<one>" by simp
        qed
      qed
      moreover have "finprod G f (I - {i}) \<in> IDirProds G S (I - {i})"
      proof (intro finprod_closed_subgroup IDirProds_is_subgroup)
        show "\<Union> (S ` (I - {i})) \<subseteq> carrier G" using assms(3) subgroup.subset by auto
        have "f j \<in> (IDirProds G S (I - {i}))" if "j \<in> (I - {i})" for j
          using IDirProds_incl[OF that] f that by blast
        thus "f \<in> I - {i} \<rightarrow> IDirProds G S (I - {i})" by blast
      qed
      ultimately have "\<not>complementary (S i) (IDirProds G S (I - {i}))"
        unfolding complementary_def by auto
      thus False using assms(1) i unfolding compl_fam_def by blast
    qed
  qed
qed

lemma (in comm_group) triv_finprod_imp_compl_fam:
  assumes "finite I" "\<And>i. i \<in> I \<Longrightarrow> subgroup (S i) G"
  and "\<forall>f \<in> Pi I S. finprod G f I = \<one> \<longrightarrow> (\<forall>i\<in>I. f i = \<one>)"
  shows "compl_fam S I"
proof (unfold compl_fam_def; rule)
  fix k
  assume k: "k \<in> I"
  let ?DP = "IDirProds G S (I - {k})"
  show "complementary (S k) ?DP"
  proof (rule ccontr; unfold complementary_def)
    have sk: "subgroup (S k) G" using assms(2)[OF k] .
    have sDP: "subgroup ?DP G"
      by (intro IDirProds_is_subgroup; use subgroup.subset[OF assms(2)] in blast)
    assume a: "(S k) \<inter> IDirProds G S (I - {k}) \<noteq> {\<one>}"
    then obtain x where x: "x \<in> (S k)" "x \<in> IDirProds G S (I - {k})" "x \<noteq> \<one>"
      using subgroup.one_closed sk sDP by blast
    then have "x \<in> (\<lambda>x. finprod G x (I - {k})) ` (Pi (I - {k}) S)"
      using IDirProds_eq_finprod_Pi[of "(I - {k})"] assms(1, 2) by blast
    then obtain ht where ht: "finprod G ht (I - {k}) = x" "ht \<in> Pi (I - {k}) S" by blast
    define h where h: "h = (ht(k := inv x))"
    then have hPi: "h \<in> Pi I S" using ht subgroup.m_inv_closed[OF assms(2)[OF k] x(1)] by auto
    have "finprod G h (I - {k}) = x"
    proof (subst ht(1)[symmetric], intro finprod_cong)
      show "I - {k} = I - {k}" by simp
      show "(h \<in> I - {k} \<rightarrow> carrier G) = True" using h ht(2) subgroup.subset[OF assms(2)]
        unfolding Pi_def id_def by auto
      show "\<And>i. i \<in> I - {k} =simp=> h i = ht i" using ht(2) h by simp
    qed
    moreover have "finprod G h I = h k \<otimes> finprod G h (I - {k})"
      by (intro finprod_minus; use k assms hPi subgroup.subset[OF assms(2)] Pi_def in blast)
    ultimately have "finprod G h I = inv x \<otimes> x" using h by simp
    then have "finprod G h I = \<one>" using subgroup.subset[OF sk] x(1) by auto
    moreover have "h k \<noteq> \<one>" using h x(3) subgroup.subset[OF sk] x(1) by force
    ultimately show False using assms(3) k hPi by blast
  qed
qed

lemma (in comm_group) triv_finprod_iff_compl_fam_Pi:
  assumes "finite I" "\<And>i. i \<in> I \<Longrightarrow> subgroup (S i) G"
  shows "compl_fam S I \<longleftrightarrow> (\<forall>f \<in> Pi I S. finprod G f I = \<one> \<longrightarrow> (\<forall>i\<in>I. f i = \<one>))"
  using compl_fam_imp_triv_finprod triv_finprod_imp_compl_fam assms by blast

lemma (in comm_group) triv_finprod_iff_compl_fam_PiE:
  assumes "finite I" "\<And>i. i \<in> I \<Longrightarrow> subgroup (S i) G"
  shows "compl_fam S I \<longleftrightarrow> (\<forall>f \<in> Pi\<^sub>E I S. finprod G f I = \<one> \<longrightarrow> (\<forall>i\<in>I. f i = \<one>))"
proof
  show "compl_fam S I \<Longrightarrow> \<forall>f\<in>Pi\<^sub>E I S. finprod G f I = \<one> \<longrightarrow> (\<forall>i\<in>I. f i = \<one>)"
    using triv_finprod_iff_compl_fam_Pi[OF assms] by auto
  have "\<forall>f\<in>Pi\<^sub>E I S. finprod G f I = \<one> \<longrightarrow> (\<forall>i\<in>I. f i = \<one>)
    \<Longrightarrow> \<forall>f\<in>Pi I S. finprod G f I = \<one> \<longrightarrow> (\<forall>i\<in>I. f i = \<one>)"
  proof(rule+)
    fix f i
    assume f: "f \<in> Pi I S" "finprod G f I = \<one>" and i: "i \<in> I"
    assume allf: "\<forall>f\<in>Pi\<^sub>E I S. finprod G f I = \<one> \<longrightarrow> (\<forall>i\<in>I. f i = \<one>)"
    have "f i = restrict f I i" using i by simp
    moreover have "finprod G (restrict f I) I = finprod G f I"
      using f subgroup.subset[OF assms(2)] unfolding Pi_def by (intro finprod_cong; auto)
    moreover have "restrict f I \<in> Pi\<^sub>E I S" using f by simp
    ultimately show "f i = \<one>" using allf f i by metis
  qed
  thus "\<forall>f\<in>Pi\<^sub>E I S. finprod G f I = \<one> \<longrightarrow> (\<forall>i\<in>I. f i = \<one>) \<Longrightarrow> compl_fam S I"
    using triv_finprod_iff_compl_fam_Pi[OF assms] by presburger
qed

text \<open>The finite product also distributes when nested.\<close>

(* Manuel Eberl, TODO: move to library *)
lemma (in comm_monoid) finprod_Sigma:
  assumes "finite A" "\<And>x. x \<in> A \<Longrightarrow> finite (B x)"
  assumes "\<And>x y. x \<in> A \<Longrightarrow> y \<in> B x \<Longrightarrow> g x y \<in> carrier G"
  shows   "(\<Otimes>x\<in>A. \<Otimes>y\<in>B x. g x y) = (\<Otimes>z\<in>Sigma A B. case z of (x, y) \<Rightarrow> g x y)"
  using assms
proof (induction A rule: finite_induct)
  case (insert x A)
  have "(\<Otimes>z\<in>Sigma (insert x A) B. case z of (x, y) \<Rightarrow> g x y) =
          (\<Otimes>z\<in>Pair x ` B x. case z of (x, y) \<Rightarrow> g x y) \<otimes> (\<Otimes>z\<in>Sigma A B. case z of (x, y) \<Rightarrow> g x y)"
    unfolding Sigma_insert using insert.prems insert.hyps
    by (subst finprod_Un_disjoint) auto
  also have "(\<Otimes>z\<in>Sigma A B. case z of (x, y) \<Rightarrow> g x y) = (\<Otimes>x\<in>A. \<Otimes>y\<in>B x. g x y)"
    using insert.prems insert.hyps by (subst insert.IH [symmetric]) auto
  also have "(\<Otimes>z\<in>Pair x ` B x. case z of (x, y) \<Rightarrow> g x y) = (\<Otimes>y\<in>B x. g x y)"
    using insert.prems insert.hyps by (subst finprod_reindex) (auto intro: inj_onI)
  finally show ?case
    using insert.hyps insert.prems by simp
qed auto

text \<open>With the now proven facts, we are able to provide criterias to inductively construct a
group that is the internal direct product of a set of generators.\<close>

(* belongs to IDirProd, but uses finprod stuff *)
lemma (in comm_group) idirprod_generate_ind:
  assumes "finite gs" "gs \<subseteq> carrier G" "g \<in> carrier G"
          "is_idirprod (generate G gs) (\<lambda>g. generate G {g}) gs"
          "complementary (generate G {g}) (generate G gs)"
  shows "is_idirprod (generate G (gs \<union> {g})) (\<lambda>g. generate G {g}) (gs \<union> {g})"
proof(cases "g \<in> gs")
  case True
  hence "gs = (gs \<union> {g})" by blast
  thus ?thesis using assms(4) by auto
next
  case gngs: False
  show ?thesis
  proof (intro is_idirprod_subgroup_suffices)
    have gsgc: "gs \<union> {g} \<subseteq> carrier G" using assms(2, 3) by blast
    thus "generate G (gs \<union> {g}) = IDirProds G (\<lambda>g. generate G {g}) (gs \<union> {g})"
      unfolding IDirProds_def using generate_idem_Un by presburger
    show "\<forall>i\<in>gs \<union> {g}. subgroup (generate G {i}) G" using generate_is_subgroup gsgc by auto
    have sg: "subgroup (generate G {g}) G" by (intro generate_is_subgroup, use assms(3) in blast)
    from assms(4) is_idirprod_def have ih: "\<forall>x. x \<in> gs \<longrightarrow> generate G {x} \<lhd> G"
                                           "compl_fam (\<lambda>g. generate G {g}) gs"
      by fastforce+
    hence ca: "complementary (generate G {a}) (generate G (gs - {a}))" if "a \<in> gs" for a
      unfolding compl_fam_def IDirProds_def
      using gsgc generate_idem_Un[of "gs - {a}"] that by fastforce
    have aux: "gs \<union> {g} - {i} \<subseteq> carrier G" for i using gsgc by blast
    show "compl_fam (\<lambda>g. generate G {g}) (gs \<union> {g})"
    proof(unfold compl_fam_def IDirProds_def, subst generate_idem_Un[OF aux],
          rule, rule ccontr)
      fix h
      assume h: "h \<in> gs \<union> {g}"
      assume c: "\<not> complementary (generate G {h}) (generate G (gs \<union> {g} - {h}))"
      show "False"
      proof (cases "h = g")
        case True
        with c have "\<not> complementary (generate G {g}) (generate G (gs - {g}))" by auto
        moreover have "complementary (generate G {g}) (generate G (gs - {g}))"
          by (rule subgroup_subset_complementary[OF generate_is_subgroup generate_is_subgroup[of gs]
                   generate_is_subgroup mono_generate], use assms(2, 3, 5) in auto)
        ultimately show False by blast
      next
        case hng: False
        hence h: "h \<in> gs" "h \<noteq> g" using h by blast+
        hence "gs \<union> {g} - {h} = gs - {h} \<union> {g}" by blast
        with c have c: "\<not> complementary (generate G {h}) (generate G (gs - {h} \<union> {g}))" by argo
        then obtain k where k: "k \<in> generate G {h}" "k \<in> generate G (gs - {h} \<union> {g})" "k \<noteq> \<one>"
          unfolding complementary_def using generate.one by blast
        with ca have kngh: "k \<notin> generate G (gs - {h})" using h unfolding complementary_def by blast
        from k(2) generate_eq_finprod_PiE_image[of "gs - {h} \<union> {g}"] assms(1) gsgc
        obtain f where f:
          "k = finprod G f (gs - {h} \<union> {g})" "f \<in> (\<Pi>\<^sub>E a\<in>gs - {h} \<union> {g}. generate G {a})"
          by blast
        have fg: "f a \<in> generate G {a}" if "a \<in> (gs - {h} \<union> {g})" for a using that f(2) by blast
        have fc: "f a \<in> carrier G" if "a \<in> (gs - {h} \<union> {g})" for a
        proof -
          have "generate G {a} \<subseteq> carrier G" if "a \<in> (gs - {h} \<union> {g})" for a
            using that generate_incl[of "{a}"] gsgc by blast
          thus "f a \<in> carrier G" using that fg by auto
        qed
        have kp: "k = f g \<otimes> finprod G f (gs - {h})"
        proof -
          have "(gs - {h} \<union> {g}) = insert g (gs - {h})" by fast
          moreover have "finprod G f (insert g (gs - {h})) = f g \<otimes> finprod G f (gs - {h})"
            by (intro finprod_insert, use fc assms(1) gngs in auto)
          ultimately show ?thesis using f(1) by argo
        qed
        have fgsh: "finprod G f (gs - {h}) \<in> generate G (gs - {h})"
        proof(intro finprod_closed_subgroup[OF generate_is_subgroup])
          show "gs - {h} \<subseteq> carrier G" using gsgc by blast
          have "f a \<in> generate G (gs - {h})" if "a \<in> (gs - {h})" for a
            using mono_generate[of "{a}" "gs - {h}"] fg that by blast
          thus "f \<in> gs - {h} \<rightarrow> generate G (gs - {h})" by blast
        qed
        have "f g \<otimes> finprod G f (gs - {h}) \<notin> generate G gs"
        proof
          assume fpgs: "f g \<otimes> finprod G f (gs - {h}) \<in> generate G gs"
          from fgsh have fgsgs: "finprod G f (gs - {h}) \<in> generate G gs"
            using mono_generate[of "gs - {h}" gs] by blast
          have fPi: "f \<in> (\<Pi> a\<in>(gs - {h}). generate G {a})" using f by blast
          have gI: "generate G (gs - {h})
                  = (\<lambda>x. finprod G x (gs - {h})) ` (\<Pi> a\<in>gs - {h}. generate G {a})"
            using generate_eq_finprod_Pi_image[of "gs - {h}"] assms(1, 2) by blast
          have fgno: "f g \<noteq> \<one>"
          proof (rule ccontr)
            assume o: "\<not> f g \<noteq> \<one>"
            hence kf: "k = finprod G f (gs - {h})" using kp finprod_closed fc by auto
            hence "k \<in> generate G (gs - {h})" using fPi gI by blast
            thus False using k ca h unfolding complementary_def by blast
          qed
          from fpgs have "f g \<in> generate G gs"
            using subgroup.mult_in_cancel_right[OF generate_is_subgroup[OF assms(2)] fc[of g] fgsgs]
            by blast
          with fgno assms(5) fg[of g] show "False" unfolding complementary_def by blast
        qed
        moreover have "k \<in> generate G gs" using k(1) mono_generate[of "{h}" gs] h(1) by blast
        ultimately show False using kp by blast
      qed
    qed
  qed
qed

end


(* Author: Tobias Nipkow *)

section "AVL Tree with Balance Factors (1)"

theory AVL_Bal_Set
imports
  Cmp
  Isin2
begin

text \<open>This version detects height increase/decrease from above via the change in balance factors.\<close>

datatype bal = Lh | Bal | Rh

type_synonym 'a tree_bal = "('a * bal) tree"

text \<open>Invariant:\<close>

fun avl :: "'a tree_bal \<Rightarrow> bool" where
"avl Leaf = True" |
"avl (Node l (a,b) r) =
  ((case b of
    Bal \<Rightarrow> height r = height l |
    Lh \<Rightarrow> height l = height r + 1 |
    Rh \<Rightarrow> height r = height l + 1)
  \<and> avl l \<and> avl r)"

subsection \<open>Code\<close>

fun is_bal where
"is_bal (Node l (a,b) r) = (b = Bal)"

fun incr where
"incr t t' = (t = Leaf \<or> is_bal t \<and> \<not> is_bal t')"

fun rot2 where
"rot2 A a B c C = (case B of
  (Node B\<^sub>1 (b, bb) B\<^sub>2) \<Rightarrow>
    let b\<^sub>1 = if bb = Rh then Lh else Bal;
        b\<^sub>2 = if bb = Lh then Rh else Bal
    in Node (Node A (a,b\<^sub>1) B\<^sub>1) (b,Bal) (Node B\<^sub>2 (c,b\<^sub>2) C))"

fun balL :: "'a tree_bal \<Rightarrow> 'a \<Rightarrow> bal \<Rightarrow> 'a tree_bal \<Rightarrow> 'a tree_bal" where
"balL AB c bc C = (case bc of
     Bal \<Rightarrow> Node AB (c,Lh) C |
     Rh \<Rightarrow> Node AB (c,Bal) C |
     Lh \<Rightarrow> (case AB of
       Node A (a,Lh) B \<Rightarrow> Node A (a,Bal) (Node B (c,Bal) C) |
       Node A (a,Bal) B \<Rightarrow> Node A (a,Rh) (Node B (c,Lh) C) |
       Node A (a,Rh) B \<Rightarrow> rot2 A a B c C))"

fun balR :: "'a tree_bal \<Rightarrow> 'a \<Rightarrow> bal \<Rightarrow> 'a tree_bal \<Rightarrow> 'a tree_bal" where
"balR A a ba BC = (case ba of
     Bal \<Rightarrow> Node A (a,Rh) BC |
     Lh \<Rightarrow> Node A (a,Bal) BC |
     Rh \<Rightarrow> (case BC of
       Node B (c,Rh) C \<Rightarrow> Node (Node A (a,Bal) B) (c,Bal) C |
       Node B (c,Bal) C \<Rightarrow> Node (Node A (a,Rh) B) (c,Lh) C |
       Node B (c,Lh) C \<Rightarrow> rot2 A a B c C))"

fun insert :: "'a::linorder \<Rightarrow> 'a tree_bal \<Rightarrow> 'a tree_bal" where
"insert x Leaf = Node Leaf (x, Bal) Leaf" |
"insert x (Node l (a, b) r) = (case cmp x a of
   EQ \<Rightarrow> Node l (a, b) r |
   LT \<Rightarrow> let l' = insert x l in if incr l l' then balL l' a b r else Node l' (a,b) r |
   GT \<Rightarrow> let r' = insert x r in if incr r r' then balR l a b r' else Node l (a,b) r')"

fun decr where
"decr t t' = (t \<noteq> Leaf \<and> (t' = Leaf \<or> \<not> is_bal t \<and> is_bal t'))"

fun split_max :: "'a tree_bal \<Rightarrow> 'a tree_bal * 'a" where
"split_max (Node l (a, ba) r) =
  (if r = Leaf then (l,a)
   else let (r',a') = split_max r;
            t' = if decr r r' then balL l a ba r' else Node l (a,ba) r'
        in (t', a'))"

fun delete :: "'a::linorder \<Rightarrow> 'a tree_bal \<Rightarrow> 'a tree_bal" where
"delete _ Leaf = Leaf" |
"delete x (Node l (a, ba) r) =
  (case cmp x a of
     EQ \<Rightarrow> if l = Leaf then r
           else let (l', a') = split_max l in
                if decr l l' then balR l' a' ba r else Node l' (a',ba) r |
     LT \<Rightarrow> let l' = delete x l in if decr l l' then balR l' a ba r else Node l' (a,ba) r |
     GT \<Rightarrow> let r' = delete x r in if decr r r' then balL l a ba r' else Node l (a,ba) r')"

subsection \<open>Proofs\<close>

lemmas split_max_induct = split_max.induct[case_names Node Leaf]

lemmas splits = if_splits tree.splits bal.splits

declare Let_def [simp]

subsubsection "Proofs about insertion"

lemma avl_insert: "avl t \<Longrightarrow>
  avl(insert x t) \<and>
  height(insert x t) = height t + (if incr t (insert x t) then 1 else 0)"
apply(induction x t rule: insert.induct)
apply(auto split!: splits)
done

text \<open>The following two auxiliary lemma merely simplify the proof of \<open>inorder_insert\<close>.\<close>

lemma [simp]: "avl t \<Longrightarrow> insert x t \<noteq> \<langle>l, (a, Rh), \<langle>\<rangle>\<rangle> \<and> insert x t \<noteq> \<langle>\<langle>\<rangle>, (a, Lh), r\<rangle>"
by(drule avl_insert[of _ x]) (auto split: splits)

theorem inorder_insert:
  "\<lbrakk> avl t;  sorted(inorder t) \<rbrakk> \<Longrightarrow> inorder(insert x t) = ins_list x (inorder t)"
apply(induction t)
apply (auto simp: ins_list_simps split!: splits)
done

subsubsection "Proofs about deletion"

lemma inorder_balR:
  "\<lbrakk> ba = Rh \<longrightarrow> r \<noteq> Leaf; avl r \<rbrakk>
  \<Longrightarrow> inorder (balR l a ba r) = inorder l @ a # inorder r"
by (auto split: splits)

lemma inorder_balL:
  "\<lbrakk> ba = Lh \<longrightarrow> l \<noteq> Leaf; avl l \<rbrakk>
   \<Longrightarrow> inorder (balL l a ba r) = inorder l @ a # inorder r"
by (auto split: splits)

lemma height_1_iff: "avl t \<Longrightarrow> height t = Suc 0 \<longleftrightarrow> (\<exists>x. t = Node Leaf (x,Bal) Leaf)"
by(cases t) (auto split: splits prod.splits)

lemma avl_split_max:
  "\<lbrakk> split_max t = (t',a); avl t; t \<noteq> Leaf \<rbrakk> \<Longrightarrow>
   avl t' \<and> height t = height t' + (if decr t t' then 1 else 0)"
apply(induction t arbitrary: t' a rule: split_max_induct)
 apply(auto simp: max_absorb1 max_absorb2 height_1_iff split!: splits prod.splits)
done

lemma avl_delete: "avl t \<Longrightarrow>
  avl (delete x t) \<and>
  height t = height (delete x t) + (if decr t (delete x t) then 1 else 0)"
apply(induction x t rule: delete.induct)
 apply(auto simp: max_absorb1 max_absorb2 height_1_iff dest: avl_split_max split!: splits prod.splits)
done

lemma inorder_split_maxD:
  "\<lbrakk> split_max t = (t',a); t \<noteq> Leaf; avl t \<rbrakk> \<Longrightarrow>
   inorder t' @ [a] = inorder t"
apply(induction t arbitrary: t' rule: split_max.induct)
 apply(fastforce split!: splits prod.splits)
apply simp
done

lemma neq_Leaf_if_height_neq_0: "height t \<noteq> 0 \<Longrightarrow> t \<noteq> Leaf"
by auto

lemma split_max_Leaf: "\<lbrakk> t \<noteq> Leaf; avl t \<rbrakk> \<Longrightarrow> split_max t = (\<langle>\<rangle>, x) \<longleftrightarrow> t = Node Leaf (x,Bal) Leaf"
by(cases t) (auto split: splits prod.splits)

theorem inorder_delete:
  "\<lbrakk> avl t; sorted(inorder t) \<rbrakk>  \<Longrightarrow> inorder (delete x t) = del_list x (inorder t)"
apply(induction t rule: tree2_induct)
apply(auto simp: del_list_simps inorder_balR inorder_balL avl_delete inorder_split_maxD
                 split_max_Leaf neq_Leaf_if_height_neq_0
           simp del: balL.simps balR.simps split!: splits prod.splits)
done

subsubsection \<open>Set Implementation\<close>

interpretation S: Set_by_Ordered
where empty = Leaf and isin = isin
  and insert = insert
  and delete = delete
  and inorder = inorder and inv = avl
proof (standard, goal_cases)
  case 1 show ?case by (simp)
next
  case 2 thus ?case by(simp add: isin_set_inorder)
next
  case 3 thus ?case by(simp add: inorder_insert)
next
  case 4 thus ?case by(simp add: inorder_delete)
next
  case 5 thus ?case by (simp)
next
  case 6 thus ?case by (simp add: avl_insert)
next
  case 7 thus ?case by (simp add: avl_delete)
qed

end


section\<open>Lindel\"of spaces\<close>

theory Lindelof_Spaces
imports T1_Spaces
begin

definition Lindelof_space where
  "Lindelof_space X \<equiv>
        \<forall>\<U>. (\<forall>U \<in> \<U>. openin X U) \<and> \<Union>\<U> = topspace X
            \<longrightarrow> (\<exists>\<V>. countable \<V> \<and> \<V> \<subseteq> \<U> \<and> \<Union>\<V> = topspace X)"

lemma Lindelof_spaceD:
  "\<lbrakk>Lindelof_space X; \<And>U. U \<in> \<U> \<Longrightarrow> openin X U; \<Union>\<U> = topspace X\<rbrakk>
  \<Longrightarrow> \<exists>\<V>. countable \<V> \<and> \<V> \<subseteq> \<U> \<and> \<Union>\<V> = topspace X"
  by (auto simp: Lindelof_space_def)

lemma Lindelof_space_alt:
   "Lindelof_space X \<longleftrightarrow>
        (\<forall>\<U>. (\<forall>U \<in> \<U>. openin X U) \<and> topspace X \<subseteq> \<Union>\<U>
             \<longrightarrow> (\<exists>\<V>. countable \<V> \<and> \<V> \<subseteq> \<U> \<and> topspace X \<subseteq> \<Union>\<V>))"
  unfolding Lindelof_space_def
  using openin_subset by fastforce

lemma compact_imp_Lindelof_space:
   "compact_space X \<Longrightarrow> Lindelof_space X"
  unfolding Lindelof_space_def compact_space
  by (meson uncountable_infinite)

lemma Lindelof_space_topspace_empty:
   "topspace X = {} \<Longrightarrow> Lindelof_space X"
  using compact_imp_Lindelof_space compact_space_topspace_empty by blast

lemma Lindelof_space_Union:
  assumes \<U>: "countable \<U>" and lin: "\<And>U. U \<in> \<U> \<Longrightarrow> Lindelof_space (subtopology X U)"
  shows "Lindelof_space (subtopology X (\<Union>\<U>))"
proof -
  have "\<exists>\<V>. countable \<V> \<and> \<V> \<subseteq> \<F> \<and> \<Union>\<U> \<inter> \<Union>\<V> = topspace X \<inter> \<Union>\<U>"
    if \<F>: "\<F> \<subseteq> Collect (openin X)" and UF: "\<Union>\<U> \<inter> \<Union>\<F> = topspace X \<inter> \<Union>\<U>"
    for \<F>
  proof -
    have "\<And>U. \<lbrakk>U \<in> \<U>; U \<inter> \<Union>\<F> = topspace X \<inter> U\<rbrakk>
               \<Longrightarrow> \<exists>\<V>. countable \<V> \<and> \<V> \<subseteq> \<F> \<and> U \<inter> \<Union>\<V> = topspace X \<inter> U"
      using lin \<F>
      unfolding Lindelof_space_def openin_subtopology_alt Ball_def subset_iff [symmetric]
      by (simp add: all_subset_image imp_conjL ex_countable_subset_image)
    then obtain g where g: "\<And>U. \<lbrakk>U \<in> \<U>; U \<inter> \<Union>\<F> = topspace X \<inter> U\<rbrakk>
                               \<Longrightarrow> countable (g U) \<and> (g U) \<subseteq> \<F> \<and> U \<inter> \<Union>(g U) = topspace X \<inter> U"
      by metis
    show ?thesis
    proof (intro exI conjI)
      show "countable (\<Union>(g ` \<U>))"
        using Int_commute UF g  by (fastforce intro: countable_UN [OF \<U>])
      show "\<Union>(g ` \<U>) \<subseteq> \<F>"
        using g UF by blast
      show "\<Union>\<U> \<inter> \<Union>(\<Union>(g ` \<U>)) = topspace X \<inter> \<Union>\<U>"
      proof
        show "\<Union>\<U> \<inter> \<Union>(\<Union>(g ` \<U>)) \<subseteq> topspace X \<inter> \<Union>\<U>"
          using g UF by blast
        show "topspace X \<inter> \<Union>\<U> \<subseteq> \<Union>\<U> \<inter> \<Union>(\<Union>(g ` \<U>))"
        proof clarsimp
          show "\<exists>y\<in>\<U>. \<exists>W\<in>g y. x \<in> W"
            if "x \<in> topspace X" "x \<in> V" "V \<in> \<U>" for x V
          proof -
            have "V \<inter> \<Union>\<F> = topspace X \<inter> V"
              using UF \<open>V \<in> \<U>\<close> by blast
            with that g [OF \<open>V \<in> \<U>\<close>]  show ?thesis by blast
          qed
        qed
      qed
    qed
  qed
  then show ?thesis
      unfolding Lindelof_space_def openin_subtopology_alt Ball_def subset_iff [symmetric]
      by (simp add: all_subset_image imp_conjL ex_countable_subset_image)
qed

lemma countable_imp_Lindelof_space:
  assumes "countable(topspace X)"
  shows "Lindelof_space X"
proof -
  have "Lindelof_space (subtopology X (\<Union>x \<in> topspace X. {x}))"
  proof (rule Lindelof_space_Union)
    show "countable ((\<lambda>x. {x}) ` topspace X)"
      using assms by blast
    show "Lindelof_space (subtopology X U)"
      if "U \<in> (\<lambda>x. {x}) ` topspace X" for U
    proof -
      have "compactin X U"
        using that by force
      then show ?thesis
        by (meson compact_imp_Lindelof_space compact_space_subtopology)
    qed
  qed
  then show ?thesis
    by simp
qed
lemma Lindelof_space_subtopology:
   "Lindelof_space(subtopology X S) \<longleftrightarrow>
        (\<forall>\<U>. (\<forall>U \<in> \<U>. openin X U) \<and> topspace X \<inter> S \<subseteq> \<Union>\<U>
            \<longrightarrow> (\<exists>V. countable V \<and> V \<subseteq> \<U> \<and> topspace X \<inter> S \<subseteq> \<Union>V))"
proof -
  have *: "(S \<inter> \<Union>\<U> = topspace X \<inter> S) = (topspace X \<inter> S \<subseteq> \<Union>\<U>)"
    if "\<And>x. x \<in> \<U> \<Longrightarrow> openin X x" for \<U>
    by (blast dest: openin_subset [OF that])
  moreover have "(\<V> \<subseteq> \<U> \<and> S \<inter> \<Union>\<V> = topspace X \<inter> S) = (\<V> \<subseteq> \<U> \<and> topspace X \<inter> S \<subseteq> \<Union>\<V>)"
    if "\<forall>x. x \<in> \<U> \<longrightarrow> openin X x" "topspace X \<inter> S \<subseteq> \<Union>\<U>" "countable \<V>" for \<U> \<V>
    using that * by blast
  ultimately show ?thesis
    unfolding Lindelof_space_def openin_subtopology_alt Ball_def
    apply (simp add: all_subset_image imp_conjL ex_countable_subset_image flip: subset_iff)
    apply (intro all_cong1 imp_cong ex_cong, auto)
    done
qed

lemma Lindelof_space_subtopology_subset:
   "S \<subseteq> topspace X
        \<Longrightarrow> (Lindelof_space(subtopology X S) \<longleftrightarrow>
             (\<forall>\<U>. (\<forall>U \<in> \<U>. openin X U) \<and> S \<subseteq> \<Union>\<U>
                 \<longrightarrow> (\<exists>V. countable V \<and> V \<subseteq> \<U> \<and> S \<subseteq> \<Union>V)))"
  by (metis Lindelof_space_subtopology topspace_subtopology topspace_subtopology_subset)

lemma Lindelof_space_closedin_subtopology:
  assumes X: "Lindelof_space X" and clo: "closedin X S"
  shows "Lindelof_space (subtopology X S)"
proof -
  have "S \<subseteq> topspace X"
    by (simp add: clo closedin_subset)
  then show ?thesis
  proof (clarsimp simp add: Lindelof_space_subtopology_subset)
    show "\<exists>V. countable V \<and> V \<subseteq> \<F> \<and> S \<subseteq> \<Union>V"
      if "\<forall>U\<in>\<F>. openin X U" and "S \<subseteq> \<Union>\<F>" for \<F>
    proof -
      have "\<exists>\<V>. countable \<V> \<and> \<V> \<subseteq> insert (topspace X - S) \<F> \<and> \<Union>\<V> = topspace X"
      proof (rule Lindelof_spaceD [OF X, of "insert (topspace X - S) \<F>"])
        show "openin X U"
          if "U \<in> insert (topspace X - S) \<F>" for U
          using that \<open>\<forall>U\<in>\<F>. openin X U\<close> clo by blast
        show "\<Union>(insert (topspace X - S) \<F>) = topspace X"
          apply auto
          apply (meson in_mono openin_closedin_eq that(1))
          using UnionE \<open>S \<subseteq> \<Union>\<F>\<close> by auto
      qed
      then obtain \<V> where "countable \<V>" "\<V> \<subseteq> insert (topspace X - S) \<F>" "\<Union>\<V> = topspace X"
        by metis
      with \<open>S \<subseteq> topspace X\<close>
      show ?thesis
        by (rule_tac x="(\<V> - {topspace X - S})" in exI) auto
    qed
  qed
qed

lemma Lindelof_space_continuous_map_image:
  assumes X: "Lindelof_space X" and f: "continuous_map X Y f" and fim: "f ` (topspace X) = topspace Y"
  shows "Lindelof_space Y"
proof -
  have "\<exists>\<V>. countable \<V> \<and> \<V> \<subseteq> \<U> \<and> \<Union>\<V> = topspace Y"
    if \<U>: "\<And>U. U \<in> \<U> \<Longrightarrow> openin Y U" and UU: "\<Union>\<U> = topspace Y" for \<U>
  proof -
    define \<V> where "\<V> \<equiv> (\<lambda>U. {x \<in> topspace X. f x \<in> U}) ` \<U>"
    have "\<And>V. V \<in> \<V> \<Longrightarrow> openin X V"
      unfolding \<V>_def using \<U> continuous_map f by fastforce
    moreover have "\<Union>\<V> = topspace X"
      unfolding \<V>_def using UU fim by fastforce
    ultimately have "\<exists>\<W>. countable \<W> \<and> \<W> \<subseteq> \<V> \<and> \<Union>\<W> = topspace X"
      using X by (simp add: Lindelof_space_def)
    then obtain \<C> where "countable \<C>" "\<C> \<subseteq> \<U>" and \<C>: "(\<Union>U\<in>\<C>. {x \<in> topspace X. f x \<in> U}) = topspace X"
      by (metis (no_types, lifting) \<V>_def countable_subset_image)
    moreover have "\<Union>\<C> = topspace Y"
    proof
      show "\<Union>\<C> \<subseteq> topspace Y"
        using UU \<C> \<open>\<C> \<subseteq> \<U>\<close> by fastforce
      have "y \<in> \<Union>\<C>" if "y \<in> topspace Y" for y
      proof -
        obtain x where "x \<in> topspace X" "y = f x"
          using that fim by (metis \<open>y \<in> topspace Y\<close> imageE)
        with \<C> show ?thesis by auto
      qed
      then show "topspace Y \<subseteq> \<Union>\<C>" by blast
    qed
    ultimately show ?thesis
      by blast
  qed
  then show ?thesis
    unfolding Lindelof_space_def
    by auto
qed

lemma Lindelof_space_quotient_map_image:
   "\<lbrakk>quotient_map X Y q; Lindelof_space X\<rbrakk> \<Longrightarrow> Lindelof_space Y"
  by (meson Lindelof_space_continuous_map_image quotient_imp_continuous_map quotient_imp_surjective_map)

lemma Lindelof_space_retraction_map_image:
   "\<lbrakk>retraction_map X Y r; Lindelof_space X\<rbrakk> \<Longrightarrow> Lindelof_space Y"
  using Abstract_Topology.retraction_imp_quotient_map Lindelof_space_quotient_map_image by blast

lemma locally_finite_cover_of_Lindelof_space:
  assumes X: "Lindelof_space X" and UU: "topspace X \<subseteq> \<Union>\<U>" and fin: "locally_finite_in X \<U>"
  shows "countable \<U>"
proof -
  have UU_eq: "\<Union>\<U> = topspace X"
    by (meson UU fin locally_finite_in_def subset_antisym)
  obtain T where T: "\<And>x. x \<in> topspace X \<Longrightarrow> openin X (T x) \<and> x \<in> T x \<and> finite {U \<in> \<U>. U \<inter> T x \<noteq> {}}"
    using fin unfolding locally_finite_in_def by meson
  then obtain I where "countable I" "I \<subseteq> topspace X" and I: "topspace X \<subseteq> \<Union>(T ` I)"
    using X unfolding Lindelof_space_alt
    by (drule_tac x="image T (topspace X)" in spec) (auto simp: ex_countable_subset_image)
  show ?thesis
  proof (rule countable_subset)
    have "\<And>i. i \<in> I \<Longrightarrow> countable {U \<in> \<U>. U \<inter> T i \<noteq> {}}"
      using T
      by (meson \<open>I \<subseteq> topspace X\<close> in_mono uncountable_infinite)
    then show "countable (insert {} (\<Union>i\<in>I. {U \<in> \<U>. U \<inter> T i \<noteq> {}}))"
      by (simp add: \<open>countable I\<close>)
  qed (use UU_eq I in auto)
qed

lemma Lindelof_space_proper_map_preimage:
  assumes f: "proper_map X Y f" and Y: "Lindelof_space Y"
  shows "Lindelof_space X"
proof (clarsimp simp: Lindelof_space_alt)
  show "\<exists>\<V>. countable \<V> \<and> \<V> \<subseteq> \<U> \<and> topspace X \<subseteq> \<Union>\<V>"
    if \<U>: "\<forall>U\<in>\<U>. openin X U" and sub_UU: "topspace X \<subseteq> \<Union>\<U>" for \<U>
  proof -
    have "\<exists>\<V>. finite \<V> \<and> \<V> \<subseteq> \<U> \<and> {x \<in> topspace X. f x = y} \<subseteq> \<Union>\<V>" if "y \<in> topspace Y" for y
    proof (rule compactinD)
      show "compactin X {x \<in> topspace X. f x = y}"
        using f proper_map_def that by fastforce
    qed (use sub_UU \<U> in auto)
    then obtain \<V> where \<V>: "\<And>y. y \<in> topspace Y \<Longrightarrow> finite (\<V> y) \<and> \<V> y \<subseteq> \<U> \<and> {x \<in> topspace X. f x = y} \<subseteq> \<Union>(\<V> y)"
      by meson
    define \<W> where "\<W> \<equiv> (\<lambda>y. topspace Y - image f (topspace X - \<Union>(\<V> y))) ` topspace Y"
    have "\<forall>U \<in> \<W>. openin Y U"
      using f \<U> \<V> unfolding \<W>_def proper_map_def closed_map_def
      by (simp add: closedin_diff openin_Union openin_diff subset_iff)
    moreover have "topspace Y \<subseteq> \<Union>\<W>"
      using \<V> unfolding \<W>_def by clarsimp fastforce
    ultimately have "\<exists>\<V>. countable \<V> \<and> \<V> \<subseteq> \<W> \<and> topspace Y \<subseteq> \<Union>\<V>"
      using Y by (simp add: Lindelof_space_alt)
    then obtain I where "countable I" "I \<subseteq> topspace Y"
      and I: "topspace Y \<subseteq> (\<Union>i\<in>I. topspace Y - f ` (topspace X - \<Union>(\<V> i)))"
      unfolding \<W>_def ex_countable_subset_image by metis
    show ?thesis
    proof (intro exI conjI)
      have "\<And>i. i \<in> I \<Longrightarrow> countable (\<V> i)"
        by (meson \<V> \<open>I \<subseteq> topspace Y\<close> in_mono uncountable_infinite)
      with \<open>countable I\<close> show "countable (\<Union>(\<V> ` I))"
        by auto
      show "\<Union>(\<V> ` I) \<subseteq> \<U>"
        using \<V> \<open>I \<subseteq> topspace Y\<close> by fastforce
      show "topspace X \<subseteq> \<Union>(\<Union>(\<V> ` I))"
      proof
        show "x \<in> \<Union> (\<Union> (\<V> ` I))" if "x \<in> topspace X" for x
        proof -
          have "f x \<in> topspace Y"
            by (meson f image_subset_iff proper_map_imp_subset_topspace that)
          then show ?thesis
            using that I by auto
        qed
      qed
    qed
  qed
qed

lemma Lindelof_space_perfect_map_image:
   "\<lbrakk>Lindelof_space X; perfect_map X Y f\<rbrakk> \<Longrightarrow> Lindelof_space Y"
  using Lindelof_space_quotient_map_image perfect_imp_quotient_map by blast

lemma Lindelof_space_perfect_map_image_eq:
   "perfect_map X Y f \<Longrightarrow> Lindelof_space X \<longleftrightarrow> Lindelof_space Y"
  using Lindelof_space_perfect_map_image Lindelof_space_proper_map_preimage perfect_map_def by blast

end


(*  Author:     Tobias Nipkow, 2002  *)

section "Arrow's Theorem for Utility Functions"

theory Arrow_Utility imports Complex_Main
begin

text\<open>This theory formalizes the first proof due to
Geanakoplos~\cite{Geanakoplos05}.  In contrast to the standard model
of preferences as linear orders, we model preferences as \emph{utility
functions} mapping each alternative to a real number. The type of
alternatives and voters is assumed to be finite.\<close>

typedecl alt
typedecl indi

axiomatization where
  alt3: "\<exists>a b c::alt. distinct[a,b,c]" and
  finite_alt: "finite(UNIV:: alt set)" and

  finite_indi: "finite(UNIV:: indi set)"

lemma third_alt: "a \<noteq> b \<Longrightarrow> \<exists>c::alt. distinct[a,b,c]"
using alt3 by simp metis

lemma alt2: "\<exists>b::alt. b \<noteq> a"
using alt3 by simp metis

type_synonym pref = "alt \<Rightarrow> real"
type_synonym prof = "indi \<Rightarrow> pref"

definition
 top :: "pref \<Rightarrow> alt \<Rightarrow> bool" (infixr "<\<cdot>" 60) where
"p <\<cdot> b  \<equiv>  \<forall>a. a \<noteq> b \<longrightarrow> p a < p b"

definition
 bot :: "alt \<Rightarrow> pref \<Rightarrow> bool" (infixr "\<cdot><" 60) where
"b \<cdot>< p  \<equiv>  \<forall>a. a \<noteq> b \<longrightarrow> p b < p a"

definition
 extreme :: "pref \<Rightarrow> alt \<Rightarrow> bool" where
"extreme p b  \<equiv>  b \<cdot>< p \<or> p <\<cdot> b"

abbreviation
"Extreme P b == \<forall>i. extreme (P i) b"

lemma less_if_bot[simp]: "\<lbrakk> b \<cdot>< p; x \<noteq> b \<rbrakk> \<Longrightarrow> p b < p x"
by(simp add:bot_def)

lemma [simp]: "\<lbrakk> p <\<cdot> b; x \<noteq> b \<rbrakk> \<Longrightarrow> p x < p b"
by(simp add:top_def)

lemma [simp]: assumes top: "p <\<cdot> b" shows "\<not> p b < p c"
proof (cases)
  assume "b = c" thus ?thesis by simp
next
  assume "b \<noteq> c"
  with top have "p c < p b" by (simp add:eq_sym_conv)
  thus ?thesis by simp
qed

lemma not_less_if_bot[simp]:
  assumes bot: "b \<cdot>< p" shows "\<not> p c < p b"
proof (cases)
  assume "b = c" thus ?thesis by simp
next
  assume "b \<noteq> c"
  with bot have "p b < p c" by (simp add:eq_sym_conv)
  thus ?thesis by simp
qed

lemma top_impl_not_bot[simp]: "p <\<cdot> b \<Longrightarrow> \<not> b \<cdot>< p"
by(unfold bot_def, simp add:alt2)

lemma [simp]: "extreme p b \<Longrightarrow> (\<not> p <\<cdot> b) = (b \<cdot>< p)"
apply(unfold extreme_def)
apply(fastforce dest:top_impl_not_bot)
done

lemma [simp]: "extreme p b \<Longrightarrow> (\<not> b \<cdot>< p) = (p <\<cdot> b)"
apply(unfold extreme_def)
apply(fastforce dest:top_impl_not_bot)
done

text\<open>Auxiliary construction to hide details of preference model.\<close>

definition
 mktop :: "pref \<Rightarrow> alt \<Rightarrow> pref" where
"mktop p b \<equiv> p(b := Max(range p) + 1)"

definition
 mkbot :: "pref \<Rightarrow> alt \<Rightarrow> pref" where
"mkbot p b \<equiv> p(b := Min(range p) - 1)"

definition
 between :: "pref \<Rightarrow> alt \<Rightarrow> alt \<Rightarrow> alt \<Rightarrow> pref" where
"between p a b c \<equiv> p(b := (p a + p c)/2)"

text\<open>To make things simpler:\<close>
declare between_def[simp]

lemma [simp]: "a \<noteq> b \<Longrightarrow> mktop p b a = p a"
by(simp add:mktop_def)

lemma [simp]: "a \<noteq> b \<Longrightarrow> mkbot p b a = p a"
by(simp add:mkbot_def)

lemma [simp]: "a \<noteq> b \<Longrightarrow> p a < mktop p b b"
by(simp add:mktop_def finite_alt)

lemma [simp]: "a \<noteq> b \<Longrightarrow> mkbot p b b < p a"
by(simp add:mkbot_def finite_alt)

lemma [simp]: "mktop p b <\<cdot> b"
by(simp add:mktop_def top_def finite_alt)

lemma [simp]: "\<not> b \<cdot>< mktop p b"
by(simp add:mktop_def bot_def alt2 finite_alt)

lemma [simp]: "a \<noteq> b \<Longrightarrow> \<not> P p a < mkbot (P p) b b"
proof (simp add:mkbot_def finite_alt)
  have "\<not> P p a + 1 < P p a" by simp
  thus "\<exists>x. \<not> P p a + 1 < P p x" ..
qed

text\<open>The proof starts here.\<close>

locale arrow =
fixes F :: "prof \<Rightarrow> pref"
assumes unanimity: "(\<And>i. P i a < P i b) \<Longrightarrow> F P a < F P b"
and IIA:
"(\<And>i. (P i a < P i b) = (P' i a < P' i b)) \<Longrightarrow>
 (F P a < F P b) = (F P' a < F P' b)"
begin

lemmas IIA' = IIA[THEN iffD1]

definition
 dictates :: "indi \<Rightarrow> alt \<Rightarrow> alt \<Rightarrow> bool" ("_ dictates _ < _") where
"(i dictates a < b)  \<equiv>  \<forall>P. P i a < P i b \<longrightarrow> F P a < F P b"
definition
 dictates2 :: "indi \<Rightarrow> alt \<Rightarrow> alt \<Rightarrow> bool" ("_ dictates _,_") where
"(i dictates a,b)  \<equiv>  (i dictates a < b) \<and> (i dictates b < a)"
definition
 dictatesx:: "indi \<Rightarrow> alt \<Rightarrow> bool" ("_ dictates'_except _") where
"(i dictates_except c)  \<equiv>  \<forall>a b. c \<notin> {a,b} \<longrightarrow> (i dictates a<b)"
definition
 dictator :: "indi \<Rightarrow> bool" where
"dictator i  \<equiv>  \<forall>a b. (i dictates a<b)"

definition
 pivotal :: "indi \<Rightarrow> alt \<Rightarrow> bool" where
"pivotal i b \<equiv>
 \<exists>P. Extreme P b  \<and>  b \<cdot>< P i  \<and>  b \<cdot>< F P  \<and>
     F (P(i := mktop (P i) b)) <\<cdot> b"

lemma all_top[simp]: "\<forall>i. P i <\<cdot> b \<Longrightarrow> F P <\<cdot> b"
by (unfold top_def) (simp add: unanimity)

lemma not_extreme:
  assumes nex: "\<not> extreme p b"
  shows "\<exists>a c. distinct[a,b,c] \<and> \<not> p a < p b \<and> \<not> p b < p c"
proof -
  obtain a c where abc: "a \<noteq> b \<and> \<not> p a < p b" "b \<noteq> c \<and> \<not> p b < p c"
    using nex by (unfold extreme_def top_def bot_def) fastforce
  show ?thesis
  proof (cases "a = c")
    assume "a \<noteq> c" thus ?thesis using abc by simp blast
  next
    assume ac: "a = c"
    obtain d where d: "distinct[a,b,d]" using abc third_alt by blast
    show ?thesis
    proof (cases "p b < p d")
      case False thus ?thesis using abc d by blast
    next
      case True
      hence db: "\<not> p d < p b" by arith
      from d have "distinct[d,b,c]" by(simp add:ac eq_sym_conv)
      thus ?thesis using abc db by blast
    qed
  qed
qed

lemma extremal:
  assumes extremes: "Extreme P b" shows "extreme (F P) b"
proof (rule ccontr)
  assume nec: "\<not> extreme (F P) b"
  hence "\<exists>a c. distinct[a,b,c] \<and> \<not> F P a < F P b \<and> \<not> F P b < F P c"
    by(rule not_extreme)
  then obtain a c where d: "distinct[a,b,c]" and
    ab: "\<not> F P a < F P b" and bc: "\<not> F P b < F P c" by blast
  let ?P = "\<lambda>i. if P i <\<cdot> b then between (P i) a c b
                else (P i)(c := P i a + 1)"
  have "\<not> F ?P a < F ?P b"
    using extremes d by(simp add:IIA[of _ _ _ P] ab)
  moreover have "\<not> F ?P b < F ?P c"
    using extremes d by(simp add:IIA[of _ _ _ P] bc eq_sym_conv)
  moreover have "F ?P a < F ?P c" by(rule unanimity)(insert d, simp)
  ultimately show False by arith
qed

lemma pivotal_ind: assumes fin: "finite D"
  shows "\<And>P. \<lbrakk> D = {i. b \<cdot>< P i}; Extreme P b; b \<cdot>< F P \<rbrakk>
  \<Longrightarrow> \<exists>i. pivotal i b" (is "\<And>P. ?D D P \<Longrightarrow> ?E P \<Longrightarrow> ?B P \<Longrightarrow> _")
using fin
proof (induct)
  case (empty P)
  from empty(1,2) have "\<forall>i. P i <\<cdot> b" by simp
  hence "F P <\<cdot> b" by simp
  hence False using empty by(blast dest:top_impl_not_bot)
  thus ?case ..
next
  fix D i P
  assume IH: "\<And>P. ?D D P \<Longrightarrow> ?E P \<Longrightarrow> ?B P \<Longrightarrow> \<exists>i. pivotal i b"
    and "?E P" and "?B P" and insert: "insert i D = {i. b \<cdot>< P i}" and "i \<notin> D"
  from insert have "b \<cdot>< P i" by blast
  let ?P = "P(i := mktop (P i) b)"
  show "\<exists>i. pivotal i b"
  proof (cases "F ?P <\<cdot> b")
    case True
    have "pivotal i b"
    proof -
      from \<open>?E P\<close> \<open>?B P\<close> \<open>b \<cdot>< P i\<close> True
      show ?thesis by(unfold pivotal_def, blast)
    qed
    thus ?thesis ..
  next
    case False
    have "D = {i. b \<cdot>< ?P i}"
      by (rule set_eqI) (simp add:\<open>i \<notin> D\<close>, insert insert, blast)
    moreover have "Extreme ?P b"
      using \<open>?E P\<close> by (simp add:extreme_def)
    moreover have "b \<cdot>< F ?P"
      using extremal[OF \<open>Extreme ?P b\<close>] False by(simp del:fun_upd_apply)
    ultimately show ?thesis by(rule IH)
  qed
qed

lemma pivotal_exists: "\<exists>i. pivotal i b"
proof -
  let ?P = "(\<lambda>_ a. if a=b then 0 else 1)::prof"
  have "Extreme ?P b" by(simp add:extreme_def bot_def)
  moreover have "b \<cdot>< F ?P"
    by(simp add:bot_def unanimity del: less_if_bot not_less_if_bot)
  ultimately show "\<exists>i. pivotal i b"
    by (rule pivotal_ind[OF finite_subset[OF subset_UNIV finite_indi] refl])
qed

lemma pivotal_xdictates: assumes pivo: "pivotal i b"
  shows "i dictates_except b"
proof -
  have "\<And>a c. \<lbrakk> a \<noteq> b; b \<noteq> c \<rbrakk> \<Longrightarrow> i dictates a < c"
  proof (unfold dictates_def, intro allI impI)
    fix a c and P::prof
    assume abc: "a \<noteq> b" "b \<noteq> c" and
           ac: "P i a < P i c"
    show "F P a < F P c"
    proof -
      obtain P1 P2 where
        "Extreme P1 b" and "b \<cdot>< F P1" and "b \<cdot>< P1 i" and "F P2 <\<cdot> b" and
        [simp]: "P2 = P1(i := mktop (P1 i) b)"
        using pivo by (unfold pivotal_def) fast
      let ?P = "\<lambda>j. if j=i then between (P j) a b c
                    else if P1 j <\<cdot> b then mktop (P j) b else mkbot (P j) b"
      have eq: "(F P a < F P c) = (F ?P a < F ?P c)"
        using abc by - (rule IIA, auto)
      have "F ?P a < F ?P b"
      proof (rule IIA')
        fix j show "(P2 j a < P2 j b) = (?P j a < ?P j b)"
          using \<open>Extreme P1 b\<close> by(simp add: ac)
      next
        show "F P2 a < F P2 b"
          using \<open>F P2 <\<cdot> b\<close> abc by(simp add: eq_sym_conv)
      qed
      also have "\<dots> < F ?P c"
      proof (rule IIA')
        fix j show "(P1 j b < P1 j c) = (?P j b < ?P j c)"
          using \<open>Extreme P1 b\<close> \<open>b \<cdot>< P1 i\<close> by(simp add: ac)
      next
        show "F P1 b < F P1 c"
          using \<open>b \<cdot>< F P1\<close> abc by(simp add: eq_sym_conv)
      qed
      finally show ?thesis by(simp add:eq)
    qed
  qed
  thus ?thesis  by(unfold dictatesx_def) fast
qed

lemma pivotal_is_dictator:
  assumes pivo: "pivotal i b" and ab: "a \<noteq> b" and d: "j dictates a,b"
  shows "i = j"
proof (rule ccontr)
  assume pd: "i \<noteq> j"
  obtain P1 P2 where "Extreme P1 b" and "b \<cdot>< F P1" and "F P2 <\<cdot> b" and
    P2: "P2 = P1(i := mktop (P1 i) b)"
    using pivo by (unfold pivotal_def) fast
  have "~(P1 j a < P1 j b)" (is "~ ?ab")
  proof
    assume "?ab"
    hence "F P1 a < F P1 b" using d by(simp add: dictates_def dictates2_def)
    with \<open>b \<cdot>< F P1\<close> show False by simp
  qed
  hence "P1 j b < P1 j a" using \<open>Extreme P1 b\<close>[THEN spec, of j] ab
    unfolding extreme_def top_def bot_def by metis
  hence "P2 j b < P2 j a" using pd by (simp add:P2)
  hence "F P2 b < F P2 a" using d by(simp add: dictates_def dictates2_def)
  with \<open>F P2 <\<cdot> b\<close> show False by simp
qed

theorem dictator: "\<exists>i. dictator i"
proof-
  from pivotal_exists[of b] obtain i where pivo: "pivotal i b" ..
  { fix a assume neq: "a \<noteq> b" have "i dictates a,b"
    proof -
      obtain c where dist: "distinct[a,b,c]"
        using neq third_alt by blast
      obtain j where "pivotal j c" using pivotal_exists by fast
      hence "j dictates_except c" by(rule pivotal_xdictates)
      hence b: "j dictates a,b"
        using dist by(simp add:dictatesx_def dictates2_def eq_sym_conv)
      with pivo neq have "i = j" by(rule pivotal_is_dictator)
      thus ?thesis using b by simp
    qed
  }
  with pivotal_xdictates[OF pivo] have "dictator i"
    by(simp add: dictates_def dictatesx_def dictates2_def dictator_def)
      (metis less_le)
  thus ?thesis ..
qed

end

end


theory RelyGuarantee3
  imports Language
begin

datatype 'a act = Act "'a set" "'a rel"

fun eval_word :: "'a act list \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "eval_word [] p = p"
| "eval_word (Act q x # xs) p = (if p \<subseteq> q then eval_word xs (x `` p) else {})"

lemma eval_word_empty [simp]: "eval_word xs {} = {}"
proof (induct xs)
  case Nil show ?case by simp
next
  case (Cons x xs) thus ?case by (cases x) simp
qed

lemma eval_append_word: "eval_word (xs @ ys) h = eval_word ys (eval_word xs h)"
proof (induct xs arbitrary: h)
  case Nil show ?case by simp
next
  case (Cons x xs) thus ?case
    by (cases x) simp
qed

lemma Image_continuous: "x `` (\<Union>X) = \<Union>Image x ` X"
  by auto

lemma eval_word_continuous: "eval_word w (\<Union>X) \<subseteq> \<Union>(eval_word w ` X)"
proof (induct w arbitrary: X)
  case Nil show ?case by simp
next
  case (Cons x xs)
  show ?case
  proof (induct x)
    fix p x
    {
      assume "\<Union>X \<subseteq> p"
      hence "eval_word (Act p x # xs) (\<Union>X) \<subseteq> \<Union> (eval_word (Act p x # xs) ` X)"
        apply (simp add: image_def)
        apply (subst Image_continuous)
        apply (rule order_trans[OF Cons.hyps])
        by auto
    }
    moreover
    {
      assume "\<not> (\<Union>X \<subseteq> p)"
      hence "eval_word (Act p x # xs) (\<Union>X) \<subseteq> Sup (eval_word (Act p x # xs) ` X)"
        by simp
    }
    ultimately show "eval_word (Act p x # xs) (\<Union>X) \<subseteq> Sup (eval_word (Act p x # xs) ` X)"
      by blast
  qed
qed

definition module :: "'a act lan \<Rightarrow> 'a set \<Rightarrow> 'a set" (infix "\<Colon>" 60) where
  "x \<Colon> h = Sup {eval_word w h|w. w \<in> x}"

lemma (in complete_lattice) Sup_comp_mono [intro]: "(\<And>x. P x \<Longrightarrow> f x \<le> g x) \<Longrightarrow> Sup {f x |x. P x} \<le> Sup {g x |x. P x}"
  by (auto intro: Sup_mono)

lemma (in complete_lattice) Sup_comp_conj: "Sup {f x y |x y. P x \<and> Q y} = Sup {Sup {f x y |x. P x} |y. Q y}"
  apply (rule antisym)
  apply (simp_all add: Sup_le_iff)
  apply auto
  defer
  apply (rule Sup_mono)
  apply auto
  apply (subgoal_tac "f x y \<le> Sup {f x y |y. Q y}")
  apply (erule order_trans)
  defer
  apply (metis (lifting, full_types) Sup_upper mem_Collect_eq)
  apply (rule Sup_comp_mono)
  by (metis (lifting, full_types) Sup_upper mem_Collect_eq)

lemma mod_mult: "y \<Colon> (x \<Colon> h) \<subseteq> x \<cdot> y \<Colon> h"
proof -
  have "y \<Colon> (x \<Colon> h) = \<Union>{eval_word yw (x \<Colon> h)|yw. yw \<in> y}"
    by (simp add: module_def)
  also have "... = \<Union>{eval_word yw (\<Union>{eval_word xw h|xw. xw \<in> x})|yw. yw \<in> y}"
    by (simp add: module_def)
  also have "... \<subseteq> \<Union>{\<Union>{eval_word yw (eval_word xw h)|xw. xw \<in> x}|yw. yw \<in> y}"
    apply (rule Sup_comp_mono)
    apply (rule order_trans[OF eval_word_continuous])
    by (auto simp add: image_def)
  also have "... = \<Union>{eval_word yw (eval_word xw h)|xw yw. xw \<in> x \<and> yw \<in> y}"
    by blast
  also have "... = \<Union>{eval_word (xw @ yw) h|xw yw. xw \<in> x \<and> yw \<in> y}"
    by (simp add: eval_append_word)
  also have "... = \<Union>{eval_word w h|w. w \<in> x \<cdot> y}"
    by (auto simp add: l_prod_def complex_product_def)
  also have "... = x \<cdot> y \<Colon> h"
    by (simp add: module_def)
  finally show ?thesis .
qed

lemma mod_one [simp]: "{[]} \<Colon> h = h"
  by (simp add: module_def)

lemma mod_zero [simp]: "{} \<Colon> h = {}"
  by (simp add: module_def)

lemma mod_empty [simp]: "x \<Colon> {} = {}"
  by (simp add: module_def)

lemma mod_distl: "(x \<union> y) \<Colon> h = (x \<Colon> h) \<union> (y \<Colon> h)"
proof -
  have "(x \<union> y) \<Colon> h = \<Union>{eval_word w h|w. w \<in> x \<union> y}"
    by (simp add: module_def)
  also have "... = \<Union>{eval_word w h|w. w \<in> x \<or> w \<in> y}"
    by blast
  also have "... = \<Union>{eval_word w h|w. w \<in> x} \<union> \<Union>{eval_word w h|w. w \<in> y}"
    by blast
  also have "... = (x \<Colon> h) \<union> (y \<Colon> h)"
    by (simp add: module_def)
  finally show ?thesis .
qed

find_theorems "op ``" "op \<union>"

lemma eval_word_union: "eval_word w (h \<union> g) \<subseteq> eval_word w h \<union> eval_word w g"
proof (induct w arbitrary: h g)
  case Nil show ?case by simp
next
  case (Cons w ws) thus ?case
    by (cases w) (simp add: Image_Un)
qed

lemma mod_distr: "x \<Colon> (h \<union> g) \<subseteq> (x \<Colon> h) \<union> (x \<Colon> g)"
proof -
  have "x \<Colon> (h \<union> g) = \<Union>{eval_word w (h \<union> g)|w. w \<in> x}"
    by (simp add: module_def)
  also have "... \<subseteq> \<Union>{eval_word w h \<union> eval_word w g|w. w \<in> x}"
    by (rule Sup_comp_mono) (rule eval_word_union)
  also have "... = \<Union>{eval_word w h|w. w \<in> x} \<union> \<Union>{eval_word w g|w. w \<in> x}"
    by blast
  also have "... = (x \<Colon> h) \<union> (x \<Colon> g)"
    by (simp add: module_def)
  finally show ?thesis .
qed

lemma mod_isol: "x \<subseteq> y \<Longrightarrow> x \<Colon> p \<subseteq> y \<Colon> p"
  by (auto simp add: module_def)

definition triple :: "'a set \<Rightarrow> 'a act lan \<Rightarrow> 'a set \<Rightarrow> bool"
  ("\<lbrace>_\<rbrace> _ \<lbrace>_\<rbrace>" [20,20,20] 100) where
  "\<lbrace>p\<rbrace> c \<lbrace>q\<rbrace> \<equiv> c \<Colon> p \<subseteq> q"

lemma "\<lbrace>p\<rbrace> c1 \<lbrace>q\<rbrace> \<Longrightarrow> \<lbrace>q\<rbrace> c2 \<lbrace>r\<rbrace> \<Longrightarrow> \<lbrace>p\<rbrace> c1 \<cdot> c2 \<lbrace>r\<rbrace>"
  apply (simp add: triple_def)

end


(*  Title:      FOL/ex/Natural_Numbers.thy
    Author:     Markus Wenzel, TU Munich
*)

section \<open>Natural numbers\<close>

theory Natural_Numbers
imports FOL
begin

text \<open>
  Theory of the natural numbers: Peano's axioms, primitive recursion.
  (Modernized version of Larry Paulson's theory "Nat".)  \medskip
\<close>

typedecl nat
instance nat :: "term" ..

axiomatization
  Zero :: nat    ("0") and
  Suc :: "nat => nat" and
  rec :: "[nat, 'a, [nat, 'a] => 'a] => 'a"
where
  induct [case_names 0 Suc, induct type: nat]:
    "P(0) ==> (!!x. P(x) ==> P(Suc(x))) ==> P(n)" and
  Suc_inject: "Suc(m) = Suc(n) ==> m = n" and
  Suc_neq_0: "Suc(m) = 0 ==> R" and
  rec_0: "rec(0, a, f) = a" and
  rec_Suc: "rec(Suc(m), a, f) = f(m, rec(m, a, f))"

lemma Suc_n_not_n: "Suc(k) \<noteq> k"
proof (induct k)
  show "Suc(0) \<noteq> 0"
  proof
    assume "Suc(0) = 0"
    then show False by (rule Suc_neq_0)
  qed
next
  fix n assume hyp: "Suc(n) \<noteq> n"
  show "Suc(Suc(n)) \<noteq> Suc(n)"
  proof
    assume "Suc(Suc(n)) = Suc(n)"
    then have "Suc(n) = n" by (rule Suc_inject)
    with hyp show False by contradiction
  qed
qed

definition add :: "nat => nat => nat"    (infixl "+" 60)
  where "m + n = rec(m, n, \<lambda>x y. Suc(y))"

lemma add_0 [simp]: "0 + n = n"
  unfolding add_def by (rule rec_0)

lemma add_Suc [simp]: "Suc(m) + n = Suc(m + n)"
  unfolding add_def by (rule rec_Suc)

lemma add_0_right: "m + 0 = m"
  by (induct m) simp_all

lemma add_Suc_right: "m + Suc(n) = Suc(m + n)"
  by (induct m) simp_all

lemma
  assumes "!!n. f(Suc(n)) = Suc(f(n))"
  shows "f(i + j) = i + f(j)"
  using assms by (induct i) simp_all

end