(*<*)
theory Szpilrajn
  imports Main
begin
  (*>*)

text \<open>
  We formalize a more general version of Szpilrajn's extension theorem~@{cite "Szpilrajn:1930"},
  employing the terminology of Bossert and Suzumura~@{cite "Bossert:2010"}. We also formalize
  Theorem 2.7 of their book. Our extension theorem states that any preorder can be extended to a
  total preorder while maintaining its structure. The proof of the extension theorem follows the
  proof presented in the Wikipedia article~@{cite Wiki}.
\<close>

section \<open>Definitions\<close>

subsection \<open>Symmetric and asymmetric factor of a relation\<close>

text \<open>
  According to Bossert and Suzumura, every relation can be partitioned into its symmetric
  and asymmetric factor. The symmetric factor of a relation \<^term>\<open>r\<close> contains all pairs
  \<^term>\<open>(x, y) \<in> r\<close> where \<^term>\<open>(y, x) \<in> r\<close>. Conversely, the asymmetric factor contains all pairs
   where this is not the case. In terms of an order \<^term>\<open>(\<le>)\<close>, the asymmetric factor contains all
  \<^term>\<open>(x, y) \<in> {(x, y) |x y. x \<le> y}\<close> where \<^term>\<open>x < y\<close>.
\<close>
definition sym_factor :: "'a rel \<Rightarrow> 'a rel"
  where "sym_factor r \<equiv> {(x, y) \<in> r. (y, x) \<in> r}"

lemma sym_factor_def': "sym_factor r = r \<inter> r\<inverse>"
  unfolding sym_factor_def by fast

definition asym_factor :: "'a rel \<Rightarrow> 'a rel"
  where "asym_factor r = {(x, y) \<in> r. (y, x) \<notin> r}"

subsubsection \<open>Properties of the symmetric factor\<close>

lemma sym_factorI[intro]: "(x, y) \<in> r \<Longrightarrow> (y, x) \<in> r \<Longrightarrow> (x, y) \<in> sym_factor r"
  unfolding sym_factor_def by blast

lemma sym_factorE[elim?]:
  assumes "(x, y) \<in> sym_factor r" obtains "(x, y) \<in> r" "(y, x) \<in> r"
  using assms[unfolded sym_factor_def] by blast

lemma sym_sym_factor[simp]: "sym (sym_factor r)"
  unfolding sym_factor_def
  by (auto intro!: symI)

lemma trans_sym_factor[simp]: "trans r \<Longrightarrow> trans (sym_factor r)"
  unfolding sym_factor_def' using trans_Int by force

lemma refl_on_sym_factor[simp]: "refl_on A r \<Longrightarrow> refl_on A (sym_factor r)"
  unfolding sym_factor_def
  by (auto intro!: refl_onI dest: refl_onD refl_onD1)

lemma sym_factor_absorb_if_sym[simp]: "sym r \<Longrightarrow> sym_factor r = r"
  unfolding sym_factor_def'
  by (simp add: sym_conv_converse_eq)

lemma sym_factor_idem[simp]: "sym_factor (sym_factor r) = sym_factor r"
  using sym_factor_absorb_if_sym[OF sym_sym_factor] .

lemma sym_factor_reflc[simp]: "sym_factor (r\<^sup>=) = (sym_factor r)\<^sup>="
  unfolding sym_factor_def by auto

lemma sym_factor_Restr[simp]: "sym_factor (Restr r A) = Restr (sym_factor r) A"
  unfolding sym_factor_def by blast

text \<open>
  In contrast to \<^term>\<open>asym_factor\<close>, the \<^term>\<open>sym_factor\<close> is monotone.
\<close>
lemma sym_factor_mono: "r \<subseteq> s \<Longrightarrow> sym_factor r \<subseteq> sym_factor s"
  unfolding sym_factor_def by auto

subsubsection \<open>Properties of the asymmetric factor\<close>

lemma asym_factorI[intro]: "(x, y) \<in> r \<Longrightarrow> (y, x) \<notin> r \<Longrightarrow> (x, y) \<in> asym_factor r"
  unfolding asym_factor_def by blast

lemma asym_factorE[elim?]:
  assumes "(x, y) \<in> asym_factor r" obtains "(x, y) \<in> r"
  using assms unfolding asym_factor_def by blast

lemma refl_not_in_asym_factor[simp]: "(x, x) \<notin> asym_factor r"
  unfolding asym_factor_def by blast

lemma irrefl_asym_factor[simp]: "irrefl (asym_factor r)"
  unfolding asym_factor_def irrefl_def by fast

lemma asym_asym_factor[simp]: "asym (asym_factor r)"
  using irrefl_asym_factor
  by (auto intro!: asymI simp: asym_factor_def)

lemma trans_asym_factor[simp]: "trans r \<Longrightarrow> trans (asym_factor r)"
  unfolding asym_factor_def trans_def by fast

lemma asym_if_irrefl_trans: "irrefl r \<Longrightarrow> trans r \<Longrightarrow> asym r"
  by (intro asymI) (auto simp: irrefl_def trans_def)

lemma antisym_if_irrefl_trans: "irrefl r \<Longrightarrow> trans r \<Longrightarrow> antisym r"
  using antisym_def asym.cases asym_if_irrefl_trans by auto

lemma asym_factor_asym_rel[simp]: "asym r \<Longrightarrow> asym_factor r = r"
  unfolding asym_factor_def
  by (cases r rule: asym.cases) auto

lemma irrefl_trans_asym_factor_id[simp]: "irrefl r \<Longrightarrow> trans r \<Longrightarrow> asym_factor r = r"
  using asym_factor_asym_rel[OF asym_if_irrefl_trans] .

lemma asym_factor_id[simp]: "asym_factor (asym_factor r) = asym_factor r"
  using asym_factor_asym_rel[OF asym_asym_factor] .

lemma asym_factor_rtrancl: "asym_factor (r\<^sup>*) = asym_factor (r\<^sup>+)"
  unfolding asym_factor_def
  by (auto simp add: rtrancl_eq_or_trancl)

lemma asym_factor_Restr[simp]: "asym_factor (Restr r A) = Restr (asym_factor r) A"
  unfolding asym_factor_def by blast

lemma acyclic_asym_factor[simp]: "acyclic r \<Longrightarrow> acyclic (asym_factor r)"
  unfolding asym_factor_def by (auto intro: acyclic_subset)

subsubsection \<open>Relations between symmetric and asymmetric factor\<close>

text \<open>
  We prove that \<^term>\<open>sym_factor\<close> and \<^term>\<open>asym_factor\<close> partition the input relation.
\<close>
lemma sym_asym_factor_Un: "sym_factor r \<union> asym_factor r = r"
  unfolding sym_factor_def asym_factor_def by blast

lemma disjnt_sym_asym_factor[simp]: "disjnt (sym_factor r) (asym_factor r)"
  unfolding disjnt_def
  unfolding sym_factor_def asym_factor_def by blast

lemma Field_sym_asym_factor_Un:
  "Field (sym_factor r) \<union> Field (asym_factor r) = Field r"
  using sym_asym_factor_Un Field_Un by metis

lemma asym_factor_tranclE:
  assumes "(a, b) \<in> (asym_factor r)\<^sup>+" shows "(a, b) \<in> r\<^sup>+"
  using assms sym_asym_factor_Un
  by (metis UnCI subsetI trancl_mono)

subsection \<open>Extension of Orders\<close>

text \<open>
  We use the definition of Bossert and Suzumura for \<open>extends\<close>. The requirement \<^term>\<open>r \<subseteq> R\<close> is
  obvious. The second requirement \<^term>\<open>asym_factor r \<subseteq> asym_factor R\<close> enforces that the
  extension \<^term>\<open>R\<close> maintains all strict preferences of \<^term>\<open>r\<close> (viewing \<^term>\<open>r\<close> as a
  preference relation).
\<close>

definition extends :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> bool"
  where "extends R r \<equiv> r \<subseteq> R \<and> asym_factor r \<subseteq> asym_factor R"

text \<open>
  We define a stronger notion of \<^term>\<open>extends\<close> where we also demand that
  \<^term>\<open>sym_factor R \<subseteq> (sym_factor r)\<^sup>=\<close>. This enforces that the extension does not introduce
  preference cycles between previously unrelated pairs \<^term>\<open>(x, y) \<in> R - r\<close>.
\<close>

definition strict_extends :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> bool"
  where "strict_extends R r \<equiv> extends R r \<and> sym_factor R \<subseteq> (sym_factor r)\<^sup>="

lemma extendsI[intro]: "r \<subseteq> R \<Longrightarrow> asym_factor r \<subseteq> asym_factor R \<Longrightarrow> extends R r"
  unfolding extends_def by (intro conjI)

lemma extendsE:
  assumes "extends R r"
  obtains "r \<subseteq> R" "asym_factor r \<subseteq> asym_factor R"
  using assms unfolding extends_def by blast

lemma trancl_subs_extends_if_trans: "extends r_ext r \<Longrightarrow> trans r_ext \<Longrightarrow> r\<^sup>+ \<subseteq> r_ext"
  unfolding extends_def asym_factor_def
  by (metis subrelI trancl_id trancl_mono)

lemma extends_if_strict_extends: "strict_extends r_ext ext \<Longrightarrow> extends r_ext ext"
  unfolding strict_extends_def by blast

lemma strict_extendsI[intro]:
  assumes "r \<subseteq> R" "asym_factor r \<subseteq> asym_factor R" "sym_factor R \<subseteq> (sym_factor r)\<^sup>="
  shows "strict_extends R r"
  unfolding strict_extends_def using assms by (intro conjI extendsI)

lemma strict_extendsE:
  assumes "strict_extends R r"
  obtains "r \<subseteq> R" "asym_factor r \<subseteq> asym_factor R" "sym_factor R \<subseteq> (sym_factor r)\<^sup>="
  using assms extendsE unfolding strict_extends_def by blast

lemma strict_extends_antisym_Restr:
  assumes "strict_extends R r"
  assumes "antisym (Restr r A)"
  shows "antisym ((R - r) \<union> Restr r A)"
proof(rule antisymI, rule ccontr)
  fix x y assume "(x, y) \<in> (R - r) \<union> Restr r A" "(y, x) \<in> (R - r) \<union> Restr r A" "x \<noteq> y"
  with \<open>strict_extends R r\<close> have "(x, y) \<in> sym_factor R"
    unfolding sym_factor_def by (auto elim!: strict_extendsE)
  with assms \<open>x \<noteq> y\<close> have "(x, y) \<in> sym_factor r"
    by (auto elim!: strict_extendsE)
  then have "(x, y) \<in> r" "(y, x) \<in> r"
    unfolding sym_factor_def by simp_all
  with \<open>antisym (Restr r A)\<close> \<open>x \<noteq> y\<close> \<open>(y, x) \<in> R - r \<union> Restr r A\<close> show False
    using antisymD by fastforce
qed

text \<open>Here we prove that we have no preference cycles between previously unrelated pairs.\<close>
lemma antisym_Diff_if_strict_extends:
  assumes "strict_extends R r"
  shows "antisym (R - r)"
  using strict_extends_antisym_Restr[OF assms, where ?A="{}"] by simp

lemma strict_extends_antisym:
  assumes "strict_extends R r"
  assumes "antisym r"
  shows "antisym R"
  using assms strict_extends_antisym_Restr[OF assms(1), where ?A=UNIV]
  by (auto elim!: strict_extendsE simp: antisym_def)

lemma strict_extends_if_strict_extends_reflc:
  assumes "strict_extends r_ext (r\<^sup>=)"
  shows "strict_extends r_ext r"
proof(intro strict_extendsI)
  from assms show "r \<subseteq> r_ext"
    by (auto elim: strict_extendsE)

  from assms \<open>r \<subseteq> r_ext\<close> show "asym_factor r \<subseteq> asym_factor r_ext"
    unfolding strict_extends_def
    by (auto simp: asym_factor_def sym_factor_def)

  from assms show "sym_factor r_ext \<subseteq> (sym_factor r)\<^sup>="
    by (auto simp: sym_factor_def strict_extends_def)
qed

lemma strict_extends_diff_Id:
  assumes "irrefl r" "trans r"
  assumes "strict_extends r_ext (r\<^sup>=)"
  shows "strict_extends (r_ext - Id) r"
proof(intro strict_extendsI)
  from assms show "r \<subseteq> r_ext - Id"
    by (auto elim: strict_extendsE simp: irrefl_def)

  note antisym_r = antisym_if_irrefl_trans[OF assms(1,2)]
  with assms strict_extends_if_strict_extends_reflc show "asym_factor r \<subseteq> asym_factor (r_ext - Id)"
    unfolding asym_factor_def
    by (auto intro: strict_extends_antisym[THEN antisymD] elim: strict_extendsE transE)

  from assms antisym_r show "sym_factor (r_ext - Id) \<subseteq> (sym_factor r)\<^sup>="
    unfolding sym_factor_def
    by (auto intro: strict_extends_antisym[THEN antisymD])
qed

text \<open>
  Both \<^term>\<open>extends\<close> and \<^term>\<open>strict_extends\<close> form a partial order since they
  are reflexive, transitive, and antisymmetric.
\<close>
lemma shows
    reflp_extends: "reflp extends" and
    transp_extends: "transp extends" and
    antisymp_extends: "antisymp extends"
  unfolding extends_def reflp_def transp_def antisymp_def
  by auto

lemma shows
    reflp_strict_extends: "reflp strict_extends" and
    transp_strict_extends: "transp strict_extends" and
    antisymp_strict_extends: "antisymp strict_extends"
  using reflp_extends transp_extends antisymp_extends
  unfolding strict_extends_def reflp_def transp_def antisymp_def
  by auto

subsection \<open>Missing order definitions\<close>

lemma preorder_onD[dest?]:
  assumes "preorder_on A r"
  shows "refl_on A r" "trans r"
  using assms unfolding preorder_on_def by blast+

lemma preorder_onI[intro]: "refl_on A r \<Longrightarrow> trans r \<Longrightarrow> preorder_on A r"
  unfolding preorder_on_def by (intro conjI)

abbreviation "preorder \<equiv> preorder_on UNIV"

