section \<open>Generalized Cantor's Theorem and Instances\<close>

theory GeneralCantor imports
  Complex_Main
  "HOL-Library.Countable"
  "HOL-Analysis.Analysis"
  "HOL-ZF.HOLZF"
  "Universal_Turing_Machine.Turing_aux"
  "Universal_Turing_Machine.TuringDecidable"
  "Universal_Turing_Machine.HaltingProblems_K_aux"
  "Universal_Turing_Machine.TuringComputable"
  "Universal_Turing_Machine.DitherTM"
  "Universal_Turing_Machine.CopyTM"
begin

text \<open>
  1. The most abstracted version of Cantor's theorem.
  S x T ---- f ----> Y
    ^                |
    |                |
(beta, Id)         alpha             S ---- beta_comp ----> T              beta \<circ> beta_comp = Id
    |                |
    |                v
    T   ---- g ----> Y
\<close>
theorem "Abstracted_Cantor":
  fixes f :: "'b \<Rightarrow> 'a \<Rightarrow> 'c" and \<alpha> :: "'c \<Rightarrow> 'c" and \<beta> :: "'a \<Rightarrow> 'b" and \<beta>_c :: "'b \<Rightarrow> 'a"
  assumes surjectivity: "surj f"
  and no_fixed_point: "\<forall>y. \<alpha> y \<noteq> y"
  and right_inverse: "\<forall>s. \<beta> (\<beta>_c s) = s"
  shows "False"
proof -
  from surjectivity have "\<forall>h :: 'a \<Rightarrow> 'c. \<exists>t. h = f t" by auto
  hence "\<exists>t. (\<alpha> \<circ> (\<lambda>t'. f (\<beta> t') t')) = f t" by simp
  then obtain t0 where "(\<alpha> \<circ> (\<lambda>t'. f (\<beta> t') t')) = f t0" ..
  hence "(\<alpha> \<circ> (\<lambda>t'. f (\<beta> t') t')) (\<beta>_c t0) = f t0 (\<beta>_c t0)" by (rule arg_cong)
  hence "\<alpha> (f t0 (\<beta>_c t0)) = f t0 (\<beta>_c t0)" using right_inverse by simp
  thus "False" using no_fixed_point by simp
qed

text \<open>
  2. An instance of the above theorem, where S = T and \<beta> = Id. Still a quite general version
  of Cantor's theorem.
  T x T ---- f ----> Y
    ^                |
    |                |
 Diagonal          alpha
    |                |
    |                v
    T   ---- g ----> Y
\<close>
theorem "Generalized_Cantor":
  fixes alpha :: "'b \<Rightarrow> 'b" and f :: "'a \<Rightarrow> 'a \<Rightarrow> 'b"
  assumes surjectivity: "surj f"
  and no_fixed_point: "\<forall>y. alpha y \<noteq> y"
  shows "False"
  apply(rule Abstracted_Cantor[of f alpha "\<lambda>x. x" "\<lambda>x. x"])
  apply(auto simp add: no_fixed_point surjectivity)
  done

text \<open>
  3. An instance of the above version of Cantor's theorem, where 'b = bool and \<alpha> = \<not>.
  Entailing the fact that no surjective functions exists from a set to its power set.
  T ---- f ----> \<P>(T)
\<close>
theorem "Classic_Cantor":
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> bool"
  assumes surjectivity: "surj f"
  shows "False"
  apply(rule Generalized_Cantor[of f Not])
  apply(auto simp add: surjectivity)
  done

text \<open>
  4. An instance of the above theorem. With the set 'a being natural numbers.
 |\<P>(\<nat>)| > |\<nat>|
\<close>
theorem "Classic_Nat_Cantor":
  fixes f :: "nat \<Rightarrow> nat \<Rightarrow> bool"
  assumes surjectivity: "surj f"
  shows "False"
  apply(rule Classic_Cantor[of f])
  apply(simp add: surjectivity)
  done

text \<open>
  5. Contrapositive of Cantor's Theorem:
  If Y is a set and there exists a set T together with a function f: T x T \<longrightarrow> Y
  such that all functions g: T \<longrightarrow> Y are representable by f, i.e. there exists
  a t in T such that g = f t, then all functions \<alpha>: Y \<longrightarrow> Y admits a fixed point.
\<close>
theorem "Contrapositive_Cantor":
  fixes f :: "'a \<Rightarrow> 'a \<Rightarrow> 'b"
  assumes surjectivity: "surj f"
  shows "\<forall>\<alpha> :: 'b \<Rightarrow> 'b. \<exists>y. \<alpha> y = y"
  by (meson Generalized_Cantor surjectivity)

text \<open>
  6. All endomorphisms admitting a fixed point means the set has only one element.
  Still, we will keep the definition of fixed points and do not make assumptions on the cardinality
  of Y. The reason being that fixed points easily generalize to categories unlike cardinality.
\<close>
lemma one_elem_to_fixed: "(\<forall>a b :: 'b. a = b) \<longrightarrow> (\<forall>\<alpha> :: 'b \<Rightarrow> 'b. \<exists>y. \<alpha> y = y)"
  by simp