lemma preorder_rtrancl: "preorder (r\<^sup>*)"
  by (intro preorder_onI refl_rtrancl trans_rtrancl)

definition "total_preorder_on A r \<equiv> preorder_on A r \<and> total_on A r"

abbreviation "total_preorder r \<equiv> total_preorder_on UNIV r"

lemma total_preorder_onI[intro]:
  "refl_on A r \<Longrightarrow> trans r \<Longrightarrow> total_on A r \<Longrightarrow> total_preorder_on A r"
  unfolding total_preorder_on_def by (intro conjI preorder_onI)

lemma total_preorder_onD[dest?]:
  assumes "total_preorder_on A r"
  shows "refl_on A r" "trans r" "total_on A r"
  using assms unfolding total_preorder_on_def preorder_on_def by blast+

definition "strict_partial_order r \<equiv> trans r \<and> irrefl r"

lemma strict_partial_orderI[intro]:
  "trans r \<Longrightarrow> irrefl r \<Longrightarrow> strict_partial_order r"
  unfolding strict_partial_order_def by blast

lemma strict_partial_orderD[dest?]:
  assumes "strict_partial_order r"
  shows "trans r" "irrefl r"
  using assms unfolding strict_partial_order_def by blast+

lemma strict_partial_order_acyclic:
  assumes "strict_partial_order r"
  shows "acyclic r"
  by (metis acyclic_irrefl assms strict_partial_order_def trancl_id)

abbreviation "partial_order \<equiv> partial_order_on UNIV"

lemma partial_order_onI[intro]:
  "refl_on A r \<Longrightarrow> trans r \<Longrightarrow> antisym r \<Longrightarrow> partial_order_on A r"
  using partial_order_on_def by blast

lemma linear_order_onI[intro]:
  "refl_on A r \<Longrightarrow> trans r \<Longrightarrow> antisym r \<Longrightarrow> total_on A r \<Longrightarrow> linear_order_on A r"
  using linear_order_on_def by blast

lemma linear_order_onD[dest?]:
  assumes "linear_order_on A r"
  shows "refl_on A r" "trans r" "antisym r" "total_on A r"
  using assms[unfolded linear_order_on_def] partial_order_onD by blast+

text \<open>A typical example is \<^term>\<open>(\<subset>)\<close> on sets:\<close>

lemma strict_partial_order_subset:
  "strict_partial_order {(x,y). x \<subset> y}"
proof
  show "trans {(x,y). x \<subset> y}"
    by (auto simp add: trans_def)
  show "irrefl {(x, y). x \<subset> y}"
    by (simp add: irrefl_def)
qed

text \<open>We already have a definition of a strict linear order in \<^term>\<open>strict_linear_order\<close>.\<close>

section \<open>Extending preorders to total preorders\<close>

text \<open>
  We start by proving that a preorder with two incomparable elements \<^term>\<open>x\<close> and \<^term>\<open>y\<close> can be
  strictly extended to a preorder where \<^term>\<open>x < y\<close>.
\<close>

lemma can_extend_preorder:
  assumes "preorder_on A r"
    and "y \<in> A" "x \<in> A" "(y, x) \<notin> r"
  shows
    "preorder_on A ((insert (x, y) r)\<^sup>+)" "strict_extends ((insert (x, y) r)\<^sup>+) r"
proof -
  note preorder_onD[OF \<open>preorder_on A r\<close>]
  then have "insert (x, y) r \<subseteq> A \<times> A"
    using \<open>y \<in> A\<close> \<open>x \<in> A\<close> refl_on_domain by fast
  with \<open>refl_on A r\<close> show "preorder_on A ((insert (x, y) r)\<^sup>+)"
    by (intro preorder_onI refl_onI trans_trancl)
       (auto simp: trancl_subset_Sigma intro!: r_into_trancl' dest: refl_onD)

  show "strict_extends ((insert (x, y) r)\<^sup>+) r"
  proof(intro strict_extendsI)
    from preorder_onD(2)[OF \<open>preorder_on A r\<close>] \<open>(y, x) \<notin> r\<close>
    show "asym_factor r \<subseteq> asym_factor ((insert (x, y) r)\<^sup>+)"
       unfolding asym_factor_def trancl_insert
       using rtranclD rtrancl_into_trancl1 r_r_into_trancl
       by fastforce

     from assms have "(y, x) \<notin> (insert (x, y) r)\<^sup>+"
       unfolding preorder_on_def trancl_insert
       using refl_onD rtranclD by fastforce
     with \<open>trans r\<close> show "sym_factor ((insert (x, y) r)\<^sup>+) \<subseteq> (sym_factor r)\<^sup>="
       unfolding trancl_insert sym_factor_def by (fastforce intro: rtrancl_trans)
  qed auto
qed

text \<open>
  With this, we can start the proof of our main extension theorem.
  For this we will use a variant of Zorns Lemma, which only considers nonempty chains:
\<close>
lemma Zorns_po_lemma_nonempty:
  assumes po: "Partial_order r"
    and u: "\<And>C. \<lbrakk>C \<in> Chains r; C\<noteq>{}\<rbrakk> \<Longrightarrow> \<exists>u\<in>Field r. \<forall>a\<in>C. (a, u) \<in> r"
    and "r \<noteq> {}"
  shows "\<exists>m\<in>Field r. \<forall>a\<in>Field r. (m, a) \<in> r \<longrightarrow> a = m"
proof -
  from \<open>r \<noteq> {}\<close> obtain x where "x \<in> Field r"
    using FieldI2 by fastforce
  with assms show ?thesis
    using Zorns_po_lemma by (metis empty_iff)
qed

theorem strict_extends_preorder_on:
  assumes "preorder_on A base_r"
  shows "\<exists>r. total_preorder_on A r \<and> strict_extends r base_r"
proof -

  text \<open>
    We define an order on the set of strict extensions of the base relation \<^term>\<open>base_r\<close>,
    where \<^term>\<open>r \<le> s\<close> iff \<^term>\<open>strict_extends r base_r\<close> and \<^term>\<open>strict_extends s r\<close>:
  \<close>

  define order_of_orders :: "('a rel) rel" where "order_of_orders =
    Restr {(r, s). strict_extends r base_r \<and> strict_extends s r} {r. preorder_on A r}"

  text \<open>
    We show that this order consists of those relations that are preorders and that strictly extend
    the base relation \<^term>\<open>base_r\<close>
  \<close>

  have Field_order_of_orders: "Field order_of_orders =
    {r. preorder_on A r \<and> strict_extends r base_r}"
    using transp_strict_extends
  proof(safe)
    fix r assume "preorder_on A r" "strict_extends r base_r"
    with reflp_strict_extends have
      "(r, r) \<in> {(r, s). strict_extends r base_r \<and> strict_extends s r}"
      by (auto elim!: reflpE)
    with \<open>preorder_on A r\<close> show "r \<in> Field order_of_orders"
      unfolding order_of_orders_def by (auto simp: Field_def)
  qed (auto simp: order_of_orders_def Field_def elim: transpE)

  text \<open>
    We now show that this set has a maximum and that any maximum of this set is a total preorder
    and as thus is one of the extensions we are looking for.
    We begin by showing the existence of a maximal element using Zorn's lemma.
  \<close>

  have "\<exists>m \<in> Field order_of_orders.
      \<forall>a \<in> Field order_of_orders. (m, a) \<in> order_of_orders \<longrightarrow> a = m"
  proof (rule Zorns_po_lemma_nonempty)

    text \<open>
      Zorn's Lemma requires us to prove that our \<^term>\<open>order_of_orders\<close> is a nonempty partial order
      and that every nonempty chain has an upper bound.
      The partial order property is trivial, since we used \<^term>\<open>strict_extends\<close> for the relation,
      which is a partial order as shown above.
    \<close>

    from reflp_strict_extends transp_strict_extends
    have "Refl {(r, s). strict_extends r base_r \<and> strict_extends s r}"
      unfolding refl_on_def Field_def by (auto elim: transpE reflpE)
    moreover have "trans {(r, s). strict_extends r base_r \<and> strict_extends s r}"
      using transp_strict_extends  by (auto elim: transpE intro: transI)
    moreover have "antisym {(r, s). strict_extends r base_r \<and> strict_extends s r}"
      using antisymp_strict_extends by (fastforce dest: antisympD intro: antisymI)

    ultimately show "Partial_order order_of_orders"
      unfolding order_of_orders_def order_on_defs
      using Field_order_of_orders Refl_Restr trans_Restr antisym_Restr
      by blast

    text \<open>Also, our order is obviously not empty since it contains \<^term>\<open>(base_r, base_r)\<close>:\<close>

    have "(base_r, base_r) \<in> order_of_orders"
      unfolding order_of_orders_def
      using assms reflp_strict_extends by (auto dest: reflpD)
    thus "order_of_orders \<noteq> {}" by force

    text \<open>
      Next we show that each chain has an upper bound.
      For the upper bound we take the union of all relations in the chain.
    \<close>

    show "\<exists>u \<in> Field order_of_orders. \<forall>a \<in> C. (a, u) \<in> order_of_orders"
      if C_def: "C \<in> Chains order_of_orders" and C_nonempty: "C \<noteq> {}"
      for C
    proof (rule bexI[where x="\<Union>C"])

      text \<open>
        Obviously each element in the chain is a strict extension of \<^term>\<open>base_r\<close> by definition
        and as such it is also a preorder.
      \<close>

      have preorder_r: "preorder_on A r" and extends_r: "strict_extends r base_r" if "r \<in> C" for r
        using that C_def[unfolded order_of_orders_def Chains_def] by blast+

      text \<open>
        Because a chain is partially ordered, the union of the chain is reflexive and transitive.
      \<close>

      have total_subs_C: "r \<subseteq> s \<or> s \<subseteq> r" if "r \<in> C" and "s \<in> C" for r s
        using C_def that
        unfolding Chains_def order_of_orders_def strict_extends_def extends_def
        by blast

      have preorder_UnC: "preorder_on A (\<Union>C)"
      proof(intro preorder_onI)
        show "refl_on A (\<Union>C)"
          using preorder_onD(1)[OF preorder_r] C_nonempty
          unfolding refl_on_def by auto

        from total_subs_C show "trans (\<Union>C)"
          using chain_subset_trans_Union[unfolded chain_subset_def]
          by (metis preorder_onD(2)[OF preorder_r])
      qed

      text \<open>We show that \<^term>\<open>\<Union>C\<close> strictly extends the base relation.\<close>

      have strict_extends_UnC: "strict_extends (\<Union>C) base_r"
      proof(intro strict_extendsI)
        note extends_r_unfolded = extends_r[unfolded extends_def strict_extends_def]

        show "base_r \<subseteq> (\<Union>C)"
          using C_nonempty extends_r_unfolded
          by blast

        then show "asym_factor base_r \<subseteq> asym_factor (\<Union>C)"
          using extends_r_unfolded
          unfolding asym_factor_def by auto

        show "sym_factor (\<Union>C) \<subseteq> (sym_factor base_r)\<^sup>="
        proof(safe)
          fix x y assume "(x, y) \<in> sym_factor (\<Union>C)" "(x, y) \<notin> sym_factor base_r"
          then have "(x, y) \<in> \<Union>C" "(y, x) \<in> \<Union>C"
            unfolding sym_factor_def by blast+

          with extends_r obtain c where "c \<in> C" "(x, y) \<in> c" "(y, x) \<in> c"
            "strict_extends c base_r"
            using total_subs_C by blast
          then have "(x, y) \<in> sym_factor c"
            unfolding sym_factor_def by blast
          with \<open>strict_extends c base_r\<close> \<open>(x, y) \<notin> sym_factor base_r\<close>
          show "x = y"
            unfolding strict_extends_def by blast
        qed
      qed

      from preorder_UnC strict_extends_UnC show "(\<Union>C) \<in> Field order_of_orders"
        unfolding Field_order_of_orders by simp

      text \<open>
        Lastly, we prove by contradiction that \<^term>\<open>\<Union>C\<close> is an upper bound for the chain.
      \<close>

      show "\<forall>a \<in> C. (a, \<Union>C) \<in> order_of_orders"
      proof(rule ccontr)
        presume "\<exists>a \<in> C. (a, \<Union>C) \<notin> order_of_orders"
        then obtain m where m: "m \<in> C" "(m, \<Union>C) \<notin> order_of_orders"
          by blast

        hence strict_extends_m: "strict_extends m base_r" "preorder_on A m"
          using extends_r preorder_r by blast+
        with m have "\<not> strict_extends (\<Union>C) m"
          using preorder_UnC unfolding order_of_orders_def by blast

        from m have "m \<subseteq> \<Union>C"
          by blast
        moreover
        have "sym_factor (\<Union>C) \<subseteq> (sym_factor m)\<^sup>="
        proof(safe)
          fix a b
          assume "(a, b) \<in> sym_factor (\<Union> C)" "(a, b) \<notin> sym_factor m"
          then have "(a, b) \<in> sym_factor base_r \<or> (a, b) \<in> Id"
            using strict_extends_UnC[unfolded strict_extends_def] by blast
          with \<open>(a, b) \<notin> sym_factor m\<close> strict_extends_m(1) show "a = b"
            by (auto elim: strict_extendsE simp: sym_factor_mono[THEN in_mono])
        qed
        ultimately
        have "\<not> asym_factor m \<subseteq> asym_factor (\<Union>C)"
          using \<open>\<not> strict_extends (\<Union>C) m\<close> unfolding strict_extends_def extends_def by blast

        then obtain x y where
          "(x, y) \<in> m" "(y, x) \<notin> m" "(x, y) \<in> asym_factor m" "(x, y) \<notin> asym_factor (\<Union>C)"
          unfolding asym_factor_def by blast

        then obtain w where "w \<in> C" "(y, x) \<in> w"
          unfolding asym_factor_def using \<open>m \<in> C\<close> by auto

        with \<open>(y, x) \<notin> m\<close> have "\<not> extends m w"
          unfolding extends_def by auto
        moreover
        from \<open>(x, y) \<in> m\<close> have "\<not> extends w m"
        proof(cases "(x, y) \<in> w")
          case True
          with \<open>(y, x) \<in> w\<close> have "(x, y) \<notin> asym_factor w"
            unfolding asym_factor_def by simp
          with \<open>(x, y) \<in> asym_factor m\<close> show "\<not> extends w m"
            unfolding extends_def by auto
        qed (auto simp: extends_def)

        ultimately show False
          using \<open>m \<in> C\<close> \<open>w \<in> C\<close>
          using C_def[unfolded Chains_def order_of_orders_def strict_extends_def]
          by auto
      qed blast
    qed
  qed

  text \<open>Let our maximal element be named \<^term>\<open>max\<close>:\<close>

  from this obtain max
    where max_field: "max \<in> Field order_of_orders"
      and is_max:
        "\<forall>a\<in>Field order_of_orders. (max, a) \<in> order_of_orders \<longrightarrow> a = max"
    by auto

  from max_field have max_extends_base: "preorder_on A max" "strict_extends max base_r"
    using Field_order_of_orders by blast+

  text \<open>
    We still have to show, that \<^term>\<open>max\<close> is a strict linear order,
    meaning that it is also a total order:
  \<close>

  have "total_on A max"
  proof
    fix x y :: 'a
    assume "x \<noteq> y" "x \<in> A" "y \<in> A"

    show "(x, y) \<in> max \<or> (y, x) \<in> max"
    proof (rule ccontr)

      text \<open>
        Assume that \<^term>\<open>max\<close> is not total, and \<^term>\<open>x\<close> and \<^term>\<open>y\<close> are incomparable.
        Then we can extend \<^term>\<open>max\<close> by setting $x < y$:
      \<close>

      presume "(x, y) \<notin> max" and "(y, x) \<notin> max"
      let ?max' = "(insert (x, y) max)\<^sup>+"

      note max'_extends_max = can_extend_preorder[OF
          \<open>preorder_on A max\<close> \<open>y \<in> A\<close> \<open>x \<in> A\<close> \<open>(y, x) \<notin> max\<close>]

      hence max'_extends_base: "strict_extends ?max' base_r"
        using \<open>strict_extends max base_r\<close> transp_strict_extends by (auto elim: transpE)

      text \<open>The extended relation is greater than \<^term>\<open>max\<close>, which is a contradiction.\<close>

      have "(max, ?max') \<in> order_of_orders"
        using max'_extends_base max'_extends_max max_extends_base
        unfolding order_of_orders_def by simp
      thus False
        using FieldI2 \<open>(x, y) \<notin> max\<close> is_max by fastforce
    qed simp_all
  qed

  with \<open>preorder_on A max\<close> have "total_preorder_on A max"
    unfolding total_preorder_on_def by simp

  with \<open>strict_extends max base_r\<close> show "?thesis" by blast
qed

text \<open>
  With this extension theorem, we can easily prove Szpilrajn's theorem and its equivalent for
  partial orders.
\<close>

corollary partial_order_extension:
  assumes "partial_order_on A r"
  shows "\<exists>r_ext. linear_order_on A r_ext \<and> r \<subseteq> r_ext"
proof -
  from assms strict_extends_preorder_on obtain r_ext where r_ext:
    "total_preorder_on A r_ext" "strict_extends r_ext r"
    unfolding partial_order_on_def by blast

  with assms have "antisym r_ext"
    unfolding partial_order_on_def using strict_extends_antisym by blast

  with assms r_ext have "linear_order_on A r_ext \<and> r \<subseteq> r_ext"
    unfolding total_preorder_on_def order_on_defs strict_extends_def extends_def
    by blast
  then show ?thesis ..
qed

corollary Szpilrajn:
  assumes "strict_partial_order r"
  shows "\<exists>r_ext. strict_linear_order r_ext \<and> r \<subseteq> r_ext"
proof -
  from assms have "partial_order (r\<^sup>=)"
    by (auto simp: antisym_if_irrefl_trans strict_partial_order_def)
  from partial_order_extension[OF this] obtain r_ext where "linear_order r_ext" "(r\<^sup>=) \<subseteq> r_ext"
    by blast
  with assms have "r \<subseteq> r_ext - Id" "strict_linear_order (r_ext - Id)"
    by (auto simp: irrefl_def strict_linear_order_on_diff_Id dest: strict_partial_orderD(2))
  then show ?thesis by blast
qed

corollary acyclic_order_extension:
  assumes "acyclic r"
  shows "\<exists>r_ext. strict_linear_order r_ext \<and> r \<subseteq> r_ext"