lemma fixed_to_one_elem: "(\<forall>\<alpha> :: 'b \<Rightarrow> 'b. \<exists>y. \<alpha> y = y) \<longrightarrow> (\<forall>a b :: 'b. a = b)"
proof (rule ccontr)
  assume "\<not> ((\<forall>\<alpha> :: 'b \<Rightarrow> 'b. \<exists>y. \<alpha> y = y) \<longrightarrow> (\<forall>a b :: 'b. a = b))"
  hence contra: "(\<forall>\<alpha> :: 'b \<Rightarrow> 'b. \<exists>y. \<alpha> y = y) \<and> (\<exists>a b :: 'b. a \<noteq> b)" by simp
  from contra have fixed_point: "\<forall>\<alpha> :: 'b \<Rightarrow> 'b. \<exists>y. \<alpha> y = y" by simp
  from contra have diff_elem: "\<exists>a b :: 'b. a \<noteq> b" by simp
  then obtain a b where "a \<noteq> (b :: 'b)" by blast
  hence "\<exists> f :: 'b \<Rightarrow> 'b. f = (\<lambda>x. (if x = a then b else a))" by fast
  then obtain f where no_fixed_point: "\<forall>y :: 'b. f y \<noteq> y" by (metis \<open>a \<noteq> (b::'b)\<close>)
  thus "False" using fixed_point no_fixed_point by blast
qed

theorem "(\<forall>\<alpha> :: 'b \<Rightarrow> 'b. \<exists>y. \<alpha> y = y) \<longleftrightarrow> (\<forall>a b :: 'b. a = b)"
  by (metis fixed_to_one_elem)

text \<open>
 7. |\<real>| = |\<P>(\<nat>)|
\<close>

text \<open>
  7.1 Show that \<exists>f s.t. f: \<real> \<longlongrightarrow> \<P>(\<rat>) and f is injective. ==> |\<real>| \<le> 2^(\<aleph>_0)
\<close>
definition cut_set :: "real \<Rightarrow> (rat \<Rightarrow> bool)" where
"cut_set r = (\<lambda>q. of_rat q < r)"

lemma "contra_inj_cut_set": "\<forall>x y :: real. x \<noteq> y \<longrightarrow> cut_set x \<noteq> cut_set y"
  by (metis cut_set_def linorder_less_linear of_rat_dense order_less_not_sym)

lemma "inj_example_cut_set": "inj cut_set"
  by (meson contra_inj_cut_set injI)

lemma "\<exists>f :: real \<Rightarrow> (rat \<Rightarrow> bool). inj f"
  by (meson inj_example_cut_set)

text \<open>
  7.2 Show that \<exists>f s.t. f: (nat => bool) => real and f is surjective on [0, 1].
       \<Longrightarrow> 2^(\<aleph>_0) \<ge> |[0,1]|
\<close>
(*A function that is surjective on real numbers between 0 and 1: *)
definition seq_to_real :: "(nat \<Rightarrow> bool) \<Rightarrow> real" where
"seq_to_real f = \<Sum>{1/(2^n) | n. f n = True}"

(*Helper definition and functions to prove that the above function is surjective: *)
(*A function that returns the most significant binary digit for a real number between 0 and 1: *)
definition most_sig_bdig :: "real \<Rightarrow> nat" where
"most_sig_bdig x = Min {n. 1/(2^n) < x}"

definition bool_mult :: "bool \<Rightarrow> real \<Rightarrow> real" where
"bool_mult b x = (if b = False then 0 else x)"

(*A function that expands a real number between 0 and 1 to its binary representation: *)
definition binary_remainder :: "(real \<Rightarrow> nat \<Rightarrow> bool) \<Rightarrow> real \<Rightarrow> nat \<Rightarrow> real set" where
"binary_remainder bs x n = {bool_mult (bs x k)  1/(2^k) | k. 1 < k \<and> k < n}"

lemma [fundef_cong]:
  assumes "x = x'" and "n = n'" and "\<And>k. k < n \<Longrightarrow> bs x k = bs' x k"
  shows "binary_remainder bs x n = binary_remainder bs' x' n'"
  using assms unfolding binary_remainder_def
  by force

fun binary_sequence :: "real \<Rightarrow> nat \<Rightarrow> bool" where
"binary_sequence x 0 = (if most_sig_bdig x > 1 then False else True)" |
binseq_rem: "binary_sequence x (Suc n) =
  (if most_sig_bdig (x - \<Sum>(binary_remainder binary_sequence x n)) > Suc n
   then False else True)"

lemma binseq_no_rem: "binary_sequence x (Suc n) =
  (if most_sig_bdig (x - \<Sum>{bool_mult (binary_sequence x k)  1/(2^k) | k. 1 < k \<and> k < n}) > Suc n
   then False else True)"
  apply(simp add: binary_remainder_def)
  done

declare binseq_rem [simp del]
declare binseq_no_rem [simp add]

(* TODO:
lemma "\<forall>r :: real. 0 < r \<and> r < 1 \<longrightarrow> (\<exists>f :: nat \<Rightarrow> bool. seq_to_real f = r)"
*)

text \<open>
  7.3 Show that \<exists>f s.t. f: (0, 1) => real and f is surjective. f x = tan(\<pi>x - \<pi>/2).
      \<Longrightarrow> |(0, 1)| \<le> |\<real>|
\<close>
definition fitted_tan :: "real \<Rightarrow> real" where
"fitted_tan x = tan (pi*x - pi/2)"

definition fitted_arctan :: "real \<Rightarrow> real" where
"fitted_arctan x = (arctan x + pi/2) / pi"

lemma fitted_arctan: "0 < fitted_arctan y \<and> fitted_arctan y < 1 \<and> fitted_tan (fitted_arctan y) = y"
  unfolding fitted_arctan_def fitted_tan_def
  by (smt (verit) arctan divide_less_eq_1_pos divide_pos_pos field_sum_of_halves
      nonzero_mult_div_cancel_left times_divide_eq_right)

lemma fitted_reverse [simp]: "\<forall>y. fitted_tan (fitted_arctan y) = y"
  unfolding fitted_arctan_def fitted_tan_def
  by (simp add: arctan)

lemma fitted_surj [simp]: "\<forall>r. \<exists>x. fitted_tan x = r"
  using fitted_reverse by blast

lemma "fitted_tan ` {r. 0 < r \<and> r < 1} = UNIV"
  using fitted_arctan fitted_surj image_iff by fastforce

text \<open>
  8. Russel's Paradox
\<close>
(*
  In the context of Generalized_Cantor g becomes the characteristic function of sets that are not
  members of themselves, i.e. g x = True iff Not (Elem x x).

  So, if there was a set R which included all the sets that are not members of themselves then,
  Elem R = g

  But such R cannot exist as Elem is not surjective, it cannot represent g, by Classic_Cantor.
*)
lemma "Russels's_Paradox": "surj Elem \<Longrightarrow> False"
  apply (rule Classic_Cantor)
  by simp

text \<open>
  9. Counting argument to show the existence of non-r.e. languages
\<close>
instance action :: countable
  by countable_datatype

instance cell :: countable
  by countable_datatype

lemma "from_nat (to_nat (p::tprog0)) = p"
  by simp

definition "tprog0_accepts_num p n \<equiv> \<lbrace>\<lambda>tap. tap = ([], <n::nat>)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace>"

theorem "Non-re_Languages":
  assumes surjectivity: "surj tprog0_accepts_num"
  shows "False"
  apply(rule Abstracted_Cantor[of tprog0_accepts_num Not from_nat to_nat])
  apply(auto simp add: surjectivity)
  done

text \<open>
  10. Turing Machines and the Halting Problem
\<close>
lemma top_holds_for [intro, simp]: "top holds_for conf"
  apply (cases conf)
  by simp

definition "halts p ns \<equiv> \<exists>Q. \<lbrace>\<lambda>tap. tap = ([], <ns::nat>)\<rbrace> p \<lbrace>Q\<rbrace>"

lemma halts_alt_def: "halts p ns = (\<exists>n. is_final (steps0 (1, [], <ns>) p n))"
  unfolding halts_def Hoare_halt_def
  by force

lemma not_halts: "\<not> halts p ns \<longrightarrow> \<lbrace>\<lambda>tap. tap = ([], <ns::nat>)\<rbrace> p \<up>"
  using Hoare_unhaltI halts_alt_def
  by presburger

lemma not_halts_alt: "\<not> halts p ns \<longrightarrow> (\<nexists>n. is_final (steps0 (1, [], <ns>) p n))"
  using halts_def Hoare_halt_def
  by blast

definition "decides_halting H \<equiv> \<forall>(p::tprog0) (ns::nat).
  \<lbrace>\<lambda>tap. tap = ([Bk], <(tm_to_nat p, ns)>)\<rbrace>
   H
  \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <(if halts p ns then 0::nat else 1::nat)> @ Bk \<up> l)\<rbrace>"

(*------------------------------TODO: AFP entry should include this.------------------------------*)
lemma Hoare_halt_tm_impl_Hoare_halt_mk_composable0_cell_list_aux: "\<lbrace>\<lambda>tap. tap = (cl', cl)\<rbrace> tm \<lbrace>Q\<rbrace> \<Longrightarrow> \<lbrace>\<lambda>tap. tap = (cl', cl)\<rbrace> mk_composable0 tm \<lbrace>Q\<rbrace>"
  unfolding Hoare_halt_def
proof -
  assume A: "\<forall>tap. (tap = (cl', cl)) \<longrightarrow> (\<exists>n. is_final (steps0 (1, tap) tm n) \<and> Q holds_for steps0 (1, tap) tm n)"
  show "\<forall>tap. (tap = (cl', cl)) \<longrightarrow> (\<exists>n. is_final (steps0 (1, tap) (mk_composable0 tm) n) \<and> Q holds_for steps0 (1, tap) (mk_composable0 tm) n)"
  proof
    fix tap
    show "(tap = (cl', cl)) \<longrightarrow> (\<exists>n. is_final (steps0 (1, tap) (mk_composable0 tm) n) \<and> Q holds_for steps0 (1, tap) (mk_composable0 tm) n)"
    proof
      assume "tap = (cl', cl)"
      with A have "(\<exists>n. is_final (steps0 (1, tap) tm n) \<and> Q holds_for steps0 (1, tap) tm n)"
        by auto
      then obtain n where w_n: "is_final (steps0 (1, tap) tm n) \<and> Q holds_for steps0 (1, tap) tm n"
        by blast

      with \<open>tap = (cl', cl)\<close> have w_n': "is_final (steps0 (1, cl', cl) tm n) \<and> Q holds_for steps0 (1, cl', cl) tm n" by auto

      have "\<exists>n. is_final (steps0 (1, cl', cl) (mk_composable0 tm) n) \<and> Q holds_for steps0 (1, cl', cl) (mk_composable0 tm) n"

      proof (cases "\<forall>stp. steps0 (1,cl',cl) (mk_composable0 tm) stp = steps0 (1,cl', cl) tm stp")
        case True
        with w_n' have "is_final (steps0 (1, cl', cl) (mk_composable0 tm) n) \<and> Q holds_for steps0 (1, cl', cl) (mk_composable0 tm) n" by auto
        then show ?thesis by auto
      next
        case False
        then have "\<exists>stp. steps0 (1, cl', cl) (mk_composable0 tm) stp \<noteq> steps0 (1, cl', cl) tm stp" by blast
        then obtain stp where w_stp: "steps0 (1, cl', cl) (mk_composable0 tm) stp \<noteq> steps0 (1, cl', cl) tm stp" by blast

        show "\<exists>m. is_final (steps0 (1, cl', cl) (mk_composable0 tm) m) \<and> Q holds_for steps0 (1, cl', cl) (mk_composable0 tm) m"
        proof -
          from w_stp have F0: "0 < stp \<and>
                           (\<exists>fl fr.
                                   snd (steps0 (1, cl', cl) tm stp) = (fl, fr) \<and>
                                   (\<forall>i < stp. steps0 (1, cl', cl) (mk_composable0 tm) i = steps0 (1, cl', cl) tm i) \<and>
                                   (\<forall>j > stp. steps0 (1, cl', cl) tm (j) = (0, fl, fr) \<and>
                                              steps0 (1, cl', cl) (mk_composable0 tm) j =(0, fl, fr)))"
            by (rule mk_composable0_tm_at_most_one_diff')

          from F0 have "0 < stp" by auto

          from F0 obtain fl fr where w_fl_fr: "snd (steps0 (1, cl', cl) tm stp) = (fl, fr) \<and>
                                   (\<forall>i < stp. steps0 (1, cl', cl) (mk_composable0 tm) i = steps0 (1, cl', cl) tm i) \<and>
                                   (\<forall>j > stp. steps0 (1, cl', cl) tm (j) = (0, fl, fr) \<and>
                                              steps0 (1, cl', cl) (mk_composable0 tm) j =(0, fl, fr))" by blast

          have "steps0 (1, cl', cl) tm (stp+1) = steps0 (1, cl', cl) tm  n"
          proof (cases "steps0 (1, cl', cl) tm n")
            case (fields fsn fln frn)
            then have "steps0 (1, cl', cl) tm n = (fsn, fln, frn)" .
            with w_n' have "is_final (fsn, fln, frn)" by auto
            with is_final_eq have "fsn=0" by auto
            with \<open>steps0 (1, cl', cl) tm n = (fsn, fln, frn)\<close>  have "steps0 (1, cl', cl) tm n = (0, fln, frn)" by auto

            show "steps0 (1, cl', cl) tm (stp + 1) = steps0 (1, cl', cl) tm n"
            proof (cases "n \<le> stp+1")
              case True
              then have "n \<le> stp + 1" .
              show ?thesis
              proof -
                from \<open>steps0 (1, cl', cl) tm n = (0, fln, frn)\<close> and \<open>n \<le> stp + 1\<close> have "steps0 (1, cl', cl) tm (stp+1) = (0, fln, frn)"
                  by (rule stable_config_after_final_ge_2')
                with \<open>fsn=0\<close> and \<open>steps0 (1, cl', cl) tm n = (fsn, fln, frn)\<close> show ?thesis by auto
              qed
            next
              case False
              then have "stp + 1 \<le> n" by arith
              show ?thesis
              proof -
                from w_fl_fr have "steps0 (1, cl', cl) tm (stp+1) = (0, fl, fr)" by auto
                have "steps0 (1, cl', cl) tm n = (0, fl, fr)"
                proof (rule stable_config_after_final_ge_2')
                  from \<open>steps0 (1, cl', cl) tm (stp+1) = (0, fl, fr)\<close> show "steps0 (1, cl', cl) tm (stp+1) = (0, fl, fr)" by auto
                next
                  from \<open>stp + 1 \<le> n\<close> show "stp + 1 \<le> n" .
                qed
                with \<open>steps0 (1, cl', cl) tm (stp+1) = (0, fl, fr)\<close> show ?thesis by auto
              qed
            qed
          qed
          with w_n' have "is_final(steps0 (1, cl', cl) tm (stp+1)) \<and> Q holds_for steps0 (1, cl', cl) tm (stp+1)" by auto
          moreover from w_fl_fr have "steps0 (1, cl', cl) tm (stp+1) = steps0 (1, cl', cl) (mk_composable0 tm) (stp+1)" by auto
          ultimately have "is_final(steps0 (1, cl', cl) (mk_composable0 tm) (stp+1)) \<and> Q holds_for steps0 (1, cl', cl) (mk_composable0 tm) (stp+1)" by auto
          then show ?thesis by blast
        qed
      qed
      with \<open>tap = (cl', cl)\<close> show "\<exists>n. is_final (steps0 (1, tap) (mk_composable0 tm) n) \<and> Q holds_for steps0 (1, tap) (mk_composable0 tm) n" by auto
    qed
  qed
qed

theorem Hoare_halt_tm_impl_Hoare_halt_mk_composable0_cell_list_generalized: "\<lbrace>P\<rbrace> tm \<lbrace>Q\<rbrace> \<Longrightarrow> \<lbrace>P\<rbrace> mk_composable0 tm \<lbrace>Q\<rbrace>"
  using Hoare_halt_def Hoare_halt_tm_impl_Hoare_halt_mk_composable0_cell_list_aux old.prod.exhaust by auto
(*------------------------------------------------------------------------------------------------*)

lemma "halting_problem_assuming_dither_copy":
  assumes "\<exists>dither::tprog0. \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace> dither \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace>
                          \<and> \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk \<up> l)\<rbrace> dither \<up>"
  and "\<exists>copy::tprog0. \<forall>n::nat. \<lbrace>\<lambda>tap. tap = ([], <n>)\<rbrace> copy \<lbrace>\<lambda>tap. tap = ([Bk], <(n, n)>)\<rbrace>"

  shows "\<nexists>H. decides_halting H"
proof (rule ccontr)
  assume "\<not> (\<nexists>H::tprog0. decides_halting H)"
  hence "\<exists>H. decides_halting H" by simp

  then obtain H'::tprog0 where "decides_halting H'" ..
  then have "composable_tm0 (mk_composable0 H') \<and> (decides_halting (mk_composable0 H'))"
    using Hoare_halt_tm_impl_Hoare_halt_mk_composable0_cell_list_generalized composable_tm0_mk_composable0 decides_halting_def by blast
  then have "\<exists>H. composable_tm0 H \<and> decides_halting H" using decides_halting_def by blast
  then obtain H::tprog0 where h: "composable_tm0 H \<and> decides_halting H" ..

  from assms(1) obtain dither::tprog0 where d: "\<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace> dither \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace>
                                              \<and> \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk \<up> l)\<rbrace> dither \<up>" ..

  from assms(2) obtain copy'::tprog0 where "\<forall>n::nat. \<lbrace>\<lambda>tap. tap = ([], <n>)\<rbrace> copy' \<lbrace>\<lambda>tap. tap = ([Bk], <(n, n)>)\<rbrace>" ..
  then have "composable_tm0 (mk_composable0 copy')
          \<and> (\<forall>n::nat. \<lbrace>\<lambda>tap. tap = ([], <n>)\<rbrace> mk_composable0 copy' \<lbrace>\<lambda>tap. tap = ([Bk], <(n, n)>)\<rbrace>)"
    using Hoare_halt_tm_impl_Hoare_halt_mk_composable0_cell_list composable_tm0_mk_composable0 by blast
  then have "\<exists>copy. composable_tm0 copy
          \<and> (\<forall>n::nat. \<lbrace>\<lambda>tap. tap = ([], <n>)\<rbrace> copy \<lbrace>\<lambda>tap. tap = ([Bk], <(n, n)>)\<rbrace>)" by blast
  then obtain copy::tprog0 where c: "composable_tm0 copy
                                  \<and> (\<forall>n::nat. \<lbrace>\<lambda>tap. tap = ([], <n>)\<rbrace> copy \<lbrace>\<lambda>tap. tap = ([Bk], <(n, n)>)\<rbrace>)" ..

  let ?contra = "copy |+| H |+| dither"
  show "False"
  proof cases
    assume contra_halts: "halts ?contra (tm_to_nat ?contra)"

    from c have p1: "\<lbrace>\<lambda>tap. tap = ([], <tm_to_nat ?contra>)\<rbrace>
                      copy
                     \<lbrace>\<lambda>tap. tap = ([Bk], <(tm_to_nat ?contra, tm_to_nat ?contra)>)\<rbrace>" by simp
    from h contra_halts have p2: "\<lbrace>\<lambda>tap. tap = ([Bk], <(tm_to_nat ?contra, tm_to_nat ?contra)>)\<rbrace>
                                   H
                                  \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat>  @ Bk \<up> l)\<rbrace>" unfolding decides_halting_def by presburger
    from d have p3: "\<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat>  @ Bk \<up> l)\<rbrace> dither \<up>" by simp

    from c p1 p2 have p1_2: "\<lbrace>\<lambda>tap. tap = ([], <tm_to_nat ?contra>)\<rbrace>
                              copy |+| H
                             \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <0::nat> @ Bk \<up> l)\<rbrace>" using Hoare_plus_halt by blast
    from c h p1_2 p3 have "\<lbrace>\<lambda>tap. tap = ([], <tm_to_nat ?contra>)\<rbrace> ?contra \<up>"
      using Hoare_plus_unhalt decides_halting_def seq_tm_composable by blast

    then show ?thesis using contra_halts halts_def Hoare_unhalt_impl_not_Hoare_halt by blast
  next
    assume contra_unhalts: "\<not> halts ?contra (tm_to_nat ?contra)"
    hence contra_unhalts_unf: "\<lbrace>\<lambda>tap. tap = ([], <tm_to_nat ?contra>)\<rbrace> ?contra \<up>" using not_halts by blast

    from c have p1: "\<lbrace>\<lambda>tap. tap = ([], <tm_to_nat ?contra>)\<rbrace>
                      copy
                     \<lbrace>\<lambda>tap. tap = ([Bk], <(tm_to_nat ?contra, tm_to_nat ?contra)>)\<rbrace>" by simp
    from h contra_unhalts have p2: "\<lbrace>\<lambda>tap. tap = ([Bk], <(tm_to_nat ?contra, tm_to_nat ?contra)>)\<rbrace>
                                     H
                                    \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace>" unfolding decides_halting_def by presburger
    from d have p3: "\<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace> dither \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace>" by simp

    from c p1 p2 have p1_2: "\<lbrace>\<lambda>tap. tap = ([], <tm_to_nat ?contra>)\<rbrace>
                              copy |+| H
                             \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace>" using Hoare_plus_halt by blast
    from c h p1_2 p3 have "\<lbrace>\<lambda>tap. tap = ([], <tm_to_nat ?contra>)\<rbrace> ?contra \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <1::nat> @ Bk \<up> l)\<rbrace>"
      using Hoare_plus_halt decides_halting_def seq_tm_composable by blast

    then show ?thesis using contra_unhalts_unf Hoare_halt_impl_not_Hoare_unhalt by blast
  qed
qed

theorem "halting_problem": "\<nexists> H. decides_halting H"
  using One_nat_def append.simps(1) append.simps(2) replicate.simps(1) replicate.simps(2)
        tape_of_nat_def tm_copy_correct tm_dither_halts'' tm_dither_loops''
        halting_problem_assuming_dither_copy
  by auto

text \<open>
  11. Cantor in locales and a new interpretation of the halting problem.
\<close>
definition ocomp :: "(nat\<rightharpoonup>nat) \<Rightarrow> (nat\<rightharpoonup>nat) \<Rightarrow> (nat\<rightharpoonup>nat)" (infixl "\<oplus>" 55) where
"ocomp f\<^sub>1 f\<^sub>2 x = (case f\<^sub>2 x of None \<Rightarrow> None | Some y \<Rightarrow> f\<^sub>1 y)"

lemma ocomp_assoc [simp]: "a \<oplus> (b \<oplus> c) = a \<oplus> b \<oplus> c"
  unfolding ocomp_def
  by (metis option.case_eq_if)

lemma "a \<oplus> Some = a"
  unfolding ocomp_def
  using option.simps(5) by force

lemma "(\<lambda>_.None) \<oplus> a = (\<lambda>_.None)"
  unfolding ocomp_def
  by (simp add: option.case_eq_if)

lemma "a \<oplus> (\<lambda>_.None) = (\<lambda>_.None)"
  unfolding ocomp_def
  by (simp add: option.case_eq_if)

locale computable_universe_carrier =
  fixes F :: "(nat\<rightharpoonup>nat) set"
  fixes pull_up :: "(nat\<rightharpoonup>nat) \<Rightarrow> nat"

  assumes countable: "inj_on pull_up F"
  assumes comp_closed: "\<lbrakk>a \<in> F; b \<in> F\<rbrakk> \<Longrightarrow> a \<oplus> b \<in> F"
begin
  definition "naked_push_down \<equiv> inv_into F pull_up"
  definition "push_down x = (case x of Some n \<Rightarrow> (if \<exists>f. pull_up f = n then naked_push_down n else (\<lambda>_.None)) | None \<Rightarrow> (\<lambda>_.None))"

  lemma push_pull_inv [simp]: "\<forall>f \<in> F. push_down (Some (pull_up f)) = f"
    using countable inv_into_f_f naked_push_down_def option.case(2) push_down_def by force

  lemma sanity_pushing_down_1: "\<exists>f. pull_up f = n \<longrightarrow> push_down (Some n) = f"
    by blast
end

locale computable_universe_curried = computable_universe_carrier +
  fixes \<alpha> \<Delta> :: "(nat\<rightharpoonup>nat)"

  assumes alpha_in_f: "\<alpha> \<in> F"
  assumes alpha: "\<alpha> 1 = None" "\<alpha> 0 = Some 1"

  assumes delta_in_f: "\<Delta> \<in> F"
  assumes delta: "\<And>f. f \<in> F \<Longrightarrow> (f \<oplus> \<Delta>) x = (push_down (f x)) x"
begin
  theorem locale_cantor:
  fixes H :: "(nat\<rightharpoonup>nat)"

  assumes Hf_falls_in_F: "\<And>f h. f \<in> F \<Longrightarrow> H (pull_up f) = Some (pull_up h) \<Longrightarrow> h \<in> F"
  assumes H_behaviour: "\<forall>f \<in> F. H (pull_up f) = Some (pull_up (\<lambda>c. case f c of Some _ \<Rightarrow> Some 1 | None \<Rightarrow> Some 0))"

  shows "H \<notin> F"
  proof (rule ccontr)
    assume "\<not> (H \<notin> F)"
    hence "H \<in> F" by simp

    define contra where "contra = \<alpha> \<oplus> H \<oplus> \<Delta>"
    have contra_in_F: "contra \<in> F" by (simp add: \<open>H \<in> F\<close> alpha_in_f comp_closed contra_def delta_in_f)

    have "\<forall>h. H (pull_up contra) = Some (pull_up h) \<longrightarrow> h \<in> F" using Hf_falls_in_F contra_in_F
      by fastforce
    moreover
    have h_pull_up_contra: "H (pull_up contra) = Some (pull_up (\<lambda>c. case contra c of Some _ \<Rightarrow> Some 1 | None \<Rightarrow> Some 0))"
      using H_behaviour contra_in_F by presburger
    ultimately
    have hcontra_in_F: "(\<lambda>c. case contra c of Some _ \<Rightarrow> Some 1 | None \<Rightarrow> Some 0) \<in> F"
      by blast

    have possible_pushed_H: "\<And>c. (push_down (H (pull_up contra))) c = Some 1 \<or> (push_down (H (pull_up contra))) c = Some 0"
      by (metis h_pull_up_contra hcontra_in_F option.case_eq_if push_pull_inv)

    show "False"
    proof cases
      assume one: "(push_down (H (pull_up contra))) (pull_up contra) = Some 1"

      hence "(\<lambda>c. case contra c of Some _ \<Rightarrow> Some 1 | None \<Rightarrow> Some 0) (pull_up contra) = Some 1"
        by (metis h_pull_up_contra hcontra_in_F option.case_eq_if option.case_eq_if option.sel push_pull_inv zero_neq_one)
      hence contra_some: "\<exists>n. contra (pull_up contra) = Some n"
        using one_neq_zero option.case_eq_if option.collapse option.inject by fastforce

      have "contra (pull_up contra) = \<alpha> (the ((H \<oplus> \<Delta>) (pull_up contra)))"
        by (metis \<open>H \<in> F\<close> alpha(1) contra_def delta ocomp_assoc ocomp_def one option.sel option.simps(5))
      moreover
      have "\<alpha> (the ((H \<oplus> \<Delta>) (pull_up contra))) = \<alpha> (the (push_down (H (pull_up contra)) (pull_up contra)))"
        by (simp add: \<open>H \<in> F\<close> delta)
      moreover
      have "\<alpha> (the (push_down (H (pull_up contra)) (pull_up contra))) = \<alpha> 1"
        by (simp add: one)
      ultimately
      have contra_none: "contra (pull_up contra) = None"
        using alpha(1) by presburger

      show "False" using contra_some contra_none by simp
    next
      assume not_one: "(push_down (H (pull_up contra))) (pull_up contra) \<noteq> Some 1"

      hence zero: "(push_down (H (pull_up contra))) (pull_up contra) = Some 0"
        using possible_pushed_H by auto
      hence "(\<lambda>c. case contra c of Some _ \<Rightarrow> Some 1 | None \<Rightarrow> Some 0) (pull_up contra) = Some 0"
        by (metis not_one h_pull_up_contra hcontra_in_F option.case_eq_if option.case_eq_if push_pull_inv)
      hence contra_none: "contra (pull_up contra) = None"
        by (smt (verit, ccfv_SIG) not_one option.case_eq_if possible_pushed_H)

      have "contra (pull_up contra) = \<alpha> (the ((H \<oplus> \<Delta>) (pull_up contra)))"
        by (metis \<open>H \<in> F\<close> alpha(2) computable_universe_curried.delta computable_universe_curried_axioms contra_def not_one ocomp_assoc ocomp_def option.sel option.simps(5) possible_pushed_H)
      moreover
      have "\<alpha> (the ((H \<oplus> \<Delta>) (pull_up contra))) = \<alpha> (the (push_down (H (pull_up contra)) (pull_up contra)))"
        by (simp add: \<open>H \<in> F\<close> delta)
      moreover
      have "\<alpha> (the (push_down (H (pull_up contra)) (pull_up contra))) = \<alpha> 0"
        by (simp add: zero)
      ultimately
      have contra_some: "\<exists>n. contra (pull_up contra) = Some n"
        using alpha(2) by fastforce

      show "False" using contra_none contra_some by simp
    qed
  qed
end

locale computable_universe_paired = computable_universe_carrier +
  fixes \<alpha> \<Delta>:: "(nat\<rightharpoonup>nat)"
  fixes pair_to_nat :: "(nat \<times> nat) \<Rightarrow> nat"

  assumes alpha_in_f: "\<alpha> \<in> F"
  assumes alpha: "\<alpha> 0 = None" "\<alpha> 1 = Some 1"

  assumes delta_in_f: "\<Delta> \<in> F"
  assumes delta: "\<And>f. f \<in> F \<Longrightarrow> (f \<oplus> \<Delta>) x = f (pair_to_nat (x, x))"
begin
  theorem locale_cantor:
    fixes H :: "(nat\<rightharpoonup>nat)"

    assumes H_behaviour: "\<And>f (c::nat). f \<in> F \<Longrightarrow>  H (pair_to_nat (pull_up f, c)) = (case f c of Some _ \<Rightarrow> Some 0 | None \<Rightarrow> Some 1)"

    shows "H \<notin> F"
  proof (rule ccontr)
    assume "\<not> H \<notin> F"
    hence "H \<in> F" by simp

    define contra where "contra = \<alpha> \<oplus> H \<oplus> \<Delta>"
    have contra_in_F: "contra \<in> F" by (simp add: \<open>H \<in> F\<close> alpha_in_f comp_closed contra_def delta_in_f)

    have possible_H: "H (pair_to_nat ((pull_up contra), (pull_up contra))) = Some 1 \<or> H (pair_to_nat ((pull_up contra), (pull_up contra))) = Some 0"
      by (simp add: alpha(2) assms contra_in_F option.case_eq_if)

    show "False"
    proof cases
      assume zero: "H (pair_to_nat ((pull_up contra), (pull_up contra))) = Some 0"
      hence contra_some: "\<exists>n. contra (pull_up contra) = Some n"
        by (metis UNIV_I assms chi_fun_0_iff chi_fun_1_I contra_in_F option.exhaust_sel option.simps(4))

      have "contra (pull_up contra) = \<alpha> (the ((H \<oplus> \<Delta>) (pull_up contra)))"
        by (metis contra_some contra_def ocomp_assoc ocomp_def option.case_eq_if option.distinct(1) option.simps(4))
      moreover
      have "\<alpha> (the ((H \<oplus> \<Delta>) (pull_up contra))) = \<alpha> (the (H (pair_to_nat ((pull_up contra), (pull_up contra)))))"
        by (simp add: \<open>H \<in> F\<close> delta)
      moreover
      have "\<alpha> (the (H (pair_to_nat ((pull_up contra), (pull_up contra))))) = \<alpha> 0"
        by (simp add: zero option.sel)
      ultimately
      have contra_none: "contra (pull_up contra) = None"
        using alpha(1) by presburger

      show "False" using contra_some contra_none by simp
    next
      assume not_zero: "H (pair_to_nat ((pull_up contra), (pull_up contra))) \<noteq> Some 0"
      hence one: "H (pair_to_nat ((pull_up contra), (pull_up contra))) = Some 1" using possible_H by blast
      hence contra_none: "contra (pull_up contra) = None"
        by (metis assms contra_in_F  not_zero option.case_eq_if)

      have "contra (pull_up contra) = \<alpha> (the ((H \<oplus> \<Delta>) (pull_up contra)))"
        by (metis \<open>H \<in> F\<close> contra_def delta ocomp_assoc ocomp_def option.sel option.simps(5) one)
      moreover
      have "\<alpha> (the ((H \<oplus> \<Delta>) (pull_up contra))) = \<alpha> (the (H (pair_to_nat ((pull_up contra), (pull_up contra)))))"
        by (simp add: \<open>H \<in> F\<close> delta)
      moreover
      have "\<alpha> (the (H (pair_to_nat ((pull_up contra), (pull_up contra))))) = \<alpha> 1"
        by (simp add: one option.sel)
      ultimately
      have contra_some: "\<exists>n. contra (pull_up contra) = Some n"
        using alpha(2) by auto

      show "False" using contra_some contra_none by simp
    qed
  qed
end

(*Turing carrier set

Important note: Blanks and Hoare triples might end up being too complicated of a problem to solve.
Proving the behaviour of functions induced from machines will not be completed due to time-constraints.
If it is wished to tackle, it might be a better idea to work with steps0 function to simply compute
the end numeral result and return that.

Deprecated def:
(if (\<exists>n c (r::nat) k1 k2 l1 l2. is_final (steps0 (1, (Bk \<up> k1, <inp> @ Bk \<up> l1)) p n) \<and> steps0 (1, (Bk \<up> k1, <inp> @ Bk \<up> l1)) p n = (c, Bk \<up> k2, <r> @ Bk \<up> l2))
 then Some (SOME r. \<exists>n c k1 k2 l1 l2. steps0 (1, (Bk \<up> k1, <inp> @ Bk \<up> l1)) p n = (c, Bk \<up> k2, <r> @ Bk \<up> l2))
 else None)*)
definition induce_F_from_tprog0 :: "tprog0 \<Rightarrow> nat \<Rightarrow> nat option" where
"induce_F_from_tprog0 p inp = (if (\<exists>r. \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <inp> @ Bk \<up> l)\<rbrace> p \<lbrace>\<lambda>tap. \<exists>k l. tap = (Bk \<up> k, <r::nat> @ Bk \<up> l)\<rbrace>)
                               then Some (THE r. \<exists>k l. steps0 (1, ([], <inp>)) p (SOME n. is_final (steps0 (1, ([], <inp>)) p n)) = (0, (Bk \<up> k, <r> @ Bk \<up> l)))
                               else None)"

(*For all possible numeral input tapes the Turing machines we are interested in return numeral output*)
definition numeral_tm0 :: "tprog0 \<Rightarrow> bool" where
"numeral_tm0 p = (let numeral_tape = \<lambda>tap. \<exists>k l (n::nat). tap = (Bk \<up> k, <n> @ Bk \<up> l)
                  in \<lbrace>numeral_tape\<rbrace> p \<lbrace>numeral_tape\<rbrace> \<or> \<lbrace>numeral_tape\<rbrace> p \<up>)"

definition "numeral_composable_tm0 p \<equiv> composable_tm0 p \<and> numeral_tm0 p"

lemma sq_num_comp_tm0: "\<lbrakk>numeral_composable_tm0 p1; numeral_composable_tm0 p2\<rbrakk> \<Longrightarrow> numeral_composable_tm0 (p1 |+| p2)"
  by (metis (no_types, lifting) Hoare_plus_halt Hoare_plus_unhalt Hoare_unhalt_def numeral_composable_tm0_def numeral_tm0_def seq_tm_composable seq_tm_steps)

definition turing_F :: "(nat\<rightharpoonup>nat) set" where
"turing_F = induce_F_from_tprog0 ` {p. numeral_composable_tm0 p}"

lemma composable_tprog_in_turing_F: "\<And>p. numeral_composable_tm0 p \<Longrightarrow> induce_F_from_tprog0 p \<in> turing_F"
  by (simp add: image_eqI turing_F_def)

(*Carrier set functions back to Turing and then to nat*)
definition turing_pull_up :: "(nat\<rightharpoonup>nat) \<Rightarrow> nat" where
"turing_pull_up f = (if f \<in> turing_F then tm_to_nat (SOME p. induce_F_from_tprog0 p = f) else 0)"

lemma countable_turing_F: "inj_on turing_pull_up turing_F"
  unfolding inj_on_def turing_pull_up_def using inj_tm_to_nat
  by (smt (verit, del_insts) Collect_cong Collect_mem_eq Eps_cong UNIV_I UNIV_def
      imageE mem_Collect_eq nat_to_tm_is_inv_of_tm_to_nat someI_ex some_eq_ex turing_F_def
      turing_pull_up_def verit_sko_ex' verit_sko_forall)

(*turing_F closed under \<oplus> and equivalent with |+|*)
lemma turing_F_from_composable_tm: "\<And>a. a \<in> turing_F \<Longrightarrow> \<exists>p. (numeral_composable_tm0 p) \<and> (induce_F_from_tprog0 p = a)"
  by (metis (no_types, lifting) f_inv_into_f inv_into_into mem_Collect_eq turing_F_def)

lemma seq_tm_stays_in_turing_F: "\<And>p1 p2. numeral_composable_tm0 p1 \<Longrightarrow> numeral_composable_tm0 p2 \<Longrightarrow> induce_F_from_tprog0 (p2 |+| p1) \<in> turing_F"
  using sq_num_comp_tm0 composable_tprog_in_turing_F by blast

lemma seq_tm_oplus_correspondence: "\<And>p1 p2. numeral_composable_tm0 p1 \<Longrightarrow> numeral_composable_tm0 p2 \<Longrightarrow>
        induce_F_from_tprog0 (p2 |+| p1) = (induce_F_from_tprog0 p1) \<oplus> (induce_F_from_tprog0 p2)"
  sorry

lemma closed_turing_F: "\<And>a b. a \<in> turing_F \<Longrightarrow> b \<in> turing_F \<Longrightarrow> a \<oplus> b \<in> turing_F"
  by (metis seq_tm_oplus_correspondence seq_tm_stays_in_turing_F turing_F_from_composable_tm)

(*Invoke the first half*)
interpretation computable_universe_carrier turing_F turing_pull_up
  apply unfold_locales
  apply (simp add: countable_turing_F)
  apply (simp add: closed_turing_F)
  done

lemma countable_tape: "from_nat (to_nat (tp::tape)) = tp"
  by simp

fun pair_plus :: "(nat \<times> nat) \<Rightarrow> nat" where
"pair_plus (t1, t2) = t1 + t2"

lemma numeral_composable_tm0_tm_dither: "numeral_composable_tm0 tm_dither"
  unfolding numeral_composable_tm0_def using composable_tm0_tm_dither
  sorry

definition tm_doubling :: "tprog0" where
"tm_doubling = [(WO, 2), (R, 1), (L, 3), (R, 2), (WB, 4), (WB, 4), (L, 5), (L, 5), (R, 0), (L, 5)]"

lemma composable_tm0_tm_doubling[intro, simp]: "composable_tm0 tm_doubling"
  by (auto simp: tm_doubling_def)

lemma tm_doubling_removes_Bk: "\<lbrace>\<lambda>tap. tap = ([Bk], <(x::nat, x)>)\<rbrace> tm_doubling \<lbrace>\<lambda>tap. \<exists>l. tap = ([Bk], <(x + x)> @ Bk \<up> l)\<rbrace>"
  sorry

definition "tm_modified_copy = tm_copy |+| tm_doubling"

lemma composable_tm0_tm_modified_copy[intro, simp]: "composable_tm0 tm_modified_copy"
  by (metis composable_tm0_tm_copy composable_tm0_tm_doubling seq_tm_composable tm_modified_copy_def)

lemma oc_arrow_to_encode[intro, simp]: "Oc \<up> (Suc n) = <n>"
  by (simp add: tape_of_nat_def)

lemma tm_modified_copy_hoare: "\<lbrace>\<lambda>tap. tap = ([], <x::nat>)\<rbrace> tm_modified_copy \<lbrace>\<lambda>tap. \<exists>l. tap = ([Bk], <(x + x)> @ Bk \<up> l)\<rbrace>"
  using tm_modified_copy_def tm_doubling_removes_Bk tm_copy_correct oc_arrow_to_encode
  Hoare_plus_halt composable_tm0_tm_copy Hoare_halt_def
  by (metis (no_types, lifting))

lemma numeral_composable_tm0_tm_modified_copy[intro, simp]: "numeral_composable_tm0 tm_modified_copy"
  sorry

(*inducing functions*)
definition "turing_dither = induce_F_from_tprog0 tm_dither"

lemma turing_dither_in_turing_F: "turing_dither \<in> turing_F"
  unfolding turing_dither_def
  using numeral_composable_tm0_tm_dither composable_tprog_in_turing_F
  by presburger

definition "turing_copy = induce_F_from_tprog0 tm_modified_copy"

lemma turing_copy_in_turing_F: "turing_copy \<in> turing_F"
  using numeral_composable_tm0_tm_modified_copy composable_tprog_in_turing_F turing_copy_def
  by presburger

(*dither and copy behaviour*)
lemma turing_dither_halts: "turing_dither 1 = Some 1"
  sorry

lemma turing_dither_loops: "turing_dither 0 = None"
  sorry

lemma turing_copy_pair_plus: "turing_copy x = Some (pair_plus (x, x))"
  sorry

lemma turing_copy_composed: "\<And>f x. f \<in> turing_F \<Longrightarrow> (f \<oplus> turing_copy) x = f (pair_plus (x, x))"
  by (simp add: ocomp_def turing_copy_pair_plus)

(*Invoke the second half*)
interpretation computable_universe_paired turing_F turing_pull_up turing_dither turing_copy pair_plus
  apply unfold_locales
  using turing_dither_in_turing_F apply simp
  using turing_dither_loops apply simp
  using One_nat_def turing_dither_halts apply fastforce
  using turing_copy_in_turing_F apply simp
  using turing_copy_composed apply simp
  done

end


(*  Title:      HOL/Algebra/Coset.thy
    Author:     Florian Kammueller
    Author:     L C Paulson
    Author:     Stephan Hohe
*)

theory Coset
imports Group
begin

section {*Cosets and Quotient Groups*}

definition
  r_coset    :: "[_, 'a set, 'a] \<Rightarrow> 'a set"    (infixl "#>\<index>" 60)
  where "H #>\<^bsub>G\<^esub> a = (\<Union>h\<in>H. {h \<otimes>\<^bsub>G\<^esub> a})"

definition
  l_coset    :: "[_, 'a, 'a set] \<Rightarrow> 'a set"    (infixl "<#\<index>" 60)
  where "a <#\<^bsub>G\<^esub> H = (\<Union>h\<in>H. {a \<otimes>\<^bsub>G\<^esub> h})"

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

definition
  set_mult  :: "[_, 'a set ,'a set] \<Rightarrow> 'a set" (infixl "<#>\<index>" 60)
  where "H <#>\<^bsub>G\<^esub> K = (\<Union>h\<in>H. \<Union>k\<in>K. {h \<otimes>\<^bsub>G\<^esub> k})"

definition
  SET_INV :: "[_,'a set] \<Rightarrow> 'a set"  ("set'_inv\<index> _" [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)"

abbreviation
  normal_rel :: "['a set, ('a, 'b) monoid_scheme] \<Rightarrow> bool"  (infixl "\<lhd>" 60) where
  "H \<lhd> G \<equiv> normal H G"

subsection {*Basic Properties of Cosets*}

lemma (in group) coset_mult_assoc:
     "[| M \<subseteq> carrier G; g \<in> carrier G; h \<in> carrier G |]
      ==> (M #> g) #> h = M #> (g \<otimes> h)"
by (force simp add: r_coset_def m_assoc)

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

lemma (in group) coset_mult_inv1:
     "[| M #> (x \<otimes> (inv y)) = M;  x \<in> carrier G ; y \<in> carrier G;
         M \<subseteq> carrier G |] ==> M #> x = M #> y"
apply (erule subst [of concl: "%z. M #> x = z #> y"])
apply (simp add: coset_mult_assoc m_assoc)
done

lemma (in group) coset_mult_inv2:
     "[| M #> x = M #> y;  x \<in> carrier G;  y \<in> carrier G;  M \<subseteq> carrier G |]
      ==> M #> (x \<otimes> (inv y)) = M "
apply (simp add: coset_mult_assoc [symmetric])
apply (simp add: coset_mult_assoc)
done

lemma (in group) coset_join1:
     "[| H #> x = H;  x \<in> carrier G;  subgroup H G |] ==> x \<in> H"
apply (erule subst)
apply (simp add: r_coset_def)
apply (blast intro: l_one subgroup.one_closed sym)
done

lemma (in group) solve_equation:
    "\<lbrakk>subgroup H G; x \<in> H; y \<in> H\<rbrakk> \<Longrightarrow> \<exists>h\<in>H. y = h \<otimes> x"
apply (rule bexI [of _ "y \<otimes> (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"
  --{*Alternative proof is to put @{term "x=\<one>"} in @{text repr_independence}.*}
by (force simp add: subgroup.m_closed r_coset_def solve_equation)

lemma (in monoid) r_coset_subset_G:
     "[| H \<subseteq> carrier G; x \<in> carrier G |] ==> H #> x \<subseteq> carrier G"
by (auto simp add: r_coset_def)

lemma (in group) rcosI:
     "[| h \<in> H; H \<subseteq> carrier G; x \<in> carrier G|] ==> h \<otimes> 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{*Really needed?*}
lemma (in group) transpose_inv:
     "[| x \<otimes> y = z;  x \<in> carrier G;  y \<in> carrier G;  z \<in> carrier G |]
      ==> (inv x) \<otimes> z = y"
by (force simp add: m_assoc [symmetric])

lemma (in group) rcos_self: "[| x \<in> carrier G; subgroup H G |] ==> x \<in> H #> x"
apply (simp add: r_coset_def)
apply (blast intro: sym l_one subgroup.subset [THEN subsetD]
                    subgroup.one_closed)
done

text (in group) {* Opposite of @{thm [source] "repr_independence"} *}
lemma (in group) repr_independenceD:
  assumes "subgroup H G"
  assumes ycarr: "y \<in> carrier G"
      and repr:  "H #> x = H #> y"
  shows "y \<in> H #> x"
proof -
  interpret subgroup H G by fact
  show ?thesis  apply (subst repr)
  apply (intro rcos_self)
   apply (rule ycarr)
   apply (rule is_subgroup)
  done
qed

text {* Elements of a right coset are in the carrier *}
lemma (in subgroup) elemrcos_carrier:
  assumes "group G"
  assumes acarr: "a \<in> carrier G"
    and a': "a' \<in> H #> a"
  shows "a' \<in> carrier G"
proof -
  interpret group G by fact
  from subset and acarr
  have "H #> a \<subseteq> carrier G" by (rule r_coset_subset_G)
  from this and a'
  show "a' \<in> carrier G"
    by fast
qed

lemma (in subgroup) rcos_const:
  assumes "group G"
  assumes hH: "h \<in> H"
  shows "H #> h = H"
proof -
  interpret group G by fact
  show ?thesis apply (unfold r_coset_def)
    apply rule
    apply rule
    apply clarsimp
    apply (intro subgroup.m_closed)
    apply (rule is_subgroup)
    apply assumption
    apply (rule hH)
    apply rule
    apply simp
  proof -
    fix h'
    assume h'H: "h' \<in> H"
    note carr = hH[THEN mem_carrier] h'H[THEN mem_carrier]
    from carr
    have a: "h' = (h' \<otimes> inv h) \<otimes> h" by (simp add: m_assoc)
    from h'H hH
    have "h' \<otimes> inv h \<in> H" by simp
    from this and a
    show "\<exists>x\<in>H. h' = x \<otimes> h" by fast
  qed
qed

text {* Step one for lemma @{text "rcos_module"} *}
lemma (in subgroup) rcos_module_imp:
  assumes "group G"
  assumes xcarr: "x \<in> carrier G"
      and x'cos: "x' \<in> H #> x"
  shows "(x' \<otimes> inv x) \<in> H"
proof -
  interpret group G by fact
  from xcarr x'cos
      have x'carr: "x' \<in> carrier G"
      by (rule elemrcos_carrier[OF is_group])
  from xcarr
      have ixcarr: "inv x \<in> carrier G"
      by simp
  from x'cos
      have "\<exists>h\<in>H. x' = h \<otimes> x"
      unfolding r_coset_def
      by fast
  from this
      obtain h
        where hH: "h \<in> H"
        and x': "x' = h \<otimes> x"
      by auto
  from hH and subset
      have hcarr: "h \<in> carrier G" by fast
  note carr = xcarr x'carr hcarr
  from x' and carr
      have "x' \<otimes> (inv x) = (h \<otimes> x) \<otimes> (inv x)" by fast
  also from carr
      have "\<dots> = h \<otimes> (x \<otimes> inv x)" by (simp add: m_assoc)
  also from carr
      have "\<dots> = h \<otimes> \<one>" by simp
  also from carr
      have "\<dots> = h" by simp
  finally
      have "x' \<otimes> (inv x) = h" by simp
  from hH this
      show "x' \<otimes> (inv x) \<in> H" by simp
qed

text {* Step two for lemma @{text "rcos_module"} *}
lemma (in subgroup) rcos_module_rev:
  assumes "group G"
  assumes carr: "x \<in> carrier G" "x' \<in> carrier G"
      and xixH: "(x' \<otimes> inv x) \<in> H"
  shows "x' \<in> H #> x"
proof -
  interpret group G by fact
  from xixH
      have "\<exists>h\<in>H. x' \<otimes> (inv x) = h" by fast
  from this
      obtain h
        where hH: "h \<in> H"
        and hsym: "x' \<otimes> (inv x) = h"
      by fast
  from hH subset have hcarr: "h \<in> carrier G" by simp
  note carr = carr hcarr
  from hsym[symmetric] have "h \<otimes> x = x' \<otimes> (inv x) \<otimes> x" by fast
  also from carr
      have "\<dots> = x' \<otimes> ((inv x) \<otimes> x)" by (simp add: m_assoc)
  also from carr
      have "\<dots> = x' \<otimes> \<one>" by simp
  also from carr
      have "\<dots> = x'" by simp
  finally
      have "h \<otimes> x = x'" by simp
  from this[symmetric] and hH
      show "x' \<in> H #> x"
      unfolding r_coset_def
      by fast
qed

text {* Module property of right cosets *}
lemma (in subgroup) rcos_module:
  assumes "group G"
  assumes carr: "x \<in> carrier G" "x' \<in> carrier G"
  shows "(x' \<in> H #> x) = (x' \<otimes> inv x \<in> H)"
proof -
  interpret group G by fact
  show ?thesis proof  assume "x' \<in> H #> x"
    from this and carr
    show "x' \<otimes> inv x \<in> H"
      by (intro rcos_module_imp[OF is_group])
  next
    assume "x' \<otimes> inv x \<in> H"
    from this and carr
    show "x' \<in> H #> x"
      by (intro rcos_module_rev[OF is_group])
  qed
qed

text {* Right cosets are subsets of the carrier. *}
lemma (in subgroup) rcosets_carrier:
  assumes "group G"
  assumes XH: "X \<in> rcosets H"
  shows "X \<subseteq> carrier G"
proof -
  interpret group G by fact
  from XH have "\<exists>x\<in> carrier G. X = H #> x"
      unfolding RCOSETS_def
      by fast
  from this
      obtain x
        where xcarr: "x\<in> carrier G"
        and X: "X = H #> x"
      by fast
  from subset and xcarr
      show "X \<subseteq> carrier G"
      unfolding X
      by (rule r_coset_subset_G)
qed

text {* Multiplication of general subsets *}
lemma (in monoid) set_mult_closed:
  assumes Acarr: "A \<subseteq> carrier G"
      and Bcarr: "B \<subseteq> carrier G"
  shows "A <#> B \<subseteq> carrier G"
apply rule apply (simp add: set_mult_def, clarsimp)
proof -
  fix a b
  assume "a \<in> A"
  from this and Acarr
      have acarr: "a \<in> carrier G" by fast

  assume "b \<in> B"
  from this and Bcarr
      have bcarr: "b \<in> carrier G" by fast

  from acarr bcarr
      show "a \<otimes> b \<in> carrier G" by (rule m_closed)
qed

lemma (in comm_group) mult_subgroups:
  assumes subH: "subgroup H G"
      and subK: "subgroup K G"
  shows "subgroup (H <#> K) G"
apply (rule subgroup.intro)
   apply (intro set_mult_closed subgroup.subset[OF subH] subgroup.subset[OF subK])
  apply (simp add: set_mult_def) apply clarsimp defer 1
  apply (simp add: set_mult_def) defer 1
  apply (simp add: set_mult_def, clarsimp) defer 1
proof -
  fix ha hb ka kb
  assume haH: "ha \<in> H" and hbH: "hb \<in> H" and kaK: "ka \<in> K" and kbK: "kb \<in> K"
  note carr = haH[THEN subgroup.mem_carrier[OF subH]] hbH[THEN subgroup.mem_carrier[OF subH]]
              kaK[THEN subgroup.mem_carrier[OF subK]] kbK[THEN subgroup.mem_carrier[OF subK]]
  from carr
      have "(ha \<otimes> ka) \<otimes> (hb \<otimes> kb) = ha \<otimes> (ka \<otimes> hb) \<otimes> kb" by (simp add: m_assoc)
  also from carr
      have "\<dots> = ha \<otimes> (hb \<otimes> ka) \<otimes> kb" by (simp add: m_comm)
  also from carr
      have "\<dots> = (ha \<otimes> hb) \<otimes> (ka \<otimes> kb)" by (simp add: m_assoc)
  finally
      have eq: "(ha \<otimes> ka) \<otimes> (hb \<otimes> kb) = (ha \<otimes> hb) \<otimes> (ka \<otimes> kb)" .

  from haH hbH have hH: "ha \<otimes> hb \<in> H" by (simp add: subgroup.m_closed[OF subH])
  from kaK kbK have kK: "ka \<otimes> kb \<in> K" by (simp add: subgroup.m_closed[OF subK])

  from hH and kK and eq
      show "\<exists>h'\<in>H. \<exists>k'\<in>K. (ha \<otimes> ka) \<otimes> (hb \<otimes> kb) = h' \<otimes> k'" by fast
next
  have "\<one> = \<one> \<otimes> \<one>" by simp
  from subgroup.one_closed[OF subH] subgroup.one_closed[OF subK] this
      show "\<exists>h\<in>H. \<exists>k\<in>K. \<one> = h \<otimes> k" by fast
next
  fix h k
  assume hH: "h \<in> H"
     and kK: "k \<in> K"

  from hH[THEN subgroup.mem_carrier[OF subH]] kK[THEN subgroup.mem_carrier[OF subK]]
      have "inv (h \<otimes> k) = inv h \<otimes> inv k" by (simp add: inv_mult_group m_comm)

  from subgroup.m_inv_closed[OF subH hH] and subgroup.m_inv_closed[OF subK kK] and this
      show "\<exists>ha\<in>H. \<exists>ka\<in>K. inv (h \<otimes> k) = ha \<otimes> ka" by fast
qed

lemma (in subgroup) lcos_module_rev:
  assumes "group G"
  assumes carr: "x \<in> carrier G" "x' \<in> carrier G"
      and xixH: "(inv x \<otimes> x') \<in> H"
  shows "x' \<in> x <# H"
proof -
  interpret group G by fact
  from xixH
      have "\<exists>h\<in>H. (inv x) \<otimes> x' = h" by fast
  from this
      obtain h
        where hH: "h \<in> H"
        and hsym: "(inv x) \<otimes> x' = h"
      by fast

  from hH subset have hcarr: "h \<in> carrier G" by simp
  note carr = carr hcarr
  from hsym[symmetric] have "x \<otimes> h = x \<otimes> ((inv x) \<otimes> x')" by fast
  also from carr
      have "\<dots> = (x \<otimes> (inv x)) \<otimes> x'" by (simp add: m_assoc[symmetric])
  also from carr
      have "\<dots> = \<one> \<otimes> x'" by simp
  also from carr
      have "\<dots> = x'" by simp
  finally
      have "x \<otimes> h = x'" by simp

  from this[symmetric] and hH
      show "x' \<in> x <# H"
      unfolding l_coset_def
      by fast
qed

subsection {* Normal subgroups *}

lemma normal_imp_subgroup: "H \<lhd> G \<Longrightarrow> 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 is_group)

lemma (in normal) inv_op_closed1:
     "\<lbrakk>x \<in> carrier G; h \<in> H\<rbrakk> \<Longrightarrow> (inv x) \<otimes> h \<otimes> 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 \<otimes> h \<otimes> (inv x) \<in> H"
apply (subgoal_tac "inv (inv x) \<otimes> h \<otimes> (inv x) \<in> H")
apply (simp add: )
apply (blast intro: inv_op_closed1)
done

text{*Alternative characterization of normal subgroups*}
lemma (in group) normal_inv_iff:
     "(N \<lhd> G) =
      (subgroup N G & (\<forall>x \<in> carrier G. \<forall>h \<in> N. x \<otimes> h \<otimes> (inv x) \<in> N))"
      (is "_ = ?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 \<otimes> h \<otimes> 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 \<otimes> x}) = (\<Union>h\<in>N. {x \<otimes> h})"
    proof
      show "(\<Union>h\<in>N. {h \<otimes> x}) \<subseteq> (\<Union>h\<in>N. {x \<otimes> h})"
      proof clarify
        fix n
        assume n: "n \<in> N"
        show "n \<otimes> x \<in> (\<Union>h\<in>N. {x \<otimes> h})"
        proof
          from closed [of "inv x"]
          show "inv x \<otimes> n \<otimes> x \<in> N" by (simp add: x n)
          show "n \<otimes> x \<in> {x \<otimes> (inv x \<otimes> n \<otimes> x)}"
            by (simp add: x n m_assoc [symmetric] sb [THEN subsetD])
        qed
      qed
    next
      show "(\<Union>h\<in>N. {x \<otimes> h}) \<subseteq> (\<Union>h\<in>N. {h \<otimes> x})"
      proof clarify
        fix n
        assume n: "n \<in> N"
        show "x \<otimes> n \<in> (\<Union>h\<in>N. {h \<otimes> x})"
        proof
          show "x \<otimes> n \<otimes> inv x \<in> N" by (simp add: x n closed)
          show "x \<otimes> n \<in> {x \<otimes> n \<otimes> inv x \<otimes> x}"
            by (simp add: x n m_assoc sb [THEN subsetD])
        qed
      qed
    qed
  qed
qed

subsection{*More Properties of Cosets*}

lemma (in group) lcos_m_assoc:
     "[| M \<subseteq> carrier G; g \<in> carrier G; h \<in> carrier G |]
      ==> g <# (h <# M) = (g \<otimes> h) <# M"
by (force simp add: l_coset_def m_assoc)

lemma (in group) lcos_mult_one: "M \<subseteq> carrier G ==> \<one> <# M = M"
by (force simp add: l_coset_def)

lemma (in group) l_coset_subset_G:
     "[| H \<subseteq> carrier G; x \<in> carrier G |] ==> 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 \<otimes> h"
    and x: "x \<in> carrier G"
    and sb: "subgroup H G"
  then obtain h' where h': "h' \<in> H & x \<otimes> h' = y" by blast
  show "\<exists>h\<in>H. x = y \<otimes> h"
  proof
    show "x = y \<otimes> 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:
     "[| y \<in> x <# H;  x \<in> carrier G;  subgroup H G |] ==> 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 \<otimes> 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 (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 {* Set of Inverses of an @{text r_coset}. *}

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)
  fix h
  assume h: "h \<in> H"
  show "inv x \<otimes> inv h \<in> (\<Union>j\<in>H. {j \<otimes> inv x})"
  proof
    show "inv x \<otimes> inv h \<otimes> x \<in> H"
      by (simp add: inv_op_closed1 h x)
    show "inv x \<otimes> inv h \<in> {inv x \<otimes> inv h \<otimes> x \<otimes> inv x}"
      by (simp add: h x m_assoc)
  qed
  show "h \<otimes> inv x \<in> (\<Union>j\<in>H. {inv x \<otimes> inv j})"
  proof
    show "x \<otimes> inv h \<otimes> inv x \<in> H"
      by (simp add: inv_op_closed2 h x)
    show "h \<otimes> inv x \<in> {inv x \<otimes> inv (x \<otimes> inv h \<otimes> inv x)}"
      by (simp add: h x m_assoc [symmetric] inv_mult_group)
  qed
qed

subsubsection {*Theorems for @{text "<#>"} with @{text "#>"} or @{text "<#"}.*}

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 \<otimes> y)"
by (simp add: setmult_rcos_assoc coset_mult_assoc
              subgroup_mult_id normal.axioms subset normal_axioms)

lemma (in normal) rcos_sum:
     "\<lbrakk>x \<in> carrier G; y \<in> carrier G\<rbrakk>
      \<Longrightarrow> (H #> x) <#> (H #> y) = H #> (x \<otimes> 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"
  -- {* generalizes @{text subgroup_mult_id} *}
  by (auto simp add: RCOSETS_def subset
        setmult_rcos_assoc subgroup_mult_id normal.axioms normal_axioms)

subsubsection{*An Equivalence Relation*}

definition
  r_congruent :: "[('a,'b)monoid_scheme, 'a set] \<Rightarrow> ('a*'a)set"  ("rcong\<index> _")
  where "rcong\<^bsub>G\<^esub> H = {(x,y). x \<in> carrier G & y \<in> carrier G & inv\<^bsub>G\<^esub> x \<otimes>\<^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 (intro equivI)
    show "refl_on (carrier G) (rcong H)"
      by (auto simp add: r_congruent_def refl_on_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 \<otimes> y \<in> H"
      hence "inv (inv x \<otimes> y) \<in> H" by simp
      thus "inv y \<otimes> 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 \<otimes> y \<in> H" and "inv y \<otimes> z \<in> H"
      hence "(inv x \<otimes> y) \<otimes> (inv y \<otimes> z) \<in> H" by simp
      hence "inv x \<otimes> (y \<otimes> inv y) \<otimes> z \<in> H"
        by (simp add: m_assoc del: r_inv Units_r_inv)
      thus "inv x \<otimes> z \<in> H" by simp
    qed
  qed
qed

text{*Equivalence classes of @{text rcong} correspond to left cosets.
  Was there a mistake in the definitions? I'd have expected them to
  correspond to right cosets.*}

(* CB: This is correct, but subtle.
   We call H #> a the right coset of a relative to H.  According to
   Jacobson, this is what the majority of group theory literature does.
   He then defines the notion of congruence relation ~ over monoids as
   equivalence relation with a ~ a' & b ~ b' \<Longrightarrow> a*b ~ a'*b'.
   Our notion of right congruence induced by K: rcong K appears only in
   the context where K is a normal subgroup.  Jacobson doesn't name it.
   But in this context left and right cosets are identical.
*)

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 )
qed

subsubsection{*Two Distinct Right Cosets are Disjoint*}

lemma (in group) rcos_equation:
  assumes "subgroup H G"
  assumes p: "ha \<otimes> a = h \<otimes> b" "a \<in> carrier G" "b \<in> carrier G" "h \<in> H" "ha \<in> H" "hb \<in> H"
  shows "hb \<otimes> a \<in> (\<Union>h\<in>H. {h \<otimes> b})"
proof -
  interpret subgroup H G by fact
  from p show ?thesis apply (rule_tac UN_I [of "hb \<otimes> ((inv ha) \<otimes> h)"])
    apply (simp add: )
    apply (simp add: m_assoc transpose_inv)
    done
qed

lemma (in group) rcos_disjoint:
  assumes "subgroup H G"
  assumes p: "a \<in> rcosets H" "b \<in> rcosets H" "a\<noteq>b"
  shows "a \<inter> b = {}"
proof -
  interpret subgroup H G by fact
  from p show ?thesis
    apply (simp add: RCOSETS_def r_coset_def)
    apply (blast intro: rcos_equation assms sym)
    done
qed

subsection {* Further lemmas for @{text "r_congruent"} *}

text {* The relation is a congruence *}

lemma (in normal) congruent_rcong:
  shows "congruent2 (rcong H) (rcong H) (\<lambda>a b. a \<otimes> b <# H)"
proof (intro congruent2I[of "carrier G" _ "carrier G" _] equiv_rcong is_group)
  fix a b c
  assume abrcong: "(a, b) \<in> rcong H"
    and ccarr: "c \<in> carrier G"

  from abrcong
      have acarr: "a \<in> carrier G"
        and bcarr: "b \<in> carrier G"
        and abH: "inv a \<otimes> b \<in> H"
      unfolding r_congruent_def
      by fast+

  note carr = acarr bcarr ccarr

  from ccarr and abH
      have "inv c \<otimes> (inv a \<otimes> b) \<otimes> c \<in> H" by (rule inv_op_closed1)
  moreover
      from carr and inv_closed
      have "inv c \<otimes> (inv a \<otimes> b) \<otimes> c = (inv c \<otimes> inv a) \<otimes> (b \<otimes> c)"
      by (force cong: m_assoc)
  moreover
      from carr and inv_closed
      have "\<dots> = (inv (a \<otimes> c)) \<otimes> (b \<otimes> c)"
      by (simp add: inv_mult_group)
  ultimately
      have "(inv (a \<otimes> c)) \<otimes> (b \<otimes> c) \<in> H" by simp
  from carr and this
     have "(b \<otimes> c) \<in> (a \<otimes> c) <# H"
     by (simp add: lcos_module_rev[OF is_group])
  from carr and this and is_subgroup
     show "(a \<otimes> c) <# H = (b \<otimes> c) <# H" by (intro l_repr_independence, simp+)
next
  fix a b c
  assume abrcong: "(a, b) \<in> rcong H"
    and ccarr: "c \<in> carrier G"

  from ccarr have "c \<in> Units G" by simp
  hence cinvc_one: "inv c \<otimes> c = \<one>" by (rule Units_l_inv)

  from abrcong
      have acarr: "a \<in> carrier G"
       and bcarr: "b \<in> carrier G"
       and abH: "inv a \<otimes> b \<in> H"
      by (unfold r_congruent_def, fast+)

  note carr = acarr bcarr ccarr

  from carr and inv_closed
     have "inv a \<otimes> b = inv a \<otimes> (\<one> \<otimes> b)" by simp
  also from carr and inv_closed
      have "\<dots> = inv a \<otimes> (inv c \<otimes> c) \<otimes> b" by simp
  also from carr and inv_closed
      have "\<dots> = (inv a \<otimes> inv c) \<otimes> (c \<otimes> b)" by (force cong: m_assoc)
  also from carr and inv_closed
      have "\<dots> = inv (c \<otimes> a) \<otimes> (c \<otimes> b)" by (simp add: inv_mult_group)
  finally
      have "inv a \<otimes> b = inv (c \<otimes> a) \<otimes> (c \<otimes> b)" .
  from abH and this
      have "inv (c \<otimes> a) \<otimes> (c \<otimes> b) \<in> H" by simp

  from carr and this
     have "(c \<otimes> b) \<in> (c \<otimes> a) <# H"
     by (simp add: lcos_module_rev[OF is_group])
  from carr and this and is_subgroup
     show "(c \<otimes> a) <# H = (c \<otimes> b) <# H" by (intro l_repr_independence, simp+)
qed

subsection {*Order of a Group and Lagrange's Theorem*}

definition
  order :: "('a, 'b) monoid_scheme \<Rightarrow> nat"
  where "order S = card (carrier S)"

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 finite_subset])
done

text{*The next two lemmas support the proof of @{text card_cosets_equal}.*}
lemma (in group) inj_on_f:
    "\<lbrakk>H \<subseteq> carrier G;  a \<in> carrier G\<rbrakk> \<Longrightarrow> inj_on (\<lambda>y. y \<otimes> inv a) (H #> a)"
apply (rule inj_onI)
apply (subgoal_tac "x \<in> carrier G & y \<in> carrier G")
 prefer 2 apply (blast intro: r_coset_subset_G [THEN subsetD])
apply (simp add: subsetD)
done

lemma (in group) inj_on_g:
    "\<lbrakk>H \<subseteq> carrier G;  a \<in> carrier G\<rbrakk> \<Longrightarrow> inj_on (\<lambda>y. y \<otimes> a) H"
by (force simp add: inj_on_def subsetD)

lemma (in group) card_cosets_equal:
     "\<lbrakk>c \<in> rcosets H;  H \<subseteq> carrier G; finite(carrier G)\<rbrakk>
      \<Longrightarrow> card c = card H"
apply (auto simp add: RCOSETS_def)
apply (rule card_bij_eq)
     apply (rule inj_on_f, assumption+)
    apply (force simp add: m_assoc subsetD r_coset_def)
   apply (rule inj_on_g, assumption+)
  apply (force simp add: m_assoc subsetD r_coset_def)
 txt{*The sets @{term "H #> a"} and @{term "H"} are finite.*}
 apply (simp add: r_coset_subset_G [THEN finite_subset])
apply (blast intro: finite_subset)
done

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> card(rcosets H) * card(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 finite_subset])
  apply (simp add: rcosets_part_G)
 apply (simp add: card_cosets_equal subgroup.subset)
apply (simp add: rcos_disjoint)
done

subsection {*Quotient Groups: Factorization of a Group*}

definition
  FactGroup :: "[('a,'b) monoid_scheme, 'a set] \<Rightarrow> ('a set) monoid" (infixl "Mod" 65)
    --{*Actually defined for groups rather than monoids*}
   where "FactGroup G H = \<lparr>carrier = rcosets\<^bsub>G\<^esub> H, mult = set_mult G, one = H\<rparr>"

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
  from _ subgroup_axioms have "H #> \<one> = H"
    by (rule coset_join2) auto
  then show ?thesis
    by (auto simp add: RCOSETS_def)
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 [OF is_group])
  apply (simp add: restrictI 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 mult_FactGroup [simp]: "X \<otimes>\<^bsub>(G Mod H)\<^esub> X' = X <#>\<^bsub>G\<^esub> X'"
  by (simp add: FactGroup_def)

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{*The coset map is a homomorphism from @{term G} to the quotient group
  @{term "G Mod H"}*}
lemma (in normal) r_coset_hom_Mod:
  "(\<lambda>a. H #> a) \<in> hom G (G Mod H)"
  by (auto simp add: FactGroup_def RCOSETS_def Pi_def hom_def rcos_sum)

subsection{*The First Isomorphism Theorem*}

text{*The quotient by the kernel of a homomorphism is isomorphic to the
  range of that homomorphism.*}

definition
  kernel :: "('a, 'm) monoid_scheme \<Rightarrow> ('b, 'n) monoid_scheme \<Rightarrow>  ('a \<Rightarrow> 'b) \<Rightarrow> 'a set"
    --{*the kernel of a homomorphism*}
  where "kernel G H h = {x. 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 is_group)
done

text{*The kernel of a homomorphism is a normal subgroup*}
lemma (in group_hom) normal_kernel: "(kernel G H h) \<lhd> G"
apply (simp add: G.normal_inv_iff subgroup_kernel)
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> {}"
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_the_elem_mem:
  assumes X: "X \<in> carrier (G Mod (kernel G H h))"
  shows "the_elem (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_def g)
  thus ?thesis by (auto simp add: g)
qed

lemma (in group_hom) FactGroup_hom:
     "(\<lambda>X. the_elem (h`X)) \<in> hom (G Mod (kernel G H h)) H"
apply (simp add: hom_def FactGroup_the_elem_mem normal.factorgroup_is_group [OF normal_kernel] group.axioms monoid.m_closed)
proof (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 \<otimes>\<^bsub>H\<^esub> h g'}" using X X'
    by (auto dest!: FactGroup_nonempty
             simp add: set_mult_def image_eq_UN
                       subsetD [OF Xsub] subsetD [OF X'sub])
  thus "the_elem (h ` (X <#> X')) = the_elem (h ` X) \<otimes>\<^bsub>H\<^esub> the_elem (h ` X')"
    by (simp add: all image_eq_UN FactGroup_nonempty X X')
qed

text{*Lemma for the following injectivity result*}
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 \<otimes> g \<otimes> inv g'" in exI)
apply (simp add: G.m_assoc)
done

lemma (in group_hom) FactGroup_inj_on:
     "inj_on (\<lambda>X. the_elem (h ` X)) (carrier (G Mod kernel G H h))"
proof (simp add: inj_on_def, 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'"
    by (force simp add: kernel_def r_coset_def image_def)+
  assume "the_elem (h ` X) = the_elem (h ` X')"
  hence h: "h g = h g'"
    by (simp add: image_eq_UN all FactGroup_nonempty X X')
  show "X=X'" by (rule equalityI) (simp_all add: FactGroup_subset h gX)
qed

text{*If the homomorphism @{term h} is onto @{term H}, then so is the
homomorphism from the quotient group*}
lemma (in group_hom) FactGroup_onto:
  assumes h: "h ` carrier G = carrier H"
  shows "(\<lambda>X. the_elem (h ` X)) ` carrier (G Mod kernel G H h) = carrier H"
proof
  show "(\<lambda>X. the_elem (h ` X)) ` carrier (G Mod kernel G H h) \<subseteq> carrier H"
    by (auto simp add: FactGroup_the_elem_mem)
  show "carrier H \<subseteq> (\<lambda>X. the_elem (h ` X)) ` carrier (G Mod kernel G H h)"
  proof
    fix y
    assume y: "y \<in> carrier H"
    with h obtain g where g: "g \<in> carrier G" "h g = y"
      by (blast elim: equalityE)
    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 "y \<in> (\<lambda>X. the_elem (h ` X)) ` carrier (G Mod kernel G H h)"
      by (auto intro!: bexI simp add: FactGroup_def RCOSETS_def image_eq_UN)
  qed
qed

text{*If @{term h} is a homomorphism from @{term G} onto @{term H}, then the
 quotient group @{term "G Mod (kernel G H h)"} is isomorphic to @{term H}.*}
theorem (in group_hom) FactGroup_iso:
  "h ` carrier G = carrier H
   \<Longrightarrow> (\<lambda>X. the_elem (h`X)) \<in> (G Mod (kernel G H h)) \<cong> H"
by (simp add: iso_def FactGroup_hom FactGroup_inj_on bij_betw_def
              FactGroup_onto)

end