proof -
  from assms have "strict_partial_order (r\<^sup>+)"
    unfolding strict_partial_order_def using acyclic_irrefl trans_trancl by blast
  thus ?thesis
    by (meson Szpilrajn r_into_trancl' subset_iff)
qed

section \<open>Consistency\<close>

text \<open>
  As a weakening of transitivity, Suzumura introduces the notion of consistency which rules out
  all preference cycles that contain at least one strict preference.
  Consistency characterises those order relations which can be extended (in terms of \<^term>\<open>extends\<close>)
  to a total order relation.
\<close>

definition consistent :: "'a rel \<Rightarrow> bool"
  where "consistent r = (\<forall>(x, y) \<in> r\<^sup>+. (y, x) \<notin> asym_factor r)"

lemma consistentI: "(\<And>x y. (x, y) \<in> r\<^sup>+ \<Longrightarrow> (y, x) \<notin> asym_factor r) \<Longrightarrow> consistent r"
  unfolding consistent_def by blast

lemma consistent_if_preorder_on[simp]:
  "preorder_on A r \<Longrightarrow> consistent r"
  unfolding preorder_on_def consistent_def asym_factor_def by auto

lemma consistent_asym_factor[simp]: "consistent r \<Longrightarrow> consistent (asym_factor r)"
  unfolding consistent_def
  using asym_factor_tranclE by fastforce

lemma acyclic_asym_factor_if_consistent[simp]: "consistent r \<Longrightarrow> acyclic (asym_factor r)"
  unfolding consistent_def acyclic_def
  using asym_factor_tranclE by (metis case_prodD trancl.simps)

lemma consistent_Restr[simp]: "consistent r \<Longrightarrow> consistent (Restr r A)"
  unfolding consistent_def asym_factor_def
  using trancl_mono by fastforce

text \<open>
  This corresponds to Theorem 2.2~@{cite "Bossert:2010"}.
\<close>
theorem trans_if_refl_total_consistent:
  assumes "refl r" "total r" and "consistent r"
  shows "trans r"
proof
  fix x y z assume "(x, y) \<in> r" "(y, z) \<in> r"

  from \<open>(x, y) \<in> r\<close> \<open>(y, z) \<in> r\<close> have "(x, z) \<in> r\<^sup>+"
    by simp
  hence "(z, x) \<notin> asym_factor r"
    using \<open>consistent r\<close> unfolding consistent_def by blast
  hence "x \<noteq> z \<Longrightarrow> (x, z) \<in> r"
    unfolding asym_factor_def using \<open>total r\<close>
    by (auto simp: total_on_def)
  then show "(x, z) \<in> r"
    apply(cases "x = z")
    using refl_onD[OF \<open>refl r\<close>] by blast+
qed

lemma order_extension_if_consistent:
  assumes "consistent r"
  obtains r_ext where "extends r_ext r" "total_preorder r_ext"
proof -
  from assms have extends: "extends (r\<^sup>*) r"
    unfolding extends_def consistent_def asym_factor_def
    using rtranclD by (fastforce simp: Field_def)
  have preorder: "preorder (r\<^sup>*)"
    unfolding preorder_on_def using refl_on_def trans_def by fastforce

  from strict_extends_preorder_on[OF preorder] extends obtain r_ext where
    "total_preorder r_ext" "extends r_ext r"
    using transpE[OF transp_extends] unfolding strict_extends_def by blast
  then show thesis using that by blast
qed

lemma consistent_if_extends_trans:
  assumes "extends r_ext r" "trans r_ext"
  shows "consistent r"
proof(rule consistentI, standard)
  fix x y assume *: "(x, y) \<in> r\<^sup>+" "(y, x) \<in> asym_factor r"
  with assms have "(x, y) \<in> r_ext"
    using trancl_subs_extends_if_trans[OF assms] by blast
  moreover from * assms have "(x, y) \<notin> r_ext"
    unfolding extends_def asym_factor_def by auto
  ultimately show False by blast
qed

text \<open>
  With Theorem 2.6~@{cite "Bossert:2010"}, we show that \<^term>\<open>consistent\<close> characterises the existence
  of order extensions.
\<close>
corollary order_extension_iff_consistent:
  "(\<exists>r_ext. extends r_ext r \<and> total_preorder r_ext) \<longleftrightarrow> consistent r"
  using order_extension_if_consistent consistent_if_extends_trans
  by (metis total_preorder_onD(2))

text \<open>
  The following theorem corresponds to Theorem 2.7~@{cite "Bossert:2010"}.
  Bossert and Suzumura claim that this theorem generalises Szpilrajn's theorem; however, we cannot
  use the theorem to strictly extend a given order \<^term>\<open>Q\<close>. Therefore, it is not strong enough to
  extend a strict partial order to a strict linear order. It works for total preorders (called
  orderings by Bossert and Suzumura). Unfortunately, we were not able to generalise the theorem
  to allow for strict extensions.
\<close>

theorem general_order_extension_iff_consistent:
  assumes "\<And>x y. \<lbrakk> x \<in> S; y \<in> S; x \<noteq> y \<rbrakk> \<Longrightarrow> (x, y) \<notin> Q\<^sup>+"
  assumes "total_preorder_on S Ord"
  shows "(\<exists>Ext. extends Ext Q \<and> total_preorder Ext \<and> Restr Ext S = Ord)
     \<longleftrightarrow> consistent Q" (is "?ExExt \<longleftrightarrow> _")
proof
  assume "?ExExt"
  then obtain Ext where
    "extends Ext Q"
    "refl Ext" "trans Ext" "total Ext"
    "Restr Ext S = Restr Ord S"
    using total_preorder_onD by fast
  show "consistent Q"
  proof(rule consistentI)
    fix x y assume "(x, y) \<in> Q\<^sup>+"
    with \<open>extends Ext Q\<close> \<open>trans Ext\<close> have "(x, y) \<in> Ext"
      unfolding extends_def by (metis trancl_id trancl_mono)
    then have "(y, x) \<notin> asym_factor Ext"
      unfolding asym_factor_def by blast
    with \<open>extends Ext Q\<close> show "(y, x) \<notin> asym_factor Q"
      unfolding extends_def asym_factor_def by blast
  qed
next
  assume "consistent Q"

  define Q' where "Q' \<equiv> Q\<^sup>* \<union> Ord \<union> Ord O Q\<^sup>* \<union> Q\<^sup>* O Ord \<union> (Q\<^sup>* O Ord) O Q\<^sup>*"

  have "refl (Q\<^sup>*)" "trans (Q\<^sup>*)" "refl_on S Ord" "trans Ord" "total_on S Ord"
    using refl_rtrancl trans_rtrancl total_preorder_onD[OF \<open>total_preorder_on S Ord\<close>]
    by - assumption

  have preorder_Q': "preorder Q'"
  proof
    show "refl Q'"
      unfolding Q'_def refl_on_def by auto

    from \<open>trans (Q\<^sup>*)\<close> \<open>refl_on S Ord\<close> \<open>trans Ord\<close> show "trans Q'"
      unfolding Q'_def[simplified]
      apply(safe intro!: transI)
      unfolding relcomp.simps
      by (metis assms(1) refl_on_domain rtranclD transD)+
  qed

  have "consistent Q'"
    using consistent_if_preorder_on preorder_Q' by blast

  have "extends Q' Q"
  proof(rule extendsI)
    have "Q \<subseteq> Restr (Q\<^sup>*) (Field Q)"
      by (auto intro: FieldI1 FieldI2)
    then show "Q \<subseteq> Q'"
      unfolding Q'_def by blast

    from \<open>consistent Q\<close> have consistentD: "(x, y) \<in> Q\<^sup>+ \<Longrightarrow> (y, x) \<in> Q \<Longrightarrow> (x, y) \<in> Q" for x y
      unfolding consistent_def asym_factor_def using rtranclD by fastforce
    have refl_on_domainE: "\<lbrakk> (x, y) \<in> Ord; x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> P \<rbrakk> \<Longrightarrow> P" for x y P
      using refl_on_domain[OF \<open>refl_on S Ord\<close>] by blast

    show "asym_factor Q \<subseteq> asym_factor Q'"
      unfolding Q'_def asym_factor_def Field_def
      apply(safe)
      using assms(1) consistentD refl_on_domainE
      by (metis r_into_rtrancl rtranclD rtrancl_trancl_trancl)+
  qed

  with strict_extends_preorder_on[OF \<open>preorder Q'\<close>]
  obtain Ext where Ext: "extends Ext Q'" "extends Ext Q" "total_preorder Ext"
    unfolding strict_extends_def
    by (metis transpE transp_extends)

  have not_in_Q': "x \<in> S \<Longrightarrow> y \<in> S \<Longrightarrow> (x, y) \<notin> Ord \<Longrightarrow> (x, y) \<notin> Q'" for x y
    using assms(1) unfolding Q'_def
    apply(safe)
    by (metis \<open>refl_on S Ord\<close> refl_on_def refl_on_domain rtranclD)+

  have "Restr Ext S = Ord"
  proof
    from \<open>extends Ext Q'\<close> have "Ord \<subseteq> Ext"
      unfolding Q'_def extends_def by auto
    with \<open>refl_on S Ord\<close> show "Ord \<subseteq> Restr Ext S"
      using refl_on_domain by fast
  next
    have "(x, y) \<in> Ord" if "x \<in> S" and "y \<in> S" and "(x, y) \<in> Ext" for x y
    proof(rule ccontr)
      assume "(x, y) \<notin> Ord"
      with that not_in_Q' have "(x, y) \<notin> Q'"
        by blast
      with \<open>refl_on S Ord\<close> \<open>total_on S Ord\<close> \<open>x \<in> S\<close> \<open>y \<in> S\<close> \<open>(x, y) \<notin> Ord\<close>
      have "(y, x) \<in> Ord"
        unfolding refl_on_def total_on_def by fast
      hence "(y, x) \<in> Q'"
        unfolding Q'_def by blast
      with \<open>(x, y) \<notin> Q'\<close> \<open>(y, x) \<in> Q'\<close> \<open>extends Ext Q'\<close>
      have "(x, y) \<notin> Ext"
        unfolding extends_def asym_factor_def by auto
      with \<open>(x, y) \<in> Ext\<close> show False by blast
    qed
    then show "Restr Ext S \<subseteq> Ord"
      by blast
  qed

  with Ext show "?ExExt" by blast
qed

section \<open>Strong consistency\<close>

text \<open>
  We define a stronger version of \<^term>\<open>consistent\<close> which requires that the relation does not
  contain hidden preference cycles, i.e. if there is a preference cycle then all the elements
  in the cycle should already be related (in both directions).
  In contrast to consistency which characterises relations that can be extended, strong consistency
  characterises relations that can be extended strictly (cf. \<^term>\<open>strict_extends\<close>).
\<close>

definition "strongly_consistent r \<equiv> sym_factor (r\<^sup>+) \<subseteq> sym_factor (r\<^sup>=)"

lemma consistent_if_strongly_consistent: "strongly_consistent r \<Longrightarrow> consistent r"
  unfolding strongly_consistent_def consistent_def
  by (auto simp: sym_factor_def asym_factor_def)

lemma strongly_consistentI: "sym_factor (r\<^sup>+) \<subseteq> sym_factor (r\<^sup>=) \<Longrightarrow> strongly_consistent r"
  unfolding strongly_consistent_def by blast

lemma strongly_consistent_if_trans_strict_extension:
  assumes "strict_extends r_ext r"
  assumes "trans r_ext"
  shows   "strongly_consistent r"
proof(unfold strongly_consistent_def, standard)
  fix x assume "x \<in> sym_factor (r\<^sup>+)"
  then show "x \<in> sym_factor (r\<^sup>=)"
    using assms trancl_subs_extends_if_trans[OF extends_if_strict_extends]
    by (metis sym_factor_mono strict_extendsE subsetD sym_factor_reflc)
qed

lemma strict_order_extension_if_consistent:
  assumes "strongly_consistent r"
  obtains r_ext where "strict_extends r_ext r" "total_preorder r_ext"
proof -
  from assms have "strict_extends (r\<^sup>+) r"
    unfolding strongly_consistent_def strict_extends_def extends_def asym_factor_def sym_factor_def
    by (auto simp: Field_def dest: tranclD)
  moreover have "strict_extends (r\<^sup>*) (r\<^sup>+)"
    unfolding strict_extends_def extends_def
    by (auto simp: asym_factor_rtrancl sym_factor_def dest: rtranclD)
  ultimately have extends: "strict_extends (r\<^sup>*) r"
    using transpE[OF transp_strict_extends] by blast

  have "preorder (r\<^sup>*)"
    unfolding preorder_on_def using refl_on_def trans_def by fastforce
  from strict_extends_preorder_on[OF this] extends obtain r_ext where
    "total_preorder r_ext" "strict_extends r_ext r"
    using transpE[OF transp_strict_extends] by blast
  then show thesis using that by blast
qed

experiment begin

text \<open>We can instantiate the above theorem to get Szpilrajn's theorem.\<close>
lemma
  assumes "strict_partial_order r"
  shows "\<exists>r_ext. strict_linear_order r_ext \<and> r \<subseteq> r_ext"
proof -
  from assms[unfolded strict_partial_order_def] have "strongly_consistent r" "antisym r"
    unfolding strongly_consistent_def by (simp_all add: antisym_if_irrefl_trans)
  from strict_order_extension_if_consistent[OF this(1)] obtain r_ext
    where "strict_extends r_ext r" "total_preorder r_ext"
    by blast
  with assms[unfolded strict_partial_order_def]
  have "trans (r_ext - Id)" "irrefl (r_ext - Id)" "total (r_ext - Id)" "r \<subseteq> (r_ext - Id)"
    using strict_extends_antisym[OF _ \<open>antisym r\<close>]
    by (auto simp: irrefl_def elim: strict_extendsE intro: trans_diff_Id dest: total_preorder_onD)
  then show ?thesis
    unfolding strict_linear_order_on_def by blast
qed

end

(*<*)
end
(*>*)


(*
  File: FundamentalGroup.thy
  Author: Bohua Zhan

  Construction of the fundamental group.
*)

theory FundamentalGroup
  imports PathHomotopy
begin

section \<open>Definition of fundamental group\<close>

definition is_loop :: "i \<Rightarrow> o" where [rewrite]:
  "is_loop(f) \<longleftrightarrow> (is_path(f) \<and> f`(0\<^sub>\<real>) = f`(1\<^sub>\<real>))"

lemma is_loopI [forward,backward]: "is_path(f) \<Longrightarrow> f`(0\<^sub>\<real>) = f`(1\<^sub>\<real>) \<Longrightarrow> is_loop(f)" by auto2
lemma is_loopD [forward]:
  "is_loop(f) \<Longrightarrow> is_path(f)"
  "is_loop(f) \<Longrightarrow> f`(0\<^sub>\<real>) = f`(1\<^sub>\<real>)" by auto2+
setup {* del_prfstep_thm @{thm is_loop_def} *}

lemma const_is_loop:
  "is_top_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> is_loop(const_mor(I,X,x))" by auto2
setup {* add_forward_prfstep_cond @{thm const_is_loop} [with_term "const_mor(?I,?X,?x)"] *}

lemma product_is_loop:
  "is_loop(f) \<Longrightarrow> is_loop(g) \<Longrightarrow> target_str(f) = target_str(g) \<Longrightarrow> f`(1\<^sub>\<real>) = g`(0\<^sub>\<real>) \<Longrightarrow> is_loop(f \<star> g)" by auto2
setup {* add_forward_prfstep_cond @{thm product_is_loop} [with_term "?f \<star> ?g"] *}

lemma inv_path_is_loop [forward]:
  "is_loop(f) \<Longrightarrow> is_loop(inv_path(f))" by auto2

definition loop_space :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "loop_space(X,x) = {f \<in> I \<rightharpoonup>\<^sub>T X. f`(0\<^sub>\<real>) = x \<and> f`(1\<^sub>\<real>) = x}"
setup {* register_wellform_data ("loop_space(X,x)", ["x \<in>. X"]) *}

definition loop_space_rel :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "loop_space_rel(X,x) = Equiv(loop_space(X,x), \<lambda>f g. path_homotopic(f,g))"
setup {* register_wellform_data ("loop_space_rel(X,x)", ["x \<in>. X"]) *}

lemma loop_spaceI [typing]:
  "is_loop(f) \<Longrightarrow> f \<in> loop_space(target_str(f),f`(0\<^sub>\<real>))" by auto2

lemma loop_spaceD [forward]:
  "f \<in> loop_space(X,x) \<Longrightarrow> is_loop(f) \<and> target_str(f) = X \<and> f`(0\<^sub>\<real>) = x" by auto2
setup {* del_prfstep_thm @{thm loop_space_def} *}

lemma loop_space_rel_is_rel [typing]:
  "is_top_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> loop_space_rel(X,x) \<in> equiv_space(loop_space(X,x))" by auto2

lemma loop_space_rel_eval:
  "is_top_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> \<R> = loop_space_rel(X,x) \<Longrightarrow>
   f \<in>. \<R> \<Longrightarrow> g \<in>. \<R> \<Longrightarrow> f \<sim>\<^sub>\<R> g \<longleftrightarrow> path_homotopic(f,g)" by auto2
setup {* add_rewrite_rule_cond @{thm loop_space_rel_eval} [with_cond "?f \<noteq> ?g"] *}
setup {* del_prfstep_thm @{thm loop_space_rel_def} *}

lemma const_mor_in_rel [typing]:
  "is_top_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> \<R> = loop_space_rel(X,x) \<Longrightarrow> const_mor(I,X,x) \<in>. \<R>" by auto2

definition loop_classes :: "i \<Rightarrow> i \<Rightarrow> i" where loop_classes [rewrite_bidir]:
  "loop_classes(X,x) = loop_space(X,x) // loop_space_rel(X,x)"
setup {* register_wellform_data ("loop_classes(X,x)", ["x \<in>. X"]) *}

definition fundamental_group :: "i \<Rightarrow> i \<Rightarrow> i" ("\<pi>\<^sub>1") where [rewrite]:
  "\<pi>\<^sub>1(X,x) = (let \<R> = loop_space_rel(X,x) in
    Group(loop_classes(X,x), equiv_class(\<R>,const_mor(I,X,x)), \<lambda>f g. equiv_class(\<R>,rep(\<R>,f) \<star> rep(\<R>,g))))"
setup {* register_wellform_data ("\<pi>\<^sub>1(X,x)", ["x \<in>. X"]) *}

lemma fundamental_group_group_form:
  "is_top_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> group_form(\<pi>\<^sub>1(X,x))" by auto2
setup {* add_forward_prfstep_cond @{thm fundamental_group_group_form} [with_term "\<pi>\<^sub>1(?X,?x)"] *}

lemma fundamental_group_carrier [rewrite_bidir]:
  "carrier(\<pi>\<^sub>1(X,x)) = loop_classes(X,x)" by auto2

lemma fundamental_group_evals [rewrite]:
  "G = \<pi>\<^sub>1(X,x) \<Longrightarrow> \<one>\<^sub>G = equiv_class(loop_space_rel(X,x),const_mor(I,X,x))"
  "is_top_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> G = \<pi>\<^sub>1(X,x) \<Longrightarrow> \<R> = loop_space_rel(X,x) \<Longrightarrow> f \<in>. G \<Longrightarrow> g \<in>. G \<Longrightarrow>
   f *\<^sub>G g = equiv_class(\<R>,rep(\<R>,f) \<star> rep(\<R>,g))" by auto2+
setup {* del_prfstep_thm @{thm fundamental_group_def} *}

section \<open>Multiplication on the fundamental group\<close>

lemma fundamental_group_mult_compat [resolve]:
  "is_top_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> compat_meta_bin(loop_space_rel(X,x), \<lambda>f g. f \<star> g)" by auto2

lemma fundamental_group_mult_eval [rewrite]:
  "is_top_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> G = \<pi>\<^sub>1(X,x) \<Longrightarrow> \<R> = loop_space_rel(X,x) \<Longrightarrow>
   f \<in>. \<R> \<Longrightarrow> g \<in>. \<R> \<Longrightarrow> equiv_class(\<R>,f) *\<^sub>G equiv_class(\<R>,g) = equiv_class(\<R>,f \<star> g)"
@proof @have "compat_meta_bin(loop_space_rel(X,x), \<lambda>f g. f \<star> g)" @qed
setup {* del_prfstep_thm @{thm fundamental_group_mult_compat} *}
setup {* del_prfstep_thm @{thm fundamental_group_evals(2)} *}

lemma fundamental_group_mult_assoc [rewrite]:
  "is_top_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> G = \<pi>\<^sub>1(X,x) \<Longrightarrow> \<R> = loop_space_rel(X,x) \<Longrightarrow>
   f \<in>. G \<Longrightarrow> g \<in>. G \<Longrightarrow> h \<in>. G \<Longrightarrow> f *\<^sub>G g *\<^sub>G h = f *\<^sub>G (g *\<^sub>G h)"
@proof @let "f' = rep(\<R>,f)" "g' = rep(\<R>,g)" "h' = rep(\<R>,h)" @qed

lemma fundamental_group_mult_id [rewrite]:
  "is_top_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> G = \<pi>\<^sub>1(X,x) \<Longrightarrow> \<R> = loop_space_rel(X,x) \<Longrightarrow>
   f \<in>. G \<Longrightarrow> f *\<^sub>G \<one>\<^sub>G = f"
@proof @let "f' = rep(\<R>,f)" @qed

lemma fundamental_group_mult_id2 [rewrite]:
  "is_top_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> G = \<pi>\<^sub>1(X,x) \<Longrightarrow> \<R> = loop_space_rel(X,x) \<Longrightarrow>
   f \<in>. G \<Longrightarrow> \<one>\<^sub>G *\<^sub>G f = f"
@proof @let "f' = rep(\<R>,f)" @qed

definition fundamental_group_inv :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "fundamental_group_inv(\<R>,f) = equiv_class(\<R>,inv_path(rep(\<R>,f)))"

lemma fundamental_group_inv_typing [typing]:
  "is_top_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> G = \<pi>\<^sub>1(X,x) \<Longrightarrow> \<R> = loop_space_rel(X,x) \<Longrightarrow>
   f \<in>. G \<Longrightarrow> fundamental_group_inv(\<R>,f) \<in>. G" by auto2

lemma fundamental_group_inv2 [rewrite]:
  "is_top_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> G = \<pi>\<^sub>1(X,x) \<Longrightarrow> \<R> = loop_space_rel(X,x) \<Longrightarrow>
   f \<in>. G \<Longrightarrow> fundamental_group_inv(\<R>,f) *\<^sub>G f = \<one>\<^sub>G" by auto2

lemma fundamental_group_is_group:
  "is_top_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> is_group(\<pi>\<^sub>1(X,x))"
@proof
  @let "G = \<pi>\<^sub>1(X,x)" "\<R> = loop_space_rel(X,x)"
  @have "is_monoid(G)"
  @have "\<forall>f\<in>.G. fundamental_group_inv(\<R>,f) *\<^sub>G f = \<one>\<^sub>G"
@qed
setup {* add_forward_prfstep_cond @{thm fundamental_group_is_group} [with_term "\<pi>\<^sub>1(?X,?x)"] *}

setup {* fold del_prfstep_thm [@{thm fundamental_group_mult_assoc},
  @{thm fundamental_group_mult_id}, @{thm fundamental_group_mult_id2},
  @{thm fundamental_group_inv2}] *}

section \<open>Morphisms on fundamental groups\<close>

definition induced_mor :: "i \<Rightarrow> i \<Rightarrow> i" where [rewrite]:
  "induced_mor(k,x) =
    (let X = source_str(k) in let Y = target_str(k) in
     let \<R> = loop_space_rel(X,x) in let \<S> = loop_space_rel(Y,k`x) in
      Mor(\<pi>\<^sub>1(X,x), \<pi>\<^sub>1(Y,k`x), \<lambda>f. equiv_class(\<S>, k \<circ>\<^sub>m rep(\<R>,f))))"
setup {* register_wellform_data ("induced_mor(k,x)", ["x \<in> source(k)"]) *}

lemma induced_mor_is_morphism [typing]:
  "continuous(k) \<Longrightarrow> X = source_str(k) \<Longrightarrow> Y = target_str(k) \<Longrightarrow> x \<in> source(k) \<Longrightarrow>
   induced_mor(k,x) \<in> \<pi>\<^sub>1(X,x) \<rightharpoonup> \<pi>\<^sub>1(Y,k`x)" by auto2

lemma induced_mor_eval [rewrite]:
  "continuous(k) \<Longrightarrow> X = source_str(k) \<Longrightarrow> Y = target_str(k) \<Longrightarrow> x \<in> source(k) \<Longrightarrow>
   \<R> = loop_space_rel(X,x) \<Longrightarrow> \<S> = loop_space_rel(Y,k`x) \<Longrightarrow> f \<in>. \<R> \<Longrightarrow>
   induced_mor(k,x)`equiv_class(\<R>,f) = equiv_class(\<S>, k \<circ>\<^sub>m f)" by auto2
setup {* del_prfstep_thm @{thm induced_mor_def} *}

setup {* add_rewrite_rule_back @{thm path_product_comp} *}
lemma induced_mor_product [rewrite]:
  "continuous(k) \<Longrightarrow> X = source_str(k) \<Longrightarrow> Y = target_str(k) \<Longrightarrow> x \<in> source(k) \<Longrightarrow>
   G = \<pi>\<^sub>1(X,x) \<Longrightarrow> H = \<pi>\<^sub>1(Y,k`x) \<Longrightarrow> f \<in>. G \<Longrightarrow> g \<in>. G \<Longrightarrow>
   induced_mor(k,x)`(f *\<^sub>G g) = induced_mor(k,x)`f *\<^sub>H induced_mor(k,x)`g"
@proof
  @let "\<R> = loop_space_rel(X,x)"
  @let "f' = rep(\<R>,f)" "g' = rep(\<R>,g)"
@qed
setup {* del_prfstep_thm_str "@sym" @{thm path_product_comp} *}

lemma induced_mor_on_id [rewrite]:
  "continuous(k) \<Longrightarrow> X = source_str(k) \<Longrightarrow> Y = target_str(k) \<Longrightarrow> x \<in> source(k) \<Longrightarrow>
   G = \<pi>\<^sub>1(X,x) \<Longrightarrow> H = \<pi>\<^sub>1(Y,k`x) \<Longrightarrow> induced_mor(k,x)`(\<one>\<^sub>G) = \<one>\<^sub>H"
@proof
  @let "\<R> = loop_space_rel(X,x)"
  @have "path_homotopic(k \<circ>\<^sub>m rep(\<R>,\<one>\<^sub>G), k \<circ>\<^sub>m const_mor(I,X,x))"
@qed

lemma induced_mor_is_homomorphism [typing]:
  "continuous(k) \<Longrightarrow> X = source_str(k) \<Longrightarrow> Y = target_str(k) \<Longrightarrow> x \<in> source(k) \<Longrightarrow>
   induced_mor(k,x) \<in> \<pi>\<^sub>1(X,x) \<rightharpoonup>\<^sub>G \<pi>\<^sub>1(Y,k`x)" by auto2

lemma induced_mor_id [rewrite]:
  "is_top_space(X) \<Longrightarrow> x \<in>. X \<Longrightarrow> induced_mor(id_mor(X),x) = id_mor(\<pi>\<^sub>1(X,x))"
@proof
  @let "G = \<pi>\<^sub>1(X,x)" "\<R> = loop_space_rel(X,x)"
  @have (@rule) "\<forall>f\<in>.G. induced_mor(id_mor(X),x)`f = f" @with
    @let "f' = rep(\<R>,f)" @end
@qed

lemma induced_mor_comp' [rewrite]:
  "continuous(k) \<Longrightarrow> continuous(h) \<Longrightarrow> target_str(k) = source_str(h) \<Longrightarrow> x \<in> source(k) \<Longrightarrow>
   X = source_str(k) \<Longrightarrow> G = \<pi>\<^sub>1(X,x) \<Longrightarrow> f \<in>. G \<Longrightarrow> \<R> = loop_space_rel(X,x) \<Longrightarrow>
   induced_mor(h \<circ>\<^sub>m k, x) ` f = induced_mor(h,k`x) ` (induced_mor(k,x) ` f)"
@proof
  @have "f = equiv_class(\<R>,rep(\<R>,f))"
  @have "(h \<circ>\<^sub>m k) \<circ>\<^sub>m rep(\<R>,f) = h \<circ>\<^sub>m (k \<circ>\<^sub>m rep(\<R>,f))"
@qed

lemma induced_mor_comp [rewrite]:
  "continuous(k) \<Longrightarrow> continuous(h) \<Longrightarrow> target_str(k) = source_str(h) \<Longrightarrow> x \<in> source(k) \<Longrightarrow>
   induced_mor(h \<circ>\<^sub>m k, x) = induced_mor(h,k`x) \<circ>\<^sub>m induced_mor(k,x)" by auto2
setup {* del_prfstep_thm @{thm induced_mor_comp'} *}

end


(*
    Title:      Miscellaneous.thy
    Author:     Jose Divasón <jose.divasonm at unirioja.es>
    Author:     Jesús Aransay <jesus-maria.aransay at unirioja.es>
*)

header{*Miscellaneous*}

theory Miscellaneous
imports
  Generalizations
  "$ISABELLE_HOME/src/HOL/Library/Bit"
  Mod_Type
begin

text{*In this file, we present some basic definitions and lemmas about linear algebra and matrices.*}

subsection{*Definitions of number of rows and columns of a matrix*}

definition nrows :: "'a^'columns^'rows => nat"
  where "nrows A = CARD('rows)"

definition ncols :: "'a^'columns^'rows => nat"
  where "ncols A = CARD('columns)"

definition matrix_scalar_mult :: "'a => ('a::semiring_1) ^'n^'m => ('a::semiring_1) ^'n^'m"
    (infixl "*k" 70)
  where "k *k A \<equiv> (\<chi> i j. k * A $ i $ j)"

subsection{*Basic properties about matrices*}

lemma nrows_not_0[simp]:
  shows "0 \<noteq> nrows A" unfolding nrows_def by simp

lemma ncols_not_0[simp]:
  shows "0 \<noteq> ncols A" unfolding ncols_def by simp

lemma nrows_transpose: "nrows (transpose A) = ncols A"
  unfolding nrows_def ncols_def ..

lemma ncols_transpose: "ncols (transpose A) = nrows A"
  unfolding nrows_def ncols_def ..

lemma finite_rows: "finite (rows A)"
  using finite_Atleast_Atmost_nat[of "\<lambda>i. row i A"] unfolding rows_def .

lemma finite_columns: "finite (columns A)"
  using finite_Atleast_Atmost_nat[of "\<lambda>i. column i A"] unfolding columns_def .

lemma matrix_vector_zero: "A *v 0 = 0"
  unfolding matrix_vector_mult_def by (simp add: zero_vec_def)

lemma vector_matrix_zero: "0 v* A = 0"
  unfolding vector_matrix_mult_def by (simp add: zero_vec_def)

lemma vector_matrix_zero': "x v* 0 = 0"
  unfolding vector_matrix_mult_def by (simp add: zero_vec_def)

lemma transpose_vector: "x v* A = transpose A *v x"
  by (unfold matrix_vector_mult_def vector_matrix_mult_def transpose_def, auto)

lemma transpose_zero[simp]: "(transpose A = 0) = (A = 0)"
  unfolding transpose_def zero_vec_def vec_eq_iff by auto

subsection{*Theorems obtained from the AFP*}

text{*The following theorems and definitions have been obtained from the AFP
\url{http://afp.sourceforge.net/browser_info/current/HOL/Tarskis_Geometry/Linear_Algebra2.html}.
I have removed some restrictions over the type classes.*}

lemma vector_matrix_left_distrib:
  (*fixes x y :: "real^('n::finite)" and A :: "real^('m::finite)^'n"*)
  shows "(x + y) v* A = x v* A + y v* A"
  unfolding vector_matrix_mult_def
  by (simp add: algebra_simps setsum.distrib vec_eq_iff)

lemma matrix_vector_right_distrib:
  (*fixes v w :: "real^('n::finite)" and M :: "real^'n^('m::finite)"*)
  shows "M *v (v + w) = M *v v + M *v w"
proof -
  have "M *v (v + w) = (v + w) v* transpose M" by (metis transpose_transpose transpose_vector)
  also have "\<dots> = v v* transpose M + w v* transpose M"
    by (rule vector_matrix_left_distrib [of v w "transpose M"])
  finally show "M *v (v + w) = M *v v + M *v w" by (metis transpose_transpose transpose_vector)
qed

lemma scalar_vector_matrix_assoc:
  fixes k :: "'a::{field}" and x :: "'a::{field}^'n" and A :: "'a^'m^'n"
  shows "(k *s x) v* A = k *s (x v* A)"
  unfolding vector_matrix_mult_def unfolding vec_eq_iff
  by (auto simp add: setsum_right_distrib, rule setsum.cong, simp_all)

lemma vector_scalar_matrix_ac:
  fixes k :: "'a::{field}" and x :: "'a::{field}^'n" and A :: "'a^'m^'n"
  shows "x v* (k *k A) = k *s (x v* A)"
  using scalar_vector_matrix_assoc
  unfolding vector_matrix_mult_def matrix_scalar_mult_def vec_eq_iff
  by (auto simp add: setsum_right_distrib)

lemma transpose_scalar: "transpose (k *k A) = k *k transpose A"
  unfolding transpose_def
  by (vector, simp add: matrix_scalar_mult_def)

lemma scalar_matrix_vector_assoc:
  fixes A :: "'a::{field}^'m^'n"
  shows "k *s (A *v v) = k *k A *v v"
proof -
  have "k *s (A *v v) = k *s (v v* transpose A)" by (metis transpose_transpose transpose_vector)
  also have "\<dots> = v v* (k *k transpose A)"
    by (rule vector_scalar_matrix_ac [symmetric])
  also have "\<dots> = v v* transpose (k *k A)" unfolding transpose_scalar ..
  finally show "k *s (A *v v) = k *k A *v v" by (metis transpose_transpose transpose_vector)
qed

lemma matrix_scalar_vector_ac:
  fixes A :: "'a::{field}^'m^'n"
  shows "A *v (k *s v) = k *k A *v v"
proof -
  have "A *v (k *s v) = k *s (v v* transpose A)"
    by (metis transpose_transpose scalar_vector_matrix_assoc transpose_vector)
  also have "\<dots> = v v* (k *k transpose A)"
    by (subst vector_scalar_matrix_ac) simp
  also have "\<dots> = v v* transpose (k *k A)" by (subst transpose_scalar) simp
  also have "\<dots> = k *k A *v v" by (metis transpose_transpose transpose_vector)
  finally show "A *v (k *s v) = k *k A *v v" .
qed

definition
  is_basis :: "('a::{field}^'n) set => bool" where
  "is_basis S \<equiv> vec.independent S \<and> vec.span S = UNIV"

lemma card_finite:
  assumes "card S = CARD('n::finite)"
  shows "finite S"
proof -
  from `card S = CARD('n)` have "card S \<noteq> 0" by simp
  with card_eq_0_iff [of S] show "finite S" by simp
qed

lemma independent_is_basis:
  fixes B :: "('a::{field}^'n) set"
  shows "vec.independent B \<and> card B = CARD('n) \<longleftrightarrow> is_basis B"
proof
  assume "vec.independent B \<and> card B = CARD('n)"
  hence "vec.independent B" and "card B = CARD('n)" by simp+
  from card_finite [of B, where 'n = 'n] and `card B = CARD('n)`
  have "finite B" by simp
  from `card B = CARD('n)`
  have "card B = vec.dim (UNIV :: (('a^'n) set))" unfolding vec_dim_card .
  with vec.card_eq_dim [of B UNIV] and `finite B` and `vec.independent B`
  have "vec.span B = UNIV" by auto
  with `vec.independent B` show "is_basis B" unfolding is_basis_def ..
next
  assume "is_basis B"
  hence "vec.independent B" unfolding is_basis_def ..
  moreover have "card B = CARD('n)"
  proof -
    have "B \<subseteq> UNIV" by simp
    moreover
    { from `is_basis B` have "UNIV \<subseteq> vec.span B" and "vec.independent B"
        unfolding is_basis_def
        by simp+ }
    ultimately have "card B = vec.dim (UNIV::((real^'n) set))"
      using vec.basis_card_eq_dim [of B UNIV]
      unfolding vec_dim_card
      by simp
    then show "card B = CARD('n)"
      by (metis vec_dim_card)
  qed
  ultimately show "vec.independent B \<and> card B = CARD('n)" ..
qed

text{*Here ends the statements obtained from AFP:
  \url{http://afp.sourceforge.net/browser_info/current/HOL/Tarskis_Geometry/Linear_Algebra2.html}
  which have been generalized.*}

subsection{*Basic properties involving span, linearity and dimensions*}

context finite_dimensional_vector_space
begin

text{*This theorem is the reciprocal theorem of @{thm "indep_card_eq_dim_span"}*}

lemma card_eq_dim_span_indep:
(*fixes A :: "('n::euclidean_space) set"*)
assumes "dim (span A) = card A" and "finite A"
shows "independent A"
by (metis assms card_le_dim_spanning dim_subset equalityE span_inc)

lemma dim_zero_eq:
(*fixes A::"'a::euclidean_space set"*)
assumes dim_A: "dim A = 0"
shows "A = {} \<or> A = {0}"
proof -
obtain B where ind_B: "independent B" and A_in_span_B: "A \<subseteq> span B"
  and card_B: "card B = 0" using basis_exists[of A] unfolding dim_A by blast
have finite_B: "finite B" using indep_card_eq_dim_span[OF ind_B] by simp
hence B_eq_empty: "B={}" using card_B unfolding card_eq_0_iff by simp
have "A \<subseteq> {0}" using A_in_span_B unfolding B_eq_empty span_empty .
thus ?thesis by blast
qed

lemma dim_zero_eq':
  (*fixes A::"'a::euclidean_space set"*)
  assumes A: "A = {} \<or> A = {0}"
  shows "dim A = 0"
proof -
have "card ({}::'b set) = dim A"
  proof (rule basis_card_eq_dim[THEN conjunct2, of "{}::'b set" A])
     show "{} \<subseteq> A" by simp
     show "A \<subseteq> span {}" using A by fastforce
     show "independent {}" by (rule independent_empty)
  qed
thus ?thesis by simp
qed

lemma dim_zero_subspace_eq:
(*  fixes A::"'a::euclidean_space set"*)
assumes subs_A: "subspace A"
shows "(dim A = 0) = (A = {0})" using dim_zero_eq dim_zero_eq' subspace_0[OF subs_A] by auto

context linear
begin

lemma linear_injective_ker_0:
shows "inj f = ({x. f x = 0} = {0})"
unfolding linear_injective_0
using linear_0 by blast

end

lemma snd_if_conv:
shows "snd (if P then (A,B) else (C,D))=(if P then B else D)" by simp

subsection{*Basic properties about matrix multiplication*}

lemma row_matrix_matrix_mult:
fixes A::"'a::{comm_ring_1}^'n^'m"
shows "(P $ i) v* A = (P ** A) $ i"
unfolding vec_eq_iff
unfolding vector_matrix_mult_def unfolding matrix_matrix_mult_def
by (auto intro!: setsum.cong)

corollary row_matrix_matrix_mult':
fixes A::"'a::{comm_ring_1}^'n^'m"
shows "(row i P) v* A = row i (P ** A)"
using row_matrix_matrix_mult unfolding row_def vec_nth_inverse .

lemma column_matrix_matrix_mult:
shows "column i (P**A) = P *v (column i A)"
unfolding column_def matrix_vector_mult_def matrix_matrix_mult_def by fastforce

lemma matrix_matrix_mult_inner_mult:
shows "(A ** B) $ i $ j = row i A \<bullet> column j B"
unfolding inner_vec_def matrix_matrix_mult_def row_def column_def by auto

lemma matrix_vmult_column_sum:
  fixes A::"'a::{field}^'n^'m"
  shows "\<exists>f. A *v x = setsum (\<lambda>y. f y *s y) (columns A)"
proof (rule exI[of _ "\<lambda>y. setsum (\<lambda>i. x $ i) {i. y = column i A}"])
  let ?f="\<lambda>y. setsum (\<lambda>i. x $ i) {i. y = column i A}"
  let ?g="(\<lambda>y. {i. y=column i (A)})"
  have inj: "inj_on ?g (columns (A))" unfolding inj_on_def unfolding columns_def by auto
  have union_univ: "\<Union> (?g`(columns (A))) = UNIV" unfolding columns_def by auto
  have "A *v x = (\<Sum>i\<in>UNIV. x $ i *s column i A)" unfolding matrix_mult_vsum ..
  also have "... = setsum (\<lambda>i.  x $ i *s column i A) (\<Union>(?g`(columns A)))" unfolding union_univ ..
  also have "... = setsum (setsum ((\<lambda>i.  x $ i *s column i A)))  (?g`(columns A))"
    by (rule setsum.Union_disjoint[unfolded o_def], auto)
  also have "... = setsum ((setsum ((\<lambda>i.  x $ i *s column i A))) \<circ> ?g)  (columns A)"
    by (rule setsum.reindex, simp add: inj)
  also have "... =  setsum (\<lambda>y. ?f y *s y) (columns A)"
  proof (rule setsum.cong, unfold o_def)
    fix xa
    have "setsum (\<lambda>i. x $ i *s column i A) {i. xa = column i A}
      = setsum (\<lambda>i. x $ i *s xa) {i. xa = column i A}" by simp
    also have "... = setsum (\<lambda>i. x $ i) {i. xa = column i A} *s xa"
      using vec.scale_setsum_left[of "(\<lambda>i. x $ i)" "{i. xa = column i A}" xa] ..
    finally show "(\<Sum>i | xa = column i A. x $ i *s column i A) = (\<Sum>i | xa = column i A. x $ i) *s xa" .
  qed rule
  finally show "A *v x = (\<Sum>y\<in>columns A. (\<Sum>i | y = column i A. x $ i) *s y)" .
qed

subsection{*Properties about invertibility*}

lemma matrix_inv:
  assumes "invertible M"
  shows matrix_inv_left: "matrix_inv M ** M = mat 1"
  and matrix_inv_right: "M ** matrix_inv M = mat 1"
  using `invertible M` and someI_ex [of "\<lambda> N. M ** N = mat 1 \<and> N ** M = mat 1"]
  unfolding invertible_def and matrix_inv_def
  by simp_all

lemma invertible_mult:
  assumes inv_A: "invertible A"
  and inv_B: "invertible B"
  shows "invertible (A**B)"
proof -
  obtain A' where AA': "A ** A' = mat 1" and A'A: "A' ** A = mat 1"
    using inv_A unfolding invertible_def by blast
  obtain B' where BB': "B ** B' = mat 1" and B'B: "B' ** B = mat 1"
    using inv_B unfolding invertible_def by blast
  show ?thesis
  proof (unfold invertible_def, rule exI[of _ "B'**A'"], rule conjI)
    have "A ** B ** (B' ** A') = A ** (B ** (B' ** A'))"
      using matrix_mul_assoc[of A B "(B' ** A')", symmetric] .
    also have "... = A ** (B ** B' ** A')" unfolding matrix_mul_assoc[of B "B'" "A'"] ..
    also have "... = A ** (mat 1 ** A')" unfolding BB' ..
    also have "... = A ** A'" unfolding matrix_mul_lid ..
    also have "... = mat 1" unfolding AA' ..
    finally show "A ** B ** (B' ** A') = mat (1\<Colon>'a)" .
    have "B' ** A' ** (A ** B) = B' ** (A' ** (A ** B))" using matrix_mul_assoc[of B' A' "(A ** B)", symmetric] .
    also have "... =  B' ** (A' ** A ** B)" unfolding matrix_mul_assoc[of A' A B] ..
    also have "... =  B' ** (mat 1 ** B)" unfolding A'A ..
    also have "... = B' ** B"  unfolding matrix_mul_lid ..
    also have "... = mat 1" unfolding B'B ..
    finally show "B' ** A' ** (A ** B) = mat 1" .
  qed
qed

text{*In the library, @{thm "matrix_inv_def"} allows the use of non squary matrices.
  The following lemma can be also proved fixing @{term "A::'a::{semiring_1}^'n^'m"}*}

lemma matrix_inv_unique:
  fixes A::"'a::{semiring_1}^'n^'n"
  assumes AB: "A ** B = mat 1" and BA: "B ** A = mat 1"
  shows "matrix_inv A = B"
proof (unfold matrix_inv_def, rule some_equality)
  show "A ** B = mat (1\<Colon>'a) \<and> B ** A = mat (1\<Colon>'a)" using AB BA by simp
  fix C assume "A ** C = mat (1\<Colon>'a) \<and> C ** A = mat (1\<Colon>'a)"
  hence AC: "A ** C = mat (1\<Colon>'a)" and CA: "C ** A = mat (1\<Colon>'a)" by auto
  have "B = B ** (mat 1)" unfolding matrix_mul_rid ..
  also have "... = B ** (A**C)" unfolding AC ..
  also have "... = B ** A ** C" unfolding matrix_mul_assoc ..
  also have "... = C" unfolding BA matrix_mul_lid ..
  finally show "C = B" ..
qed

lemma matrix_vector_mult_zero_eq:
assumes P: "invertible P"
shows "((P**A)*v x = 0) = (A *v x = 0)"
proof (rule iffI)
assume "P ** A *v x = 0"
hence "matrix_inv P *v (P ** A *v x) = matrix_inv P *v 0" by simp
hence "matrix_inv P *v (P ** A *v x) =  0" by (metis matrix_vector_zero)
hence "(matrix_inv P ** P ** A) *v x =  0" by (metis matrix_vector_mul_assoc)
thus "A *v x =  0" by (metis assms matrix_inv_left matrix_mul_lid)
next
assume "A *v x = 0"
thus "P ** A *v x = 0" by (metis matrix_vector_mul_assoc matrix_vector_zero)
qed

lemma inj_matrix_vector_mult:
fixes P::"'a::{field}^'n^'m"
assumes P: "invertible P"
shows "inj (op *v P)"
unfolding vec.linear_injective_0
using matrix_left_invertible_ker[of P] P unfolding invertible_def by blast

lemma independent_image_matrix_vector_mult:
fixes P::"'a::{field}^'n^'m"
assumes ind_B: "vec.independent B" and inv_P: "invertible P"
shows "vec.independent ((op *v P)` B)"
proof (rule vec.independent_injective_on_span_image)
  show "vec.independent B" using ind_B .
  show "inj_on (op *v P) (vec.span B)"
    using inj_matrix_vector_mult[OF inv_P] unfolding inj_on_def by simp
qed

lemma independent_preimage_matrix_vector_mult:
fixes P::"'a::{field}^'n^'n"
assumes ind_B: "vec.independent ((op *v P)` B)" and inv_P: "invertible P"
shows "vec.independent B"
proof -
have "vec.independent ((op *v (matrix_inv P))` ((op *v P)` B))"
  proof (rule independent_image_matrix_vector_mult)
    show "vec.independent (op *v P ` B)" using ind_B .
    show "invertible (matrix_inv P)"
      by (metis matrix_inv_left matrix_inv_right inv_P invertible_def)
    qed
moreover have "(op *v (matrix_inv P))` ((op *v P)` B) = B"
    proof (auto)
      fix x assume x: "x \<in> B" show "matrix_inv P *v (P *v x) \<in> B"
      by (metis (full_types) x inv_P matrix_inv_left matrix_vector_mul_assoc matrix_vector_mul_lid)
      thus "x \<in> op *v (matrix_inv P) ` op *v P ` B"
      unfolding image_def
      by (auto, metis  inv_P matrix_inv_left matrix_vector_mul_assoc matrix_vector_mul_lid)
     qed
ultimately show ?thesis by simp
qed

subsection{*Properties about the dimension of vectors*}

lemma dimension_vector[code_unfold]: "vec.dimension TYPE('a::{field}) TYPE('rows::{mod_type})=CARD('rows)"
proof -
let ?f="\<lambda>x. axis (from_nat x) 1::'a^'rows::{mod_type}"
have "vec.dimension TYPE('a::{field}) TYPE('rows::{mod_type}) = card (cart_basis::('a^'rows::{mod_type}) set)"
  unfolding vec.dimension_def ..
also have "... = card{..<CARD('rows)}" unfolding cart_basis_def
  proof (rule bij_betw_same_card[symmetric, of ?f], unfold bij_betw_def, unfold inj_on_def axis_eq_axis, auto)
     fix x y assume x: "x < CARD('rows)" and y: "y < CARD('rows)" and eq: "from_nat x = (from_nat y::'rows)"
     show "x = y" using from_nat_eq_imp_eq[OF eq x y] .
     next
     fix i show "axis i 1 \<in> (\<lambda>x. axis (from_nat x::'rows) 1) ` {..<CARD('rows)}" unfolding image_def
     by (auto, metis lessThan_iff to_nat_from_nat to_nat_less_card)
  qed
also have "... = CARD('rows)" by (metis card_lessThan)
finally show ?thesis .
qed

subsection{*Instantiations and interpretations*}

text{*Functions between two real vector spaces form a real vector*}
instantiation "fun" :: (real_vector, real_vector) real_vector
begin

definition "plus_fun f g = (\<lambda>i. f i + g i)"
definition "zero_fun = (\<lambda>i. 0)"
definition "scaleR_fun a f = (\<lambda>i. a *\<^sub>R f i )"

instance proof
  fix a::"'a \<Rightarrow> 'b" and b::"'a \<Rightarrow> 'b" and c::"'a \<Rightarrow> 'b"
  show "a + b + c = a + (b + c)" unfolding fun_eq_iff unfolding plus_fun_def by auto
  show "a + b = b + a" unfolding fun_eq_iff unfolding plus_fun_def by auto
  show " (0\<Colon>'a \<Rightarrow> 'b) + a = a"  unfolding fun_eq_iff unfolding plus_fun_def zero_fun_def by auto
  show "- a + a = (0\<Colon>'a \<Rightarrow> 'b)" unfolding fun_eq_iff unfolding plus_fun_def zero_fun_def by auto
  show "a - b = a + - b" unfolding fun_eq_iff unfolding plus_fun_def zero_fun_def by auto
next
  fix a::real and x::"('a \<Rightarrow> 'b)" and y::"'a \<Rightarrow> 'b"
  show "a *\<^sub>R (x + y) = a *\<^sub>R x + a *\<^sub>R y"
  unfolding fun_eq_iff plus_fun_def scaleR_fun_def scaleR_right.add by auto
next
  fix a::real and b::real and x::"'a \<Rightarrow> 'b"
  show "(a + b) *\<^sub>R x = a *\<^sub>R x + b *\<^sub>R x"
    unfolding fun_eq_iff unfolding plus_fun_def scaleR_fun_def unfolding  scaleR_left.add by auto
  show " a *\<^sub>R b *\<^sub>R x = (a * b) *\<^sub>R x" unfolding fun_eq_iff unfolding scaleR_fun_def by auto
  show "(1\<Colon>real) *\<^sub>R x = x" unfolding fun_eq_iff unfolding scaleR_fun_def by auto
qed
end

instantiation vec :: (type, finite) equal
begin
definition equal_vec :: "('a, 'b::finite) vec => ('a, 'b::finite) vec => bool"
  where "equal_vec x y = (\<forall>i. x$i = y$i)"
instance
proof (intro_classes)
  fix x y::"('a, 'b::finite) vec"
  show "equal_class.equal x y = (x = y)" unfolding equal_vec_def using vec_eq_iff by auto
qed
end

instantiation bit :: linorder
begin

definition less_eq_bit :: "bit \<Rightarrow> bit \<Rightarrow> bool"
where "less_eq_bit x y = (y=1 \<or> x=0)"

definition less_bit :: "bit \<Rightarrow> bit \<Rightarrow> bool"
where "less_bit x y = (y=1 \<and> x=0)"

instance
proof (intro_classes, auto simp add: less_eq_bit_def less_bit_def)
qed
end

interpretation matrix: vector_space "(op *k)::'a::{field}=>'a^'cols^'rows=>'a^'cols^'rows"
proof (unfold_locales)
fix a::'a and x y::"'a^'cols^'rows"
show "a *k (x + y) = a *k x + a *k y"
  unfolding matrix_scalar_mult_def vec_eq_iff
  by (simp add: vector_space_over_itself.scale_right_distrib)
next
fix a b::'a and x::"'a^'cols^'rows"
show "(a + b) *k x = a *k x + b *k x"
unfolding matrix_scalar_mult_def vec_eq_iff
  by (simp add: comm_semiring_class.distrib)
show "a *k (b *k x) = a * b *k x"
  unfolding matrix_scalar_mult_def vec_eq_iff by auto
show"1 *k x = x" unfolding matrix_scalar_mult_def vec_eq_iff by auto
qed

subsection{*Properties about lists*}

text{*The following definitions and theorems are developed in order to compute setprods.
  More theorems and properties can be demonstrated in a similar way to the ones
  about @{term "listsum"}.*}

definition (in monoid_mult) listprod :: "'a list => 'a" where
  "listprod xs = foldr times xs 1"

lemma (in monoid_mult) listprod_simps [simp]:
  "listprod [] = 1"
  "listprod (x # xs) = x * listprod xs"
  by (simp_all add: listprod_def)

lemma (in monoid_mult) listprod_append [simp]:
  "listprod (xs @ ys) = listprod xs * listprod ys"
  by (induct xs) (simp_all add: mult.assoc)

lemma (in comm_monoid_mult) listprod_rev [simp]:
  "listprod (rev xs) = listprod xs"
  by (simp add: listprod_def foldr_fold fold_rev fun_eq_iff ac_simps)

lemma (in monoid_mult) listprod_distinct_conv_setprod_set:
  "distinct xs ==> listprod (map f xs) = setprod f (set xs)"
  by (induct xs) simp_all

lemma setprod_code [code]:
  "setprod f (set xs) = listprod (map f (remdups xs))"
  by (simp add: listprod_distinct_conv_setprod_set)

end


(*  Title:      HOL/Algebra/Generated_Groups.thy
    Author:     Paulo Emílio de Vilhena
*)

theory Generated_Groups
  imports Group Coset

begin

section \<open>Generated Groups\<close>

inductive_set generate :: "('a, 'b) monoid_scheme \<Rightarrow> 'a set \<Rightarrow> 'a set"
  for G and H where
    one:  "\<one>\<^bsub>G\<^esub> \<in> generate G H"
  | incl: "h \<in> H \<Longrightarrow> h \<in> generate G H"
  | inv:  "h \<in> H \<Longrightarrow> inv\<^bsub>G\<^esub> h \<in> generate G H"
  | eng:  "h1 \<in> generate G H \<Longrightarrow> h2 \<in> generate G H \<Longrightarrow> h1 \<otimes>\<^bsub>G\<^esub> h2 \<in> generate G H"

subsection \<open>Basic Properties\<close>

lemma (in group) generate_consistent:
  assumes "K \<subseteq> H" "subgroup H G" shows "generate (G \<lparr> carrier := H \<rparr>) K = generate G K"
proof
  show "generate (G \<lparr> carrier := H \<rparr>) K \<subseteq> generate G K"
  proof
    fix h assume "h \<in> generate (G \<lparr> carrier := H \<rparr>) K" thus "h \<in> generate G K"
    proof (induction, simp add: one, simp_all add: incl[of _ K G] eng)
      case inv thus ?case
        using m_inv_consistent assms generate.inv[of _ K G] by auto
    qed
  qed
next
  show "generate G K \<subseteq> generate (G \<lparr> carrier := H \<rparr>) K"
  proof
    note gen_simps = one incl eng
    fix h assume "h \<in> generate G K" thus "h \<in> generate (G \<lparr> carrier := H \<rparr>) K"
      using gen_simps[where ?G = "G \<lparr> carrier := H \<rparr>"]
    proof (induction, auto)
      fix h assume "h \<in> K" thus "inv h \<in> generate (G \<lparr> carrier := H \<rparr>) K"
        using m_inv_consistent assms generate.inv[of h K "G \<lparr> carrier := H \<rparr>"] by auto
    qed
  qed
qed

lemma (in group) generate_in_carrier:
  assumes "H \<subseteq> carrier G" and "h \<in> generate G H" shows "h \<in> carrier G"
  using assms(2,1) by (induct h rule: generate.induct) (auto)

lemma (in group) generate_incl:
  assumes "H \<subseteq> carrier G" shows "generate G H \<subseteq> carrier G"
  using generate_in_carrier[OF assms(1)] by auto

lemma (in group) generate_m_inv_closed:
  assumes "H \<subseteq> carrier G" and "h \<in> generate G H" shows "(inv h) \<in> generate G H"
  using assms(2,1)
proof (induction rule: generate.induct, auto simp add: one inv incl)
  fix h1 h2
  assume h1: "h1 \<in> generate G H" "inv h1 \<in> generate G H"
     and h2: "h2 \<in> generate G H" "inv h2 \<in> generate G H"
  hence "inv (h1 \<otimes> h2) = (inv h2) \<otimes> (inv h1)"
    by (meson assms generate_in_carrier group.inv_mult_group is_group)
  thus "inv (h1 \<otimes> h2) \<in> generate G H"
    using generate.eng[OF h2(2) h1(2)] by simp
qed

lemma (in group) generate_is_subgroup:
  assumes "H \<subseteq> carrier G" shows "subgroup (generate G H) G"
  using subgroup.intro[OF generate_incl eng one generate_m_inv_closed] assms by auto

lemma (in group) mono_generate:
  assumes "K \<subseteq> H" shows "generate G K \<subseteq> generate G H"
proof
  fix h assume "h \<in> generate G K" thus "h \<in> generate G H"
    using assms by (induction) (auto simp add: one incl inv eng)
qed

lemma (in group) generate_subgroup_incl:
  assumes "K \<subseteq> H" "subgroup H G" shows "generate G K \<subseteq> H"
  using group.generate_incl[OF subgroup_imp_group[OF assms(2)], of K] assms(1)
  by (simp add: generate_consistent[OF assms])

lemma (in group) generate_minimal:
  assumes "H \<subseteq> carrier G" shows "generate G H = \<Inter> { H'. subgroup H' G \<and> H \<subseteq> H' }"
  using generate_subgroup_incl generate_is_subgroup[OF assms] incl[of _ H] by blast

lemma (in group) generateI:
  assumes "subgroup E G" "H \<subseteq> E" and "\<And>K. \<lbrakk> subgroup K G; H \<subseteq> K \<rbrakk> \<Longrightarrow> E \<subseteq> K"
  shows "E = generate G H"
proof -
  have subset: "H \<subseteq> carrier G"
    using subgroup.subset assms by auto
  show ?thesis
    using assms unfolding generate_minimal[OF subset] by blast
qed

lemma (in group) normal_generateI:
  assumes "H \<subseteq> carrier G" and "\<And>h g. \<lbrakk> h \<in> H; g \<in> carrier G \<rbrakk> \<Longrightarrow> g \<otimes> h \<otimes> (inv g) \<in> H"
  shows "generate G H \<lhd> G"
proof (rule normal_invI[OF generate_is_subgroup[OF assms(1)]])
  fix g h assume g: "g \<in> carrier G" show "h \<in> generate G H \<Longrightarrow> g \<otimes> h \<otimes> (inv g) \<in> generate G H"
  proof (induct h rule: generate.induct)
    case one thus ?case
      using g generate.one by auto
  next
    case incl show ?case
      using generate.incl[OF assms(2)[OF incl g]] .
  next
    case (inv h)
    hence h: "h \<in> carrier G"
      using assms(1) by auto
    hence "inv (g \<otimes> h \<otimes> (inv g)) = g \<otimes> (inv h) \<otimes> (inv g)"
      using g by (simp add: inv_mult_group m_assoc)
    thus ?case
      using generate_m_inv_closed[OF assms(1) generate.incl[OF assms(2)[OF inv g]]] by simp
  next
    case (eng h1 h2)
    note in_carrier = eng(1,3)[THEN generate_in_carrier[OF assms(1)]]
    have "g \<otimes> (h1 \<otimes> h2) \<otimes> inv g = (g \<otimes> h1 \<otimes> inv g) \<otimes> (g \<otimes> h2 \<otimes> inv g)"
      using in_carrier g by (simp add: inv_solve_left m_assoc)
    thus ?case
      using generate.eng[OF eng(2,4)] by simp
  qed
qed

lemma (in group) subgroup_int_pow_closed:
  assumes "subgroup H G" "h \<in> H" shows "h [^] (k :: int) \<in> H"
  using group.int_pow_closed[OF subgroup_imp_group[OF assms(1)]] assms(2)
  unfolding int_pow_consistent[OF assms] by simp

lemma (in group) generate_pow:
  assumes "a \<in> carrier G" shows "generate G { a } = { a [^] (k :: int) | k. k \<in> UNIV }"
proof
  show "{ a [^] (k :: int) | k. k \<in> UNIV } \<subseteq> generate G { a }"
    using subgroup_int_pow_closed[OF generate_is_subgroup[of "{ a }"] incl[of a]] assms by auto
next
  show "generate G { a } \<subseteq> { a [^] (k :: int) | k. k \<in> UNIV }"
  proof
    fix h assume "h \<in> generate G { a }" hence "\<exists>k :: int. h = a [^] k"
    proof (induction, metis int_pow_0[of a], metis singletonD int_pow_1[OF assms])
      case (inv h)
      hence "inv h = a [^] ((- 1) :: int)"
        using assms unfolding int_pow_def2 by simp
      thus ?case
        by blast
    next
      case eng thus ?case
        using assms by (metis int_pow_mult)
    qed
    thus "h \<in> { a [^] (k :: int) | k. k \<in> UNIV }"
      by blast
  qed
qed

corollary (in group) generate_one: "generate G { \<one> } = { \<one> }"
  using generate_pow[of "\<one>", OF one_closed] by simp

corollary (in group) generate_empty: "generate G {} = { \<one> }"
  using mono_generate[of "{}" "{ \<one> }"] generate.one unfolding generate_one by auto

lemma (in group_hom)
  "subgroup K G \<Longrightarrow> subgroup (h ` K) H"
  using subgroup_img_is_subgroup by auto

lemma (in group_hom) generate_img:
  assumes "K \<subseteq> carrier G" shows "generate H (h ` K) = h ` (generate G K)"
proof
  have "h ` K \<subseteq> h ` (generate G K)"
    using incl[of _ K G] by auto
  thus "generate H (h ` K) \<subseteq> h ` (generate G K)"
    using generate_subgroup_incl subgroup_img_is_subgroup[OF G.generate_is_subgroup[OF assms]] by auto
next
  show "h ` (generate G K) \<subseteq> generate H (h ` K)"
  proof
    fix a assume "a \<in> h ` (generate G K)"
    then obtain k where "k \<in> generate G K" "a = h k"
      by blast
    show "a \<in> generate H (h ` K)"
      using \<open>k \<in> generate G K\<close> unfolding \<open>a = h k\<close>
    proof (induct k, auto simp add: generate.one[of H] generate.incl[of _ "h ` K" H])
      case (inv k) show ?case
        using assms generate.inv[of "h k" "h ` K" H] inv by auto
    next
      case eng show ?case
        using generate.eng[OF eng(2,4)] eng(1,3)[THEN G.generate_in_carrier[OF assms]] by auto
    qed
  qed
qed

section \<open>Derived Subgroup\<close>

subsection \<open>Definitions\<close>

abbreviation derived_set :: "('a, 'b) monoid_scheme \<Rightarrow> 'a set \<Rightarrow> 'a set"
  where "derived_set G H \<equiv>
           \<Union>h1 \<in> H. (\<Union>h2 \<in> H. { h1 \<otimes>\<^bsub>G\<^esub> h2 \<otimes>\<^bsub>G\<^esub> (inv\<^bsub>G\<^esub> h1) \<otimes>\<^bsub>G\<^esub> (inv\<^bsub>G\<^esub> h2) })"

definition derived :: "('a, 'b) monoid_scheme \<Rightarrow> 'a set \<Rightarrow> 'a set" where
  "derived G H = generate G (derived_set G H)"

subsection \<open>Basic Properties\<close>

lemma (in group) derived_set_incl:
  assumes "K \<subseteq> H" "subgroup H G" shows "derived_set G K \<subseteq> H"
  using assms(1) subgroupE(3-4)[OF assms(2)] by (auto simp add: subset_iff)

lemma (in group) derived_incl:
  assumes "K \<subseteq> H" "subgroup H G" shows "derived G K \<subseteq> H"
  using generate_subgroup_incl[OF derived_set_incl] assms unfolding derived_def by auto

lemma (in group) derived_set_in_carrier:
  assumes "H \<subseteq> carrier G" shows "derived_set G H \<subseteq> carrier G"
  using derived_set_incl[OF assms subgroup_self] .

lemma (in group) derived_in_carrier:
  assumes "H \<subseteq> carrier G" shows "derived G H \<subseteq> carrier G"
  using derived_incl[OF assms subgroup_self] .

lemma (in group) exp_of_derived_in_carrier:
  assumes "H \<subseteq> carrier G" shows "(derived G ^^ n) H \<subseteq> carrier G"
  using assms derived_in_carrier by (induct n) (auto)

lemma (in group) derived_is_subgroup:
  assumes "H \<subseteq> carrier G" shows "subgroup (derived G H) G"
  unfolding derived_def using generate_is_subgroup[OF derived_set_in_carrier[OF assms]] .

lemma (in group) exp_of_derived_is_subgroup:
  assumes "subgroup H G" shows "subgroup ((derived G ^^ n) H) G"
  using assms derived_is_subgroup subgroup.subset by (induct n) (auto)

lemma (in group) exp_of_derived_is_subgroup':
  assumes "H \<subseteq> carrier G" shows "subgroup ((derived G ^^ (Suc n)) H) G"
  using assms derived_is_subgroup[OF subgroup.subset] derived_is_subgroup by (induct n) (auto)

lemma (in group) mono_derived_set:
  assumes "K \<subseteq> H" shows "derived_set G K \<subseteq> derived_set G H"
  using assms by auto

lemma (in group) mono_derived:
  assumes "K \<subseteq> H" shows "derived G K \<subseteq> derived G H"
  unfolding derived_def using mono_generate[OF mono_derived_set[OF assms]] .

lemma (in group) mono_exp_of_derived:
  assumes "K \<subseteq> H" shows "(derived G ^^ n) K \<subseteq> (derived G ^^ n) H"
  using assms mono_derived by (induct n) (auto)

lemma (in group) derived_set_consistent:
  assumes "K \<subseteq> H" "subgroup H G" shows "derived_set (G \<lparr> carrier := H \<rparr>) K = derived_set G K"
  using m_inv_consistent[OF assms(2)] assms(1) by (auto simp add: subset_iff)

lemma (in group) derived_consistent:
  assumes "K \<subseteq> H" "subgroup H G" shows "derived (G \<lparr> carrier := H \<rparr>) K = derived G K"
  using generate_consistent[OF derived_set_incl] derived_set_consistent assms by (simp add: derived_def)

lemma (in comm_group) derived_eq_singleton:
  assumes "H \<subseteq> carrier G" shows "derived G H = { \<one> }"
proof (cases "derived_set G H = {}")
  case True show ?thesis
    using generate_empty unfolding derived_def True by simp
next
  case False
  have aux_lemma: "h \<in> derived_set G H \<Longrightarrow> h = \<one>" for h
    using assms by (auto simp add: subset_iff)
       (metis (no_types, lifting) m_comm m_closed inv_closed inv_solve_right l_inv l_inv_ex)
  have "derived_set G H = { \<one> }"
  proof
    show "derived_set G H \<subseteq> { \<one> }"
      using aux_lemma by auto
  next
    obtain h where h: "h \<in> derived_set G H"
      using False by blast
    thus "{ \<one> } \<subseteq> derived_set G H"
      using aux_lemma[OF h] by auto
  qed
  thus ?thesis
    using generate_one unfolding derived_def by auto
qed

lemma (in group) derived_is_normal:
  assumes "H \<lhd> G" shows "derived G H \<lhd> G"
proof -
  interpret H: normal H G
    using assms .

  show ?thesis
    unfolding derived_def
  proof (rule normal_generateI[OF derived_set_in_carrier[OF H.subset]])
    fix h g assume "h \<in> derived_set G H" and g: "g \<in> carrier G"
    then obtain h1 h2 where h: "h1 \<in> H" "h2 \<in> H" "h = h1 \<otimes> h2 \<otimes> inv h1 \<otimes> inv h2"
      by auto
    hence in_carrier: "h1 \<in> carrier G" "h2 \<in> carrier G" "g \<in> carrier G"
      using H.subset g by auto
    have "g \<otimes> h \<otimes> inv g =
           g \<otimes> h1 \<otimes> (inv g \<otimes> g) \<otimes> h2 \<otimes> (inv g \<otimes> g) \<otimes> inv h1 \<otimes> (inv g \<otimes> g) \<otimes> inv h2 \<otimes> inv g"
      unfolding h(3) by (simp add: in_carrier m_assoc)
    also have " ... =
          (g \<otimes> h1 \<otimes> inv g) \<otimes> (g \<otimes> h2 \<otimes> inv g) \<otimes> (g \<otimes> inv h1 \<otimes> inv g) \<otimes> (g \<otimes> inv h2 \<otimes> inv g)"
      using in_carrier m_assoc inv_closed m_closed by presburger
    finally have "g \<otimes> h \<otimes> inv g =
          (g \<otimes> h1 \<otimes> inv g) \<otimes> (g \<otimes> h2 \<otimes> inv g) \<otimes> inv (g \<otimes> h1 \<otimes> inv g) \<otimes> inv (g \<otimes> h2 \<otimes> inv g)"
      by (simp add: in_carrier inv_mult_group m_assoc)
    thus "g \<otimes> h \<otimes> inv g \<in> derived_set G H"
      using h(1-2)[THEN H.inv_op_closed2[OF g]] by auto
  qed
qed

lemma (in group) normal_self: "carrier G \<lhd> G"
  by (rule normal_invI[OF subgroup_self], simp)

corollary (in group) derived_self_is_normal: "derived G (carrier G) \<lhd> G"
  using derived_is_normal[OF normal_self] .

corollary (in group) derived_subgroup_is_normal:
  assumes "subgroup H G" shows "derived G H \<lhd> G \<lparr> carrier := H \<rparr>"
  using group.derived_self_is_normal[OF subgroup_imp_group[OF assms]]
        derived_consistent[OF _ assms]
  by simp

corollary (in group) derived_quot_is_group: "group (G Mod (derived G (carrier G)))"
  using normal.factorgroup_is_group[OF derived_self_is_normal] by auto

lemma (in group) derived_quot_is_comm_group: "comm_group (G Mod (derived G (carrier G)))"
proof (rule group.group_comm_groupI[OF derived_quot_is_group], simp add: FactGroup_def)
  interpret DG: normal "derived G (carrier G)" G
    using derived_self_is_normal .

  fix H K assume "H \<in> rcosets derived G (carrier G)" and "K \<in> rcosets derived G (carrier G)"
  then obtain g1 g2
    where g1: "g1 \<in> carrier G" "H = derived G (carrier G) #> g1"
      and g2: "g2 \<in> carrier G" "K = derived G (carrier G) #> g2"
    unfolding RCOSETS_def by auto
  hence "H <#> K = derived G (carrier G) #> (g1 \<otimes> g2)"
    by (simp add: DG.rcos_sum)
  also have " ... = derived G (carrier G) #> (g2 \<otimes> g1)"
  proof -
    { fix g1 g2 assume g1: "g1 \<in> carrier G" and g2: "g2 \<in> carrier G"
      have "derived G (carrier G) #> (g1 \<otimes> g2) \<subseteq> derived G (carrier G) #> (g2 \<otimes> g1)"
      proof
        fix h assume "h \<in> derived G (carrier G) #> (g1 \<otimes> g2)"
        then obtain g' where h: "g' \<in> carrier G" "g' \<in> derived G (carrier G)" "h = g' \<otimes> (g1 \<otimes> g2)"
          using DG.subset unfolding r_coset_def by auto
        hence "h = g' \<otimes> (g1 \<otimes> g2) \<otimes> (inv g1 \<otimes> inv g2 \<otimes> g2 \<otimes> g1)"
          using g1 g2 by (simp add: m_assoc)
        hence "h = (g' \<otimes> (g1 \<otimes> g2 \<otimes> inv g1 \<otimes> inv g2)) \<otimes> (g2 \<otimes> g1)"
          using h(1) g1 g2 inv_closed m_assoc m_closed by presburger
        moreover have "g1 \<otimes> g2 \<otimes> inv g1 \<otimes> inv g2 \<in> derived G (carrier G)"
          using incl[of _ "derived_set G (carrier G)"] g1 g2 unfolding derived_def by blast
        hence "g' \<otimes> (g1 \<otimes> g2 \<otimes> inv g1 \<otimes> inv g2) \<in> derived G (carrier G)"
          using DG.m_closed[OF h(2)] by simp
        ultimately show "h \<in> derived G (carrier G) #> (g2 \<otimes> g1)"
          unfolding r_coset_def by blast
      qed }
    thus ?thesis
      using g1(1) g2(1) by auto
  qed
  also have " ... = K <#> H"
    by (simp add: g1 g2 DG.rcos_sum)
  finally show "H <#> K = K <#> H" .
qed

corollary (in group) derived_quot_of_subgroup_is_comm_group:
  assumes "subgroup H G" shows "comm_group ((G \<lparr> carrier := H \<rparr>) Mod (derived G H))"
  using group.derived_quot_is_comm_group[OF subgroup_imp_group[OF assms]]
        derived_consistent[OF _ assms]
  by simp

proposition (in group) derived_minimal:
  assumes "H \<lhd> G" and "comm_group (G Mod H)" shows "derived G (carrier G) \<subseteq> H"
proof -
  interpret H: normal H G
    using assms(1) .

  show ?thesis
    unfolding derived_def
  proof (rule generate_subgroup_incl[OF _ H.subgroup_axioms])
    show "derived_set G (carrier G) \<subseteq> H"
    proof
      fix h assume "h \<in> derived_set G (carrier G)"
      then obtain g1 g2 where h: "g1 \<in> carrier G" "g2 \<in> carrier G" "h = g1 \<otimes> g2 \<otimes> inv g1 \<otimes> inv g2"
        by auto
      have "H #> (g1 \<otimes> g2) = (H #> g1) <#> (H #> g2)"
        by (simp add: h(1-2) H.rcos_sum)
      also have " ... = (H #> g2) <#> (H #> g1)"
        using comm_groupE(4)[OF assms(2)] h(1-2) unfolding FactGroup_def RCOSETS_def by auto
      also have " ... = H #> (g2 \<otimes> g1)"
        by (simp add: h(1-2) H.rcos_sum)
      finally have "H #> (g1 \<otimes> g2) = H #> (g2 \<otimes> g1)" .
      then obtain h' where "h' \<in> H" "\<one> \<otimes> (g1 \<otimes> g2) = h' \<otimes> (g2 \<otimes> g1)"
        using H.one_closed unfolding r_coset_def by blast
      thus "h \<in> H"
        using h m_assoc by auto
    qed
  qed
qed

proposition (in group) derived_of_subgroup_minimal:
  assumes "K \<lhd> G \<lparr> carrier := H \<rparr>" "subgroup H G" and "comm_group ((G \<lparr> carrier := H \<rparr>) Mod K)"
  shows "derived G H \<subseteq> K"
  using group.derived_minimal[OF subgroup_imp_group[OF assms(2)] assms(1,3)]
        derived_consistent[OF _ assms(2)]
  by simp

lemma (in group_hom) derived_img:
  assumes "K \<subseteq> carrier G" shows "derived H (h ` K) = h ` (derived G K)"
proof -
  have "derived_set H (h ` K) = h ` (derived_set G K)"
  proof
    show "derived_set H (h ` K) \<subseteq> h ` derived_set G K"
    proof
      fix a assume "a \<in> derived_set H (h ` K)"
      then obtain k1 k2
        where "k1 \<in> K" "k2 \<in> K" "a = (h k1) \<otimes>\<^bsub>H\<^esub> (h k2) \<otimes>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h k1) \<otimes>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h k2)"
        by auto
      hence "a = h (k1 \<otimes> k2 \<otimes> inv k1 \<otimes> inv k2)"
        using assms by (simp add: subset_iff)
      from this \<open>k1 \<in> K\<close> and \<open>k2 \<in> K\<close> show "a \<in> h ` derived_set G K" by auto
    qed
  next
    show "h ` (derived_set G K) \<subseteq> derived_set H (h ` K)"
    proof
      fix a assume "a \<in> h ` (derived_set G K)"
      then obtain k1 k2 where "k1 \<in> K" "k2 \<in> K" "a = h (k1 \<otimes> k2 \<otimes> inv k1 \<otimes> inv k2)"
        by auto
      hence "a = (h k1) \<otimes>\<^bsub>H\<^esub> (h k2) \<otimes>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h k1) \<otimes>\<^bsub>H\<^esub> inv\<^bsub>H\<^esub> (h k2)"
        using assms by (simp add: subset_iff)
      from this \<open>k1 \<in> K\<close> and \<open>k2 \<in> K\<close> show "a \<in> derived_set H (h ` K)" by auto
    qed
  qed
  thus ?thesis
    unfolding derived_def using generate_img[OF G.derived_set_in_carrier[OF assms]] by simp
qed

lemma (in group_hom) exp_of_derived_img:
  assumes "K \<subseteq> carrier G" shows "(derived H ^^ n) (h ` K) = h ` ((derived G ^^ n) K)"
  using derived_img[OF G.exp_of_derived_in_carrier[OF assms]] by (induct n) (auto)

end


theory P26 imports Main begin

fun le :: "nat \<Rightarrow> nat list \<Rightarrow> bool" where
"le n Nil = True" |
"le n (x # xs) = (n\<le>x \<and> (le n xs))"

fun sorted :: "nat list \<Rightarrow> bool" where
"sorted Nil = True" |
"sorted (x # xs) = (le x xs \<and> (sorted xs))"

fun count :: "nat list \<Rightarrow> nat \<Rightarrow> nat" where
"count Nil x = 0" |
"count (y # ys) x = (count ys x + (if x=y then 1 else 0))"

fun merge :: "nat list \<Rightarrow> nat list \<Rightarrow> nat list" where
"merge xs Nil = xs" |
"merge Nil ys = ys" |
"merge (x # xs) (y # ys) =
  (if x \<le> y then (x # (merge xs (y # ys)))
  else (y # (merge (x # xs) ys)))"

fun msort :: "nat list \<Rightarrow> nat list" where
"msort Nil = Nil" |
"msort (x # Nil) = (x # Nil)" |
"msort xs = (merge (msort (take ((length xs) div 2) xs))
                   (msort (drop ((length xs) div 2) xs)))"

lemma [simp]: "le x (merge xs ys) = (le x xs \<and> le x ys)"
  apply (induct xs ys rule: merge.induct)
  apply auto
done

lemma [simp]: "sorted (merge xs ys) = (sorted xs \<and> sorted ys)"
  apply (induct xs ys rule: merge.induct)
    apply (auto simp add: linorder_not_le order_less_le)
  done

theorem "sorted (msort xs)"
  apply (induct xs rule: msort.induct)
    apply auto
  done

lemma [simp]: "count (merge xs ys) a = (count xs a) + (count ys a)"
  apply (induct xs ys rule: merge.induct)
    apply auto
  done

lemma [simp]: "count xs a + count ys a = (count (xs @ ys) a)"
  apply (induct xs)
   apply auto
  done

theorem "count (msort xs) x = count xs x"
  apply (induct xs rule: msort.induct)
    apply auto
  done

end