theory N_Properties
imports "UniversalProperty" "HOL.Nat" "Conjugacy_Problem" "Minimal"
begin

section\<open>N-Properties\<close>

text\<open>In this file, we define the properties N0, N1, and N2 [Ref: Lyndon and Schupp]. A key step
in the proof of Nielsen-Schreier, given in Lyndon and Schupp, is that given any
 subgroup of a freegroup, there exists a subset in which all the elements and their
 inverses satisfy the above properties, and the subset generates the subgroup.
In our formalisation we prove that the set of reduced words corresponding to
the elements of such a subset satisfy the properties N0, N1 and N2.\<close>

text\<open>
Our definitions of N0 and N1 resemble the definitions in Lyndon and Schupp. For N2,
we use an equivalent condition, which is not stated in terms of length.
Details of our definitions are available in the text accompanying the definitions
in the file below.

A crucial detail is the definition of the order in N2, which is defined in definition,
lex L2 word'. We use a modified version of it, lex L2 word, with an added condition, which
makes the proof easier.\<close>

text \<open>following helper lemmas prove useful in the theorems below\<close>
lemma one_list:"length xs = 1 \<Longrightarrow> \<exists>x. xs = [x]"
  by (metis append.left_neutral diff_self_eq_0 le_0_eq take0 take_all_iff take_last zero_neq_one)

lemma inverse_neq:"x \<noteq> inverse x"
  by (metis inverse.elims prod.inject)

lemma redelem_unique :
  assumes "X \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle> ))"
    shows "\<exists>!xs  \<in>  X. reduced xs \<and>  ((reln_tuple \<langle>S\<rangle> )`` {xs} = X)"
proof(rule classical)
  assume 1:"\<not>(\<exists>!xs  \<in>  X. reduced xs \<and>  ((reln_tuple \<langle>S\<rangle> )`` {xs} = X))"
  have "\<exists>xs \<in> X. reduced xs \<and> ((reln_tuple \<langle>S\<rangle> )`` {xs} = X)" using assms red_repelem by auto
  then obtain xs where x:"xs  \<in>  X \<and>  reduced xs" by auto
  obtain ys where y:"(ys  \<in>  X \<and>  reduced ys \<and>  (reln_tuple \<langle>S\<rangle> )`` {xs} = X) \<and>  ys \<noteq> xs " using 1 x by (smt (verit, best) assms equiv_class_eq_iff equiv_class_self quotientE quotient_eq_iff reln_equiv)
  then have "(xs, ys)  \<in>  reln_tuple \<langle>S\<rangle> " using x y by blast
  then have "xs ~ ys" using reln_tuple_def by auto
  then have "ys = xs" using x y 1 reduced_cancel_eq reln_imp_cancels by blast
  moreover then have "(reln_tuple \<langle>S\<rangle> )`` {xs} = (reln_tuple \<langle>S\<rangle> )`` {ys}" by simp
  ultimately have False by (simp add: y)
  then show "\<exists>!xs  \<in>  X. reduced xs \<and>  ((reln_tuple \<langle>S\<rangle> )`` {xs} = X)" by simp
qed

text\<open>Given a monoidgetype set S, reduced representation of an element w in the group
generated by the set, is the unique reduced word in the span of S corresponding to
 w. Existence of the reduced representation is proved by the lemma above.\<close>

definition red_rep :: "('a, 'b) monoidgentype set \<Rightarrow> ('a, 'b) word set \<Rightarrow> ('a, 'b) word"
  where "red_rep S X  = (THE xs. xs \<in> X \<and> reduced xs \<and> (X = reln_tuple \<langle>S\<rangle> `` {xs}))"

lemma red_rep_the:
  assumes "X \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>))"
    shows "((red_rep S X) \<in> X)  \<and> reduced ((red_rep S X))
                \<and> (X = reln_tuple \<langle>S\<rangle> `` {(red_rep S X)})"
  unfolding red_rep_def
proof(rule theI')
  show "\<exists>!xs. xs \<in> X \<and> reduced xs \<and> X = reln_tuple \<langle>S\<rangle> `` {xs}" using redelem_unique[of "X" "S"] assms by metis
qed

lemma equivred_equiv:
  assumes "X \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>))"
  shows "\<forall>xs \<in> X. (reln_tuple \<langle>S\<rangle>) `` {xs} = (reln_tuple \<langle>S\<rangle>) `` {red_rep S X}"
proof-
  obtain xs where x:"xs \<in> X" using assms red_repelem by auto
  then have xs: "xs \<in> \<langle>S\<rangle>" using append_congruent assms equiv_2f_clos reln_equiv rightappend_span freewords_on_def by fastforce
  have rw: "red_rep S X \<in> X" using x red_rep_def redelem_unique red_rep_the assms by blast
  then have rs: "red_rep S X \<in> \<langle>S\<rangle>" using assms by (meson quotient_eq_iff refl_onD1 reln_equiv reln_refl)
  then have "(xs,red_rep S X)\<in>(reln_tuple \<langle>S\<rangle>)" using xs x rs rw by (meson assms quotient_eq_iff reln_equiv)
  then have "(reln_tuple \<langle>S\<rangle>) `` {xs} = (reln_tuple \<langle>S\<rangle>) `` {red_rep S X}" by (meson equiv_class_eq_iff reln_equiv)
  then show ?thesis using x assms by (smt (verit, best)  equiv_class_eq_iff quotient_eq_iff reln_equiv)
qed

definition equivinv :: "('a, 'b) monoidgentype set \<Rightarrow> ('a, 'b) word set \<Rightarrow> ('a, 'b) word set"
  where "equivinv S X = (reln_tuple \<langle>S\<rangle> `` {wordinverse (red_rep S X)})"

lemma red_rep_proj_app:
  assumes "X \<in> (\<langle>S\<rangle> // reln_tuple \<langle>S\<rangle>) \<and> Y \<in> (\<langle>S\<rangle> // reln_tuple \<langle>S\<rangle>)"
  shows "((red_rep S (proj_append \<langle>S\<rangle> X Y)))
           = (reduce^^(length ((red_rep S X) @ (red_rep S Y)))) ((red_rep S X) @ (red_rep S Y))"
proof-
  let ?rk = "red_rep S X"
  let ?rm = "red_rep S Y"
  let ?rkm = "((reduce^^(length (?rk@?rm))) (?rk@?rm))"
  have appA:"(?rk@?rm) \<in> \<langle>S\<rangle>" using red_rep_def assms(1) by (smt (verit) append_congruent equiv_2f_clos red_rep_the reln_equiv)
  have 1:"equiv \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle>)" by (simp add: reln_equiv)
  moreover have "(red_rep S X) \<in> \<langle>S\<rangle> \<and> (red_rep S Y) \<in> \<langle>S\<rangle>" using red_rep_def assms calculation in_quotient_imp_subset red_rep_the by blast
  moreover have "proj_append \<langle>S\<rangle> (reln_tuple \<langle>S\<rangle> `` {red_rep S X}) (reln_tuple \<langle>S\<rangle> `` {red_rep S Y}) = reln_tuple \<langle>S\<rangle> `` {red_rep S X @ red_rep S Y}" unfolding proj_append_def using assms append_congruent[of "S"] proj_append_wd[of "red_rep S X" "S" "red_rep S Y"] calculation(2) proj_append_def by blast
  ultimately have 2:"proj_append \<langle>S\<rangle> X Y  = reln_tuple \<langle>S\<rangle> `` {red_rep S X @ red_rep S Y}" using assms
    by (metis red_rep_the)
  then have "(?rkm) ~ (?rk@?rm)" using cancels_imp_rel iter_cancels_to reln.sym by blast
  moreover then have "(?rkm) \<in> \<langle>S\<rangle>" using appA cancels_to_preserves iter_cancels_to by blast
  ultimately have crc: "((?rk@?rm), ?rkm) \<in> reln_tuple \<langle>S\<rangle>" using appA reln_tuple_def by (smt (z3) case_prodI mem_Collect_eq reln.sym)
  then have "(reln_tuple \<langle>S\<rangle>`` {?rkm}) = (reln_tuple \<langle>S\<rangle> `` {?rk@?rm})" using "1" equiv_class_eq_iff by fastforce
  moreover then have a:"?rkm \<in> (reln_tuple \<langle>S\<rangle> `` {?rk@?rm})" using  crc by simp
  moreover have "reduced ?rkm" using reduced_iter_length by blast
  ultimately have "red_rep S (reln_tuple \<langle>S\<rangle> `` {?rk@?rm}) = ?rkm"
    using red_rep_def assms(1) 2
    by (metis (no_types, lifting) proj_append_clos red_rep_the redelem_unique)
  then show ?thesis unfolding proj_append_def using 1 2 assms append_congruent[of "S"] proj_append_wd[of "red_rep S X" "S" "red_rep S Y"] red_rep_def equiv_2f_wd[of "(freewords_on S)" "(reln_tuple (freewords_on S))" "append" "red_rep S X" "red_rep S Y"] by (simp add: proj_append_def)
qed

lemma iter_wordinv:
  assumes "(us @ vs) = (xs@ys@(wordinverse ys)@zs)"
          "reduced (xs@zs)"
    shows "(reduce^^(length (us@vs))) (us@vs) = (xs@zs)"
proof-
  have "(reduce^^(length (ys@(wordinverse ys)))) (ys@(wordinverse ys)) = []" using FreeGroupMain.wordinverse_inverse cancels_imp_iter reln_imp_cancels by fastforce
  then show ?thesis using assms  append.assoc append.left_neutral cancels_eq_leftappend
        cancels_eq_rightappend cancels_imp_iter iter_imp_cancels reduced_iter_eq reduced_iter_length
    by metis
qed

lemma reduced_reln_eq:
"xs ~ ys \<Longrightarrow> reduced xs \<Longrightarrow> reduced ys \<Longrightarrow> xs = ys"
  by (simp add: reduced_cancel_eq reln_imp_cancels)

lemma reln_eq: assumes "reln_tuple \<langle>S\<rangle> `` {xs} = reln_tuple \<langle>S\<rangle> `` {ys}" "xs \<in> \<langle>S\<rangle>" "ys \<in> \<langle>S\<rangle>"
  shows "xs ~ ys"
  using assms unfolding reln_tuple_def by blast

lemma redrep_in:  assumes "xs \<in> carrier (freegroup S)"
  shows "red_rep S xs \<in> \<langle>S\<rangle>"
  using assms red_rep_def red_rep_the unfolding freegroup_def
  using Union_quotient reln_equiv by fastforce

lemma mult_reln:
  assumes "xs \<in> carrier (freegroup S)" "ys \<in> carrier (freegroup S)"
  shows "(red_rep S (xs \<otimes>\<^bsub>F\<^bsub>S\<^esub>\<^esub> ys)) ~ ((red_rep S xs) @ (red_rep S ys))"
proof-
  have "xs = reln_tuple \<langle>S\<rangle> `` {red_rep S xs}" using red_rep_def red_rep_the assms(1) unfolding freegroup_def by fastforce
  moreover have 1:"red_rep S xs \<in> \<langle>S\<rangle>" using assms(1) redrep_in by blast
  moreover have "ys = reln_tuple \<langle>S\<rangle> `` {red_rep S ys}" using red_rep_def red_rep_the assms(2) unfolding freegroup_def by fastforce
  moreover have 2: "red_rep S ys \<in> \<langle>S\<rangle>" using assms(2) redrep_in by blast
  ultimately have "reln_tuple \<langle>S\<rangle> `` {(red_rep S (xs \<otimes>\<^bsub>F\<^bsub>S\<^esub>\<^esub> ys))} = reln_tuple \<langle>S\<rangle> `` {((red_rep S xs) @ (red_rep S ys))}" using proj_append_wd unfolding freegroup_def
    by (metis assms(1) assms(2) freegroup_def monoid.select_convs(1) partial_object.select_convs(1) proj_append_clos red_rep_the)
  moreover have "((red_rep S xs) @ (red_rep S ys)) \<in> \<langle>S\<rangle>" using 1 2 unfolding freewords_on_def by (simp add: span_append)
  moreover have "(red_rep S (xs \<otimes>\<^bsub>F\<^bsub>S\<^esub>\<^esub> ys)) \<in> \<langle>S\<rangle>" by (simp add: assms(1) assms(2) freegroup_is_group group.subgroup_self redrep_in subgroup.m_closed)
  ultimately show ?thesis using reln_eq by auto
qed

text\<open>The following definitions are used to define the order on subgroups\<close>

text\<open>Left subword returns the initial segment with a specified length,
 of the word w\<close>
definition left_subword :: "('a, 'b) word \<Rightarrow> ('a, 'b) word" ("L")
  where
"left_subword xs = take (((length xs+1) div 2)) xs"

text\<open>Left tuple returns a tuple, of the left subword and the left subword of the
inverse of the word.\<close>

definition left_tuple ("L2")
  where "left_tuple xs = (L xs, L (wordinverse xs))"

text\<open>r gen returns a well order on the groupgentype\<close>
definition r_gen
  where
"r_gen = (SOME r :: ('a, 'b) groupgentype rel. Well_order r \<and> Field r = UNIV)"

text\<open>The following lemma uses the Zorn's lemma\<close>
lemma r_gen:
"Well_order r_gen \<and> Field r_gen = UNIV"
  unfolding r_gen_def using someI_ex[of "\<lambda> r. Well_order r \<and> Field r = UNIV"]
            well_ordering
  by (simp add: \<open>\<exists>x. Well_order x \<and> Field x = UNIV \<Longrightarrow> Well_order (SOME x. Well_order x \<and> Field x = UNIV) \<and> Field (SOME x. Well_order x \<and> Field x = UNIV) = UNIV\<close> well_ordering)

lemma wf_r_gen:
"wf (r_gen - Id)"
  using r_gen well_order_on_def by auto

text\<open>lex word is the lexicographical order on the lists, which naturally extends to
 words \<close>
definition lex_word
  where
"lex_word = lenlex (r_gen - Id)"

lemma wf_lex_word:
"wf lex_word"
  unfolding lex_word_def by (simp add: wf_r_gen wf_lenlex)

lemma wf_inv1:
  assumes "wf r"
  shows "wf {(x,y). (f x, f y) \<in> r}"
  by (metis assms inv_image_def wf_inv_image)

fun min
where
"min r (x, y) = (if (x, y) \<in> r then x else y)"

fun max
where
"max r (x, y) = (if (x, y) \<in> r then y else x)"

text\<open>lex L2 word` defines an order on the elements of the group, as defined in
Lyndon and Schupp. It compares two left tuples, by first comparing the minimal
elements of the tuples in the lexicographic order, and if they are equal,
 it compares the maximal elements of tuples in terms of the same.\<close>

definition lex_L2_word'
  where
"lex_L2_word' S = {(X,Y). X \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>))
                          \<and> Y \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>))
           \<and>  ((\<lambda>x. (min lex_word (L2 (red_rep S X)),
      max lex_word (L2 (red_rep S X)))) X ,
     (\<lambda>x. (min lex_word (L2 (red_rep S Y)), max lex_word (L2 (red_rep S Y)))) Y) \<in> (lex_word <*lex*> lex_word)}"

lemma wf_lex_word_prod:
 "wf (lex_word <*lex*> lex_word)"
  by (simp add: wf_lex_prod wf_lex_word)

lemma wf_lex_L2_word':
"wf (lex_L2_word' S)"
proof-
  have "wf {(x,y) . ((\<lambda>x. (min lex_word (L2 (red_rep S x)), max lex_word (L2 (red_rep S x)))) x , (\<lambda>x. (min lex_word (L2 (red_rep S x)), max lex_word (L2 (red_rep S x)))) y) \<in> (lex_word <*lex*> lex_word)}" using wf_inv1 wf_lex_word_prod by fast
  moreover have "lex_L2_word' S \<subseteq> {(x,y) . ((\<lambda>x. (min lex_word (L2 (red_rep S x)), max lex_word (L2 (red_rep S x)))) x , (\<lambda>x. (min lex_word (L2 (red_rep S x)), max lex_word (L2 (red_rep S x)))) y) \<in> (lex_word <*lex*> lex_word)}" unfolding lex_L2_word'_def by auto
  ultimately show ?thesis using wf_subset by blast
qed

definition nat_less :: "(nat \<times> nat) set"
  where
"nat_less = {(x,y). x < y}"

lemma wf_nat_less:
"wf nat_less"
proof-
  have "nat_less = less_than" unfolding nat_less_def less_than_def using less_eq by blast
  then show ?thesis using wf_less_than by argo
qed

lemma wf_lex_L2_word'_prod:
"wf (nat_less <*lex*> lex_L2_word' S)"
  by (simp add: wf_lex_L2_word' wf_lex_prod wf_nat_less)

text\<open>This defines an order on the elements of the group, by first comparing the
lengths of  the reduced representation, and if they are equal, it compares them using the
lex L2 word' order defined above.\<close>

definition lex_L2_word
  where
"lex_L2_word S = ({(X,Y). X \<in>  (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>))
                          \<and>  Y \<in>  (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>))
                          \<and>  (((\<lambda>x. (length (red_rep S x), x))) X,
                                ((\<lambda>x. (length (red_rep S x), x))) Y)
                            \<in> (nat_less <*lex*> lex_L2_word' S)})"

lemma wf_lex_L2_word: "wf (lex_L2_word S)"
proof-
  have "wf {(x,y). ((\<lambda>x. (length (red_rep S x), x)) x, (\<lambda>x. (length (red_rep S x), x)) y) \<in> (nat_less <*lex*> lex_L2_word' S)}" using wf_inv1 wf_lex_L2_word'_prod by fast
  moreover have "lex_L2_word S \<subseteq>{(x,y). ((\<lambda>x. (length (red_rep S x), x)) x, (\<lambda>x. (length (red_rep S x), x)) y) \<in> (nat_less <*lex*> lex_L2_word' S)}" unfolding lex_L2_word_def by auto
  ultimately show ?thesis  using wf_subset by blast
qed

lemma lex_L2_word_length:
  assumes "X \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>)) \<and> Y \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>))"
      and "length ((red_rep S) X) = length ((red_rep S) Y)"
    shows "(X,Y) \<in> (lex_L2_word S) \<longleftrightarrow>  (X,Y) \<in> (lex_L2_word' S)"
  unfolding lex_L2_word_def by (simp add: assms(1) assms(2) wf_nat_less)

lemma lex_L2_word_length_conv:
  assumes "X \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>)) \<and> Y \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>))"
      and "length ((red_rep S) X) = length ((red_rep S) Y)"
    shows "(X,Y) \<in> (lex_L2_word' S) \<Longrightarrow> (X,Y) \<in> (lex_L2_word S)"
  unfolding lex_L2_word_def by (simp add: assms(1) assms(2))

lemma total_Id: "total r \<Longrightarrow> total (r - Id)"
  by simp

lemma total_r_gen_Id: "total (r_gen - Id)"
  using r_gen total_Id unfolding well_order_on_def linear_order_on_def by metis

lemma lex_word_total:
"\<not> (X,Y) \<in> (lex_word) \<Longrightarrow> \<not> (Y,X) \<in> (lex_word) \<Longrightarrow> X = Y"
proof-
  assume "\<not> (X,Y) \<in> (lex_word)" and "\<not> (Y,X) \<in> (lex_word) "
  then show "X = Y" using total_r_gen_Id unfolding lex_word_def by (metis UNIV_I total_lenlex total_on_def)
qed

lemma lex_L2_word_total1:
  assumes "X \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>)) \<and> Y \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>))"
      and "length ((red_rep S) X) = length ((red_rep S) Y)"
    shows "\<not> (X,Y) \<in> (lex_L2_word S) \<Longrightarrow> \<not> (Y,X) \<in> (lex_L2_word S)
            \<Longrightarrow> min lex_word (L2 (red_rep S X)) = min lex_word (L2 (red_rep S Y))
                \<and> max lex_word (L2 (red_rep S X)) = max lex_word (L2 (red_rep S Y))"
proof-
  assume "\<not> (X,Y) \<in> (lex_L2_word S)" and "\<not> (Y,X) \<in> (lex_L2_word S)"
  then have 1: "\<not> (X,Y) \<in> (lex_L2_word' S) \<and> \<not> (Y,X) \<in> (lex_L2_word' S)" using assms lex_L2_word_length by auto
  have "\<not> (min lex_word (L2 (red_rep S X)), min lex_word (L2 (red_rep S Y))) \<in> lex_word"
  proof(rule ccontr)
    assume "\<not> (min lex_word (L2 (red_rep S X)), min lex_word (L2 (red_rep S Y))) \<notin> lex_word"
    then have "(min lex_word (L2 (red_rep S X)), min lex_word (L2 (red_rep S Y))) \<in> lex_word" by blast
    then have "(X,Y) \<in> (lex_L2_word' S)" unfolding lex_L2_word'_def lex_prod_def using assms(1)  by simp
    then show False using 1 by blast
  qed
  moreover have "\<not> (min lex_word (L2 (red_rep S Y)), min lex_word (L2 (red_rep S X))) \<in> lex_word"
  proof(rule ccontr)
    assume "\<not> (min lex_word (L2 (red_rep S Y)), min lex_word (L2 (red_rep S X))) \<notin> lex_word"
    then have "(min lex_word (L2 (red_rep S Y)), min lex_word (L2 (red_rep S X))) \<in> lex_word" by blast
    then have "(Y,X) \<in> (lex_L2_word' S)" unfolding lex_L2_word'_def lex_prod_def using assms(1)  by simp
    then show False using 1 by blast
  qed
  ultimately have min: "min lex_word (L2 (red_rep S X)) = min lex_word (L2 (red_rep S Y))" using lex_word_total by blast
  have "\<not> (max lex_word (L2 (red_rep S X)), max lex_word (L2 (red_rep S Y))) \<in> lex_word"
  proof(rule ccontr)
    assume "\<not> (max lex_word (L2 (red_rep S X)), max lex_word (L2 (red_rep S Y))) \<notin> lex_word"
    then have "(max lex_word (L2 (red_rep S X)), max lex_word (L2 (red_rep S Y))) \<in> lex_word" by blast
    then have "(X,Y) \<in> (lex_L2_word' S)" unfolding lex_L2_word'_def lex_prod_def using assms(1) min  by simp
    then show False using 1 by blast
  qed
  moreover have "\<not> (max lex_word (L2 (red_rep S Y)), max lex_word (L2 (red_rep S X))) \<in> lex_word"
  proof(rule ccontr)
    assume "\<not> (max lex_word (L2 (red_rep S Y)), max lex_word (L2 (red_rep S X))) \<notin> lex_word"
    then have "(max lex_word (L2 (red_rep S Y)), max lex_word (L2 (red_rep S X))) \<in> lex_word" by blast
    then have "(Y,X) \<in> (lex_L2_word' S)" unfolding lex_L2_word'_def lex_prod_def using assms(1) min  by simp
    then show False using 1 by blast
  qed
  ultimately show "min lex_word (L2 (red_rep S X)) = min lex_word (L2 (red_rep S Y)) \<and> max lex_word (L2 (red_rep S X)) = max lex_word (L2 (red_rep S Y))" using min lex_word_total by blast
qed

fun rev_tuple ("\<down>")
  where
"\<down> (x,y) = (y,x)"

lemma lex_L2_word_total2:
"min lex_word (L2 xs) = min lex_word (L2 ys) \<and> max lex_word (L2 xs) = max lex_word (L2 ys) \<Longrightarrow> (L2 xs = L2 ys) \<or> (\<down> (L2 xs) = L2 ys)"
  by (metis left_tuple_def max.simps min.simps rev_tuple.simps)

lemma "(L2 xs = L2 ys) \<or> (\<down> (L2 xs) = L2 ys) \<Longrightarrow> min lex_word (L2 xs) = min lex_word (L2 ys) \<and> max lex_word (L2 xs) = max lex_word (L2 ys)"
  by (metis left_tuple_def lex_word_total max.simps min.simps rev_tuple.simps wf_lex_word wf_not_sym)

text\<open>We right subword on the lines of left subword above.\<close>
definition right_subword ("R")
  where
"right_subword xs =  drop (((length xs+1) div 2)) xs"

lemma length_wordinverse:"length xs = length (wordinverse xs)"
  by (simp add: wordinverse_redef1)

lemma even_div2:
"even (n :: nat) \<Longrightarrow> n - ((n + 1) div 2) = ((n + 1) div 2)"
   by fastforce

lemma odd_div2:
"odd (n :: nat) \<Longrightarrow> n - ((n + 1) div 2) = ((n + 1) div 2) - 1"
  by (metis (no_types, lifting) add_diff_cancel_right add_diff_cancel_right' even_div2 odd_even_add odd_one odd_succ_div_two odd_two_times_div_two_succ)

lemma even_R:
"even (length xs) \<Longrightarrow> L (wordinverse xs) = wordinverse (R xs)"
  unfolding right_subword_def left_subword_def
proof-
  assume "even (length xs)"
  then have 1:"length xs - (length xs + 1) div 2 = (length xs + 1) div 2" using even_div2 by blast
  have "take ((length (wordinverse xs) + 1) div 2) (wordinverse xs) = take ((length xs + 1) div 2) (rev ((map inverse) xs))" by (simp add: wordinverse_redef1)
  moreover then have "... = rev (drop ((length xs + 1) div 2) ((map inverse) xs))" using 1 length_map take_rev by metis
  moreover then have "... = wordinverse (drop ((length xs + 1) div 2) xs)" by (simp add: drop_map wordinverse_redef1)
  ultimately show "take ((length (wordinverse xs) + 1) div 2) (wordinverse xs) =
    wordinverse (drop ((length xs + 1) div 2) xs)" by presburger
qed

lemma take_length:
 "n \<le> length xs \<Longrightarrow>length (take n xs) = n"
  by simp

lemma drop_odd_length: "odd (length xs) \<Longrightarrow> (length (drop ((length xs + 1) div 2 - 1) xs) = ((length xs + 1) div 2))"
proof-
  assume odd:"odd (length xs)"
  then have "length xs > 0" using odd by force
  then have 1:"((length xs + 1) div 2) \<le> length xs" by simp
  have "drop ((length xs + 1) div 2 - 1) (rev xs) = rev (take ((length xs + 1) div 2) xs)" using odd rev_take odd_div2 by metis
  moreover have "length (rev (take ((length xs + 1) div 2) xs)) = ((length xs + 1) div 2)" using 1 take_length length_rev by metis
  moreover have "length (drop ((length xs + 1) div 2 - 1) (rev xs)) = length (drop ((length xs + 1) div 2 - 1) xs)"  by simp
  ultimately show "(length (drop ((length xs + 1) div 2 - 1) xs) = ((length xs + 1) div 2))" by presburger
qed

lemma odd_R:
"odd (length xs) \<Longrightarrow>  take (((length xs+1) div 2) - 1) (L (wordinverse xs)) = wordinverse (R xs)"
  unfolding right_subword_def left_subword_def
proof-
  assume odd:"odd (length xs)"
  then have  1:"length xs - (length xs + 1) div 2 = (length xs + 1) div 2 - 1" using odd_div2 by blast
  have "take ((length xs + 1) div 2 - 1)
     (take ((length (wordinverse xs) + 1) div 2) (wordinverse xs)) =  take ((length xs + 1) div 2 - 1)
     (take ((length xs + 1) div 2) (rev (map inverse xs)))" by (simp add: wordinverse_redef1)
  moreover then have "... = take ((length xs + 1) div 2 - 1) (rev (drop ((length xs + 1) div 2 - 1) ((map inverse) xs)))" using 1 length_map take_rev by metis
  moreover then have "... = rev (drop (length (drop ((length xs + 1) div 2 - 1) ((map inverse) xs)) -  ((length xs + 1) div 2 - 1))  (drop ((length xs + 1) div 2 - 1) ((map inverse) xs)))" using take_rev by blast
  moreover then have "... = rev (drop (((length xs + 1) div 2) -  ((length xs + 1) div 2 - 1))  (drop ((length xs + 1) div 2 - 1) ((map inverse) xs)))" using drop_odd_length length_map odd by metis
  moreover then have "... = rev (drop 1  (drop ((length xs + 1) div 2 - 1) ((map inverse) xs)))" by (simp add: odd)
  moreover then have "... = rev ((drop ((length xs + 1) div 2) ((map inverse) xs)))" by (simp add: odd)
  moreover then have "... = rev ((map inverse) (drop ((length xs + 1) div 2)  xs))" using drop_map by blast
  moreover then have "... = wordinverse (drop ((length xs + 1) div 2) xs)" by (simp add: wordinverse_redef1)
  ultimately show "take ((length xs + 1) div 2 - 1)
     (take ((length (wordinverse xs) + 1) div 2) (wordinverse xs)) =
    wordinverse (drop ((length xs + 1) div 2) xs)" by presburger
qed

lemma LR_eq:
  assumes "L xs = L ys"
          and "R xs = R ys"
        shows "xs = ys"
proof-
  have "L xs @ R xs = xs" unfolding left_subword_def right_subword_def by simp
  moreover have  "L ys @ R ys = ys" unfolding left_subword_def right_subword_def by simp
  ultimately show ?thesis using assms(1,2) by argo
qed

lemma L2_eq:
  assumes "length xs = length ys"
          and "(L2 xs = L2 ys)"
        shows "L xs = L ys \<and> R xs = R ys"
proof(cases "odd (length xs)")
  case True
  have 1: "L xs = L ys" using assms(2) left_tuple_def by (metis prod.inject)
  have "L (wordinverse xs) = L (wordinverse ys)" using assms(2) left_tuple_def by (metis prod.inject)
  then have "take (((length xs+1) div 2) - 1) (L (wordinverse xs)) =  take (((length ys+1) div 2) - 1) (L (wordinverse ys))" using assms(1) by presburger
  then have "wordinverse (R xs) = wordinverse (R ys)" using True assms(1) odd_R by metis
  then have "R xs = R ys" using wordinverse_of_wordinverse by metis
  then show ?thesis using 1 by blast
next
  case False
  have 1: "L xs = L ys" using assms(2) left_tuple_def by (metis prod.inject)
  have "L (wordinverse xs) = L (wordinverse ys)" using assms(2) left_tuple_def by (metis prod.inject)
  then have "wordinverse (R xs) = wordinverse (R ys)" using False assms(1) even_R by metis
  then have "R xs = R ys" using wordinverse_of_wordinverse by metis
  then show ?thesis using 1 by blast
qed

lemma eq_L2_eq:
  assumes "length xs = length ys"
          and "(L2 xs = L2 ys)"
        shows "xs = ys"
  using L2_eq LR_eq assms(1) assms(2) by auto

lemma rev_L2_inv:
  assumes "length xs = length ys"
          and "((\<down> (L2 xs)) = L2 ys)"
        shows "xs = wordinverse ys"
proof(cases "odd (length xs)")
  case True
  have 1: "L xs = L (wordinverse ys)" using assms(2) left_tuple_def old.prod.inject rev_tuple.simps by metis
  have "L (wordinverse xs) = L ys" using assms(2) left_tuple_def old.prod.inject rev_tuple.simps by metis
  then have "take (((length xs+1) div 2) - 1) (L (wordinverse xs)) =  take (((length ys+1) div 2) - 1) (L ys)" using assms(1) by presburger
  then have "take (((length xs+1) div 2) - 1) (L (wordinverse xs)) =  take (((length ys+1) div 2) - 1) (L (wordinverse (wordinverse ys)))" using wordinverse_of_wordinverse by metis
  then have "take (((length xs+1) div 2) - 1) (L (wordinverse xs)) =  take (((length (wordinverse (wordinverse ys))+1) div 2) - 1) (L (wordinverse (wordinverse ys)))" using length_wordinverse by metis
  then have "wordinverse (R xs) = wordinverse  (R (wordinverse ys))" using True assms(1) odd_R length_wordinverse by metis
  then have "R xs = R (wordinverse ys)" using wordinverse_of_wordinverse  by metis
  then show ?thesis using 1 LR_eq by blast
next
  case False
  then have even: "even (length xs)" by auto
  have 1:"L xs = L (wordinverse ys)" using assms(2) left_tuple_def old.prod.inject rev_tuple.simps by metis
  have "L (wordinverse xs) = L ys" using assms(2) left_tuple_def old.prod.inject rev_tuple.simps by metis
  then have "L (wordinverse xs) = L (wordinverse (wordinverse ys))" by (simp add: wordinverse_of_wordinverse)
  then have "wordinverse (R xs) = wordinverse  (R (wordinverse ys))" using even_R assms(1) even by (metis length_wordinverse)
  then have "R xs = (R (wordinverse ys))" using wordinverse_of_wordinverse by metis
  then show ?thesis using 1 LR_eq by blast
qed

lemma length_lex:
  assumes "length (red_rep S X) < length (red_rep S Y)"
              "X \<in> carrier (freegroup S) \<and>
                 Y \<in> carrier (freegroup S)"
      shows "(X,Y) \<in> lex_L2_word S"
proof-
  have "(length (red_rep S X), length (red_rep S Y)) \<in> nat_less" unfolding nat_less_def using assms by blast
  then show ?thesis unfolding lex_L2_word_def lex_prod_def using assms(2) unfolding freegroup_def by simp
qed

text\<open>This proves that if two elements are not comparable in terms of the lex L2
word order, their reduced representations are either the same or inverses of each
 other.\<close>
lemma
  assumes "X \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>)) \<and> Y \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>))"
      and "length ((red_rep S) X) = length ((red_rep S) Y)"
    shows "\<not> (X,Y) \<in> (lex_L2_word S) \<Longrightarrow> \<not> (Y,X) \<in> (lex_L2_word S)
    \<Longrightarrow> (red_rep S X) = (red_rep S Y) \<or> (red_rep S X) = wordinverse (red_rep S Y)"
  using assms lex_L2_word_total1 lex_L2_word_total2 eq_L2_eq rev_L2_inv by blast+

lemma red_rep_wordinv:
  assumes "X \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>))"
  shows "red_rep S ((reln_tuple \<langle>S\<rangle>) `` {wordinverse (red_rep S X)}) = wordinverse (red_rep S X)"
proof-
  have "reduced (wordinverse (red_rep S X))" using red_rep_def[of "S" "X"] reduced_wordinverse[of "red_rep S X"] red_rep_the assms by blast
  moreover have "wordinverse (red_rep S X) \<in> ((reln_tuple \<langle>S\<rangle>) `` {wordinverse (red_rep S X)})" using assms eq_equiv_class_iff2 in_quotient_imp_subset red_rep_the reln_equiv span_wordinverse by fastforce
  ultimately show ?thesis using red_rep_def[of "S" "((reln_tuple \<langle>S\<rangle>) `` {wordinverse (red_rep S X)})"] assms group.wordinverse_inv by (smt (verit, best) Image_singleton_iff quotientI red_rep_the redelem_unique refl_onD2 reln_refl)
qed

lemma red_rep_inv:
  assumes "X \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>))"
  shows "(red_rep S (inv\<^bsub>freegroup S\<^esub> X)) = wordinverse (red_rep S X)"
proof-
  have grpA:"group (freegroup S)" by (simp add: freegroup_is_group)
  then have "X \<in> carrier (freegroup S)" using assms freegroup_def by (metis partial_object.select_convs(1))
  moreover have "X = (reln_tuple \<langle>S\<rangle>) `` {red_rep S X}" using assms by (simp add: red_rep_the)
  ultimately have "inv\<^bsub>(freegroup S)\<^esub> X = (reln_tuple \<langle>S\<rangle>) `` {wordinverse (red_rep S X)}" using group.wordinverse_inv grpA by blast
  then have "(red_rep S (inv\<^bsub>freegroup S\<^esub> X)) = red_rep S ((reln_tuple \<langle>S\<rangle>) `` {wordinverse (red_rep S X)})" by auto
  then show ?thesis  unfolding red_rep_def red_rep_wordinv using assms by (metis equivinv_def red_rep_def red_rep_wordinv)
qed

lemma L2_wordinv:
  "L2 (wordinverse xs) = (snd (L2 xs), fst (L2 xs))"
  by (simp add: FreeGroupMain.wordinverse_of_wordinverse left_tuple_def)

lemma lex_L2_inv:
  assumes "(Y,X) \<in> lex_L2_word S"
  shows "(Y,inv\<^bsub>freegroup S\<^esub> X) \<in> lex_L2_word S"
proof-
  have 1:"X \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>))" using assms(1) unfolding lex_L2_word_def by blast
  then obtain invx where "invx = (inv\<^bsub>freegroup S\<^esub> X)" using freegroup_is_group by simp
  then have x:"(inv\<^bsub>freegroup S\<^esub> X) \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>))" using m_inv_def[of "freegroup S" "X"] freegroup_def
    by (metis (no_types, lifting) freegroup_is_group group.inv_closed partial_object.select_convs(1) 1)
  have y: "Y \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>))" using assms(1) unfolding lex_L2_word_def by blast
  have 2:"(length (red_rep S Y) < length (red_rep S X)) \<or> ((length (red_rep S Y) = length (red_rep S X) \<and> (Y,X) \<in> lex_L2_word' S))"
    using nat_less_def assms unfolding lex_L2_word_def lex_prod_def by fastforce
  then show ?thesis
  proof(cases "(length (red_rep S Y) < length (red_rep S X))")
    case True
    then have "length (red_rep S Y) < length (wordinverse (red_rep S X))" using length_wordinverse by metis
    then have "length (red_rep S Y) < length (red_rep S (inv\<^bsub>freegroup S\<^esub> X))" using 1 red_rep_inv by metis
    then show ?thesis using x y by (simp add: lex_L2_word_def nat_less_def)
  next
    case False
    then have 3:"((length (red_rep S Y) = length (red_rep S X) \<and> (Y,X) \<in> lex_L2_word' S))" using 2 by blast
    then have 4:"length (red_rep S Y) = length (red_rep S (inv\<^bsub>freegroup S\<^esub> X))" using 1 red_rep_inv by (metis length_wordinverse)
    then have "((\<lambda>x. (min lex_word (L2 (red_rep S x)), max lex_word (L2 (red_rep S x)))) Y
                , (\<lambda>x. (min lex_word (L2 (red_rep S x)), max lex_word (L2 (red_rep S x)))) X) \<in> (lex_word <*lex*> lex_word)" using 3 unfolding lex_L2_word'_def by fastforce
    then have 5:"((min lex_word (L2 (red_rep S Y))), (min lex_word (L2 (red_rep S X)))) \<in> lex_word \<or>
               (min lex_word (L2 (red_rep S Y))) = (min lex_word (L2 (red_rep S X))) \<and>
               (max lex_word (L2 (red_rep S Y)), max lex_word (L2 (red_rep S X))) \<in> lex_word" using lex_prod_def[of "lex_word" "lex_word"] by simp
    have "L2 (wordinverse (red_rep S X)) = (snd (L2 (red_rep S X)), fst (L2 (red_rep S X)))" using L2_wordinv by blast
    then have L2_winv:"min lex_word (L2 (red_rep S X)) = min lex_word (L2 (wordinverse (red_rep S X))) \<and>
                       max lex_word (L2 (red_rep S X)) = max lex_word (L2 (wordinverse (red_rep S X)))" using  wf_lex_word min.simps  by (metis (no_types, lifting) lex_word_total max.simps prod.exhaust_sel wf_asym)
    then have "((min lex_word (L2 (red_rep S Y))), (min lex_word (L2 (wordinverse(red_rep S X))))) \<in> lex_word \<or>
               (min lex_word (L2 (red_rep S Y))) = (min lex_word (L2 (wordinverse(red_rep S X)))) \<and>
               (max lex_word (L2 (red_rep S Y)), max lex_word (L2 (wordinverse(red_rep S X)))) \<in> lex_word" using 5 by auto
    then have "((min lex_word (L2 (red_rep S Y))), (min lex_word (L2 (red_rep S (inv\<^bsub>freegroup S\<^esub> X))))) \<in> lex_word \<or>
               (min lex_word (L2 (red_rep S Y))) = (min lex_word (L2 (red_rep S (inv\<^bsub>freegroup S\<^esub> X)))) \<and>
               (max lex_word (L2 (red_rep S Y)), max lex_word (L2 (red_rep S (inv\<^bsub>freegroup S\<^esub> X)))) \<in> lex_word" using red_rep_inv 1 by force
    then have "(Y,(inv\<^bsub>freegroup S\<^esub> X)) \<in> lex_L2_word' S" unfolding lex_L2_word'_def using x y by auto
    then show ?thesis using x y 2 4 lex_L2_word_length by blast
  qed
qed

lemma reduced_tl:"reduced (x#xs) \<Longrightarrow> reduced xs"
  by (metis append_Nil assoc_Cons reduced_leftappend)

text\<open>l concat appends a list of words\<close>
definition l_concat :: "'a list list \<Rightarrow> 'a list"
  where
"l_concat ls \<equiv> (foldr (@) ls [])"

lemma append_equivred_span:
  assumes "set ls \<subseteq> carrier (freegroup S)"
  shows "l_concat (map (red_rep S) ls) \<in> \<langle>S\<rangle>"
proof-
  have "\<forall>x\<in> set ls. \<forall>n\<in>x. n \<in> \<langle>S\<rangle>" using assms in_quotient_imp_subset reln_equiv unfolding freegroup_def by fastforce
  then have 1:"\<forall>x\<in> set ls. x \<subseteq> \<langle>S\<rangle>" by auto
  then have "\<forall>x\<in> set ls. x \<in> \<langle>S\<rangle> // reln_tuple \<langle>S\<rangle> " using assms freegroup_def by (metis partial_object.select_convs(1) subset_code(1))
  moreover then have "\<forall>x\<in> set ls. (red_rep S x \<in> x)" by (simp add: red_rep_the)
  ultimately have "\<forall>x\<in> set ls. (red_rep S x \<in> \<langle>S\<rangle>)" using 1 by auto
  then have "set(map (red_rep S) ls) \<subseteq> \<langle>S\<rangle>" by auto
  then show ?thesis unfolding l_concat_def
  proof(induction ls)
    case Nil
    then show ?case using span_append freewords_on_def[of "S"] words_on.empty by auto
  next
    case (Cons a l)
    then have "set (map (red_rep S) l) \<subseteq> \<langle>S\<rangle>" by simp
    then have 1:"foldr (@) (map (red_rep S) l) [] \<in> \<langle>S\<rangle>" using Cons.IH by auto
    have "[(foldr (@) (map (red_rep S) (a # l)) [])] = [foldr (@) [((foldr (@) (map (red_rep S) [a]) [])@(foldr (@) (map (red_rep S) l) []))] []]" by simp
    then show ?case using span_append freewords_on_def 1 by (metis (no_types, lifting) Cons.prems concat.simps(2) concat_conv_foldr list.set_intros(1) list.simps(9) subset_code(1))
  qed
qed

lemma m_concat_to_l_concat:
  assumes "set l \<subseteq> carrier (freegroup S)"
  shows "monoid.m_concat (freegroup S) l = (reln_tuple \<langle>S\<rangle>) `` {(l_concat (map(red_rep S) l))}"
  using assms
proof(induction l)
  case Nil
  have "monoid.m_concat (freegroup S) [] = \<one>\<^bsub>freegroup S\<^esub>"  by simp
  moreover have "l_concat (map (red_rep S) []) = []" unfolding l_concat_def by simp
  moreover have "reln_tuple \<langle>S\<rangle> `` {[]} = \<one>\<^bsub>freegroup S\<^esub>" using freegroup_def[of "S"] by simp
  ultimately show ?case by simp
next
  case (Cons a l)
  then have "set l \<subseteq> carrier (freegroup S)" by simp
  then have I:"monoid.m_concat (freegroup S) l = reln_tuple \<langle>S\<rangle> `` {l_concat (map (red_rep S) l)}" using Cons.IH by auto
  have 1:"reln_tuple \<langle>S\<rangle> `` {l_concat (map (red_rep S) (a # l))} = reln_tuple \<langle>S\<rangle> `` {((red_rep S) a @ l_concat (map (red_rep S) l))}" unfolding l_concat_def by simp
  have a1:"a \<in> carrier (freegroup S)" using Cons by simp
  then have a:"(red_rep S) a \<in> \<langle>S\<rangle>" unfolding freegroup_def using red_rep_the in_quotient_imp_subset reln_equiv by fastforce
  have "l_concat (map (red_rep S) l) \<in> \<langle>S\<rangle>" using Cons.prems append_equivred_span unfolding freegroup_def by auto
  then have "reln_tuple \<langle>S\<rangle> `` {l_concat (map (red_rep S) (a # l))} = reln_tuple \<langle>S\<rangle> `` {(red_rep S) a} \<otimes>\<^bsub>freegroup S\<^esub>  reln_tuple \<langle>S\<rangle> `` {(l_concat (map (red_rep S) l))}"
    using proj_append_wd[of "(red_rep S) a" "S" " l_concat (map (red_rep S) l)"] 1 a
    unfolding freegroup_def by auto
  moreover have "monoid.m_concat (freegroup S) (a # l) = a \<otimes>\<^bsub>freegroup S\<^esub> monoid.m_concat (freegroup S) l"
    by simp
  moreover have "a = reln_tuple \<langle>S\<rangle> `` {(red_rep S) a}" using red_rep_the a1 freegroup_def
    by (metis partial_object.select_convs(1))
  ultimately show ?case using I by simp
qed

lemma reducedE:
"\<exists>ys. xs ~ ys \<and> reduced ys"
proof-
  have "xs ~ (reduce^^(length xs)) xs" by (simp add: cancels_imp_rel iter_cancels_to)
  moreover have "reduced ((reduce^^(length xs)) xs)" by (simp add: reduced_iter_length)
  ultimately show ?thesis by blast
qed

lemma "\<exists>! ys. xs ~ ys \<and> reduced ys"
proof(rule ex_ex1I)
  show "\<exists>ys. xs ~ ys \<and> reduced ys" using reducedE by blast
next
  show "\<And>ys zs. xs ~ ys \<and> reduced ys \<Longrightarrow> xs ~ zs \<and> reduced zs \<Longrightarrow> ys = zs"
  proof-
    fix ys zs assume "xs ~ ys \<and> reduced ys" and "xs ~ zs \<and> reduced zs"
    moreover then have "ys ~ zs" using reln.sym reln.trans by blast
    ultimately show "ys = zs"  by (simp add: reduced_cancel_eq reln_imp_cancels)
  qed
qed

fun a2 ("\<pi>\<^bsub>1\<^esub>")
  where
"a2 (x,y,z) = x"

fun b2 ("\<pi>\<^bsub>3\<^esub>")
  where
"b2 (x,y,z) = z"

fun p2 ("\<pi>\<^bsub>2\<^esub>")
  where
"p2 (x,y,z) = y"

lemma cancel2E:
  assumes "reduced xs"
          and "reduced ys"
        shows "\<exists>ws. xs = (a2 ws) @ (p2 ws)
                     \<and> ys = (wordinverse (p2 ws)) @ (b2 ws)
                     \<and> reduced ((a2 ws) @ (b2 ws))"
  using assms
proof(induction xs)
  case Nil
  have "[] = [] @ []" by simp
  moreover have "ys = wordinverse [] @ ys" by simp
  moreover have "reduced ([] @ ys)" using Nil.prems(2) by simp
  ultimately show ?case by simp
next
  case (Cons z zs)
  have "reduced zs" using Cons.prems(1) reduced_tl by blast
  then obtain w where w:"zs = a2 w @ p2 w \<and> ys = wordinverse (p2 w) @ b2 w \<and> reduced (a2 w @ b2 w)" using Cons.IH Cons.prems(2) by blast
  then show ?case
  proof(cases "a2 w = []")
    case True note a2 = this
    then show ?thesis
    proof(cases "b2 w = []")
      case True
      have "(z#zs) = [z] @ p2 w" using a2 w by simp
      moreover have "reduced ([z] @ b2 w)" using True by simp
      moreover define w' where w':"w' = ([z], p2 w, b2 w)"
      moreover have "a2 w' = [z]" using w' by simp
      moreover have "b2 w' = b2 w" using w' by simp
      moreover have "p2 w' = p2 w" using w' by simp
      ultimately show ?thesis using w by metis
    next
      case False
      then obtain b bs where b2:"b#bs = b2 w" using list.exhaust by metis
      have rb2: "reduced (b2 w)" using w reduced_leftappend by blast
      then have rbs: "reduced bs" using b2 using reduced_tl by metis
      then show ?thesis
      proof(cases "z = inverse b")
        case True
        then have 1:"wordinverse ([z]@(p2 w)) = (wordinverse (p2 w)) @ [b]" using inverse_of_inverse by fastforce
        define w' where w':"w' = (([]::('a,'b) word), ([z]@(p2 w)), bs)"
        moreover then have "(z#zs) = a2 w' @ p2 w'" using w a2 by simp
        moreover have "ys = wordinverse (p2 w') @ (b2 w')" using w w' 1 b2 by auto
        moreover have "reduced (a2 w' @ b2 w')" using w' rbs by simp
        ultimately show ?thesis by blast
      next
        case False
        define w' where w': "w' = ([z], (p2 w),b#bs)"
        moreover then have "(z#zs) = a2 w' @ p2 w'" using w a2 by simp
        moreover have "ys = wordinverse (p2 w') @ (b2 w')" using w w' b2 by auto
        moreover have "(a2 w' @ b2 w') = (z#b#bs)" using b2 w' by simp
        moreover then have "reduced (a2 w' @ b2 w')" using rb2 b2 False reduced.simps(3) by metis
        ultimately show ?thesis by blast
      qed
    qed
  next
    case False
    then obtain a as where a2:"a2 w = a#as" using list.exhaust by metis
    then have za:"z \<noteq>  inverse a"  using Cons.prems(1) w by auto
    define w' where w':"w' = ((z#a#as), p2 w, b2 w)"
    moreover have zzs:"(z#zs) = a2 w' @ p2 w'" using w w' a2 by simp
    moreover have "ys = wordinverse (p2 w') @ (b2 w')" using w w' by simp
    moreover have "reduced ((a2 w') @ (b2 w'))" using Cons.prems(1) za w w' zzs reduced.simps(3) by auto
    ultimately show ?thesis by blast
  qed
qed

lemma cancel2E':
  assumes "reduced xs"
      and "reduced ys"
    shows "\<exists>! ws. xs = (a2 ws) @ (p2 ws)
                  \<and> ys = (wordinverse (p2 ws)) @ (b2 ws)
                  \<and> reduced ((a2 ws) @ (b2 ws))"
proof(rule ex_ex1I)
  show "\<exists>w. xs = a2 w @ p2 w \<and> ys = wordinverse (p2 w) @ b2 w \<and> reduced (a2 w @ b2 w)" using cancel2E assms by blast
next
  fix w v
  assume w:"xs = a2 w @ p2 w \<and> ys = wordinverse (p2 w) @ b2 w \<and> reduced (a2 w @ b2 w)"
  and v: "xs = a2 v @ p2 v \<and> ys = wordinverse (p2 v) @ b2 v \<and> reduced (a2 v @ b2 v)"
  then obtain c where c:"p2 w = c @ p2 v \<and> (a2 v = a2 w @ c) \<or> p2 v = c @ p2 w \<and> (a2 w = a2 v @ c)" using append_eq_append_conv2[of "a2 w" "p2 w" "a2 v" "p2 v"] by metis
  have wd: "w = (a2 w, p2 w, b2 w)" by (metis a2.simps b2.elims p2.simps)
  have vd: "v = (a2 v, p2 v, b2 v)" by (metis a2.simps b2.elims p2.simps)
  then show "w = v"
  proof(cases "c = []")
    case True
    then have "p2 w = p2 v" using c by auto
    moreover then have "a2 w = a2 v" using w v by simp
    moreover then have "b2 w = b2 v" using v w by auto
    ultimately show ?thesis using wd vd by simp
  next
    case False note cn = this
    then show ?thesis
    proof(cases "p2 w = c @ p2 v \<and> (a2 v = a2 w @ c)")
      case True
      then have "wordinverse (p2 w) = wordinverse (p2 v) @ wordinverse c" using c wordinverse_append by metis
      then have "wordinverse c @ b2 w = b2 v" using w v by auto
      then have 1:"a2 v @ b2 v = a2 w @ c @ wordinverse c @ b2 w" using True by simp
      then have "(a2 v @ b2 v) ~ a2 w @ c @ wordinverse c @ b2 w" using reln.refl by simp
      moreover have "(c @ wordinverse c) ~ []" by (simp add: wordinverse_inverse)
      ultimately have  "(a2 v @ b2 v) ~ a2 w @ b2 w" using 1 by (metis (no_types, lifting) append_Nil2 append_assoc mult reln.refl)
      then have "(a2 v @ b2 v) = a2 w @ b2 w" using w v  by (simp add: reduced_cancel_eq reln_imp_cancels)
      moreover have "(a2 v @ b2 v) \<noteq>  a2 w @ b2 w" using 1 cn by simp
      ultimately show ?thesis by blast
    next
      case False
      then have F:"p2 v = c @ p2 w \<and> (a2 w = a2 v @ c)" using c by blast
      then have "wordinverse (p2 v) = wordinverse (p2 w) @ wordinverse c" using c wordinverse_append by metis
      then have "wordinverse c @ b2 v = b2 w" using w v by auto
      then have 1:"a2 w @ b2 w = a2 v @ c @ wordinverse c @ b2 v" using F by simp
      then have "(a2 w @ b2 w) ~ a2 v @ c @ wordinverse c @ b2 v" using reln.refl by simp
      moreover have "(c @ wordinverse c) ~ []" by (simp add: wordinverse_inverse)
      ultimately have  "(a2 w @ b2 w) ~ a2 v @ b2 v" using 1 by (metis (no_types, lifting) append_Nil2 append_assoc mult reln.refl)
      then have "(a2 w @ b2 w) = a2 v @ b2 v" using w v  by (simp add: reduced_cancel_eq reln_imp_cancels)
      moreover have "(a2 w @ b2 w) \<noteq>  a2 v @ b2 v" using 1 cn by simp
      ultimately show ?thesis by blast
    qed
  qed
qed

text\<open>Given two reduced words x and y, cancel2 returns the unique triple (a,p,b),
  such that x = a @ p, y = (wordinverse p)@b, and ab is reduced. Existence of such a word is
proved above.\<close>
definition cancel2 ::
      "('a,'b) word \<Rightarrow> ('a,'b) word
                  \<Rightarrow> (('a,'b) word \<times> ('a,'b) word \<times> ('a,'b) word)" (infix "\<oslash>\<^bsub>2\<^esub>" 65)
  where
"cancel2 xs ys = (THE ws. xs = a2 ws @ p2 ws \<and> ys = (wordinverse (p2 ws)) @ b2 ws \<and> reduced (a2 ws@b2 ws))"

lemma cancel2_the:
  assumes "reduced xs"
      and "reduced ys"
    shows "xs = a2 (xs\<oslash>\<^bsub>2\<^esub>ys)  @  p2 (xs\<oslash>\<^bsub>2\<^esub>ys)
           \<and> ys = (wordinverse (p2 (xs\<oslash>\<^bsub>2\<^esub>ys))) @ b2 (xs\<oslash>\<^bsub>2\<^esub>ys)
           \<and> reduced (a2 (xs\<oslash>\<^bsub>2\<^esub>ys)@b2 (xs\<oslash>\<^bsub>2\<^esub>ys))"
  unfolding cancel2_def
  by(rule theI', simp add: assms cancel2E')

lemma cancel2_reln:
  assumes "xs = a @ p \<and> ys = (wordinverse p) @ b"
  shows "(xs@ys) ~ (a@b)"
proof-
  have "(p @ wordinverse p) ~ []" by (simp add: wordinverse_inverse)
  then show ?thesis using assms  mult reln.refl  by (metis append_Nil2 append.assoc)
qed

text\<open>The following definition corresponds to the N1 property on words, which is
 stated earlier in the file.\<close>

definition N1 :: "('a,'b) word \<Rightarrow> ('a, 'b) word \<Rightarrow> bool"
  where
"N1 xs ys = ((xs \<noteq>  wordinverse ys)
              \<longrightarrow> ((length (\<pi>\<^bsub>2\<^esub> (xs\<oslash>\<^bsub>2\<^esub>ys))) \<le>(length (\<pi>\<^bsub>1\<^esub>  (xs\<oslash>\<^bsub>2\<^esub>ys)))
                        \<and> (length (\<pi>\<^bsub>2\<^esub>  (xs\<oslash>\<^bsub>2\<^esub>ys))) \<le> (length (\<pi>\<^bsub>3\<^esub>  (xs\<oslash>\<^bsub>2\<^esub>ys)))))"

lemma N1_length:
  assumes "X \<in> (\<langle>S\<rangle> // reln_tuple \<langle>S\<rangle>) \<and> Y \<in> (\<langle>S\<rangle> // reln_tuple \<langle>S\<rangle>)"
          "N1 (red_rep S X) (red_rep S Y)"
          "((red_rep S X) \<noteq> wordinverse (red_rep S Y))"
          "(length ((red_rep S (proj_append \<langle>S\<rangle> X Y)))) = b"
          "length (red_rep S X) = a"
          "length (red_rep S Y) = c"
    shows "(b \<ge> a) \<and> (b \<ge> c)"
proof-
  let ?rk = "red_rep S X"
  let  ?rm = "red_rep S Y"
  have N1:"(less_eq (length (p2 (?rk\<oslash>\<^bsub>2\<^esub>?rm))) (length (a2 (?rk\<oslash>\<^bsub>2\<^esub>?rm))))
         \<and> less_eq (length (p2 (?rk\<oslash>\<^bsub>2\<^esub>?rm))) (length (b2 (?rk\<oslash>\<^bsub>2\<^esub>?rm)))" using assms(2,3) N1_def by blast
  then have x:"?rk = ((a2 (?rk\<oslash>\<^bsub>2\<^esub>?rm)) @ (p2 (?rk\<oslash>\<^bsub>2\<^esub>?rm)))" using cancel2_def[of "?rk" "?rm"] cancel2_the red_rep_def assms(1) red_rep_the by blast
  have y:"?rm = ((wordinverse(p2 (?rk\<oslash>\<^bsub>2\<^esub>?rm))) @ (b2 (?rk\<oslash>\<^bsub>2\<^esub>?rm)))" using cancel2_def[of "?rk" "?rm"] cancel2_the red_rep_def assms(1) red_rep_the by blast
  have rac:"reduced ((a2 (?rk\<oslash>\<^bsub>2\<^esub>?rm))@(b2 (?rk\<oslash>\<^bsub>2\<^esub>?rm)))" using cancel2_def[of "?rk" "?rm"] cancel2_the red_rep_def assms(1) red_rep_the by blast
  have a:"length(p2 (?rk\<oslash>\<^bsub>2\<^esub>?rm)) \<le> length (a2 (?rk\<oslash>\<^bsub>2\<^esub>?rm))" using x y rac N1_def assms(2) using N1 by blast
  have b:"length(p2 (?rk\<oslash>\<^bsub>2\<^esub>?rm)) \<le> length (b2 (?rk\<oslash>\<^bsub>2\<^esub>?rm))" using x y rac N1_def assms(2) using N1 by blast
  have 1:"((red_rep S (proj_append \<langle>S\<rangle> X Y))) = ((reduce^^(length (?rk @ ?rm))) (?rk @ ?rm))" using assms(1) red_rep_proj_app by blast
  then have "(?rk @ ?rm) = ((a2 (?rk\<oslash>\<^bsub>2\<^esub>?rm)) @ (p2 (?rk\<oslash>\<^bsub>2\<^esub>?rm))@(wordinverse(p2 (?rk\<oslash>\<^bsub>2\<^esub>?rm))) @ (b2 (?rk\<oslash>\<^bsub>2\<^esub>?rm)))" using x y by auto
  then have 2:"(reduce^^(length (?rk @ ?rm))) (?rk @ ?rm) = ((a2 (?rk\<oslash>\<^bsub>2\<^esub>?rm)) @ (b2 (?rk\<oslash>\<^bsub>2\<^esub>?rm)))" using rac iter_wordinv by blast
  have "(length ((reduce^^(length (?rk @ ?rm))) (?rk @ ?rm))) \<le> length (?rk @ ?rm)" using length_reduce_iter by blast
  have "(b \<ge> (length ?rk)) \<and> (b \<ge> (length ?rm))" using a b 1 2 by (metis (no_types, lifting) add_le_mono1 assms(4) length_append length_wordinverse nat_add_left_cancel_le x y)
  then show ?thesis using assms(3,4,5,6) a b by auto
qed

lemma length_N1:
  assumes "X \<in> carrier (freegroup S)" "Y \<in> carrier (freegroup S)"
        "length (red_rep S (X \<otimes>\<^bsub>F\<^bsub>S\<^esub>\<^esub> Y)) \<ge> length (red_rep S X)
          \<and> length (red_rep S (X \<otimes>\<^bsub>F\<^bsub>S\<^esub>\<^esub> Y)) \<ge>  length (red_rep S Y)"
  shows "N1 (red_rep S X) (red_rep S Y)"
proof-
  let ?x = "(red_rep S X)"
  let ?y = "(red_rep S Y)"
  let ?xy = "(cancel2 ?x ?y)"
  have xy: "(X \<otimes>\<^bsub>F\<^bsub>S\<^esub>\<^esub> Y) \<in> carrier (freegroup S)" using assms
    by (simp add: freegroup_is_group group.subgroupE(4) group.subgroup_self)
  have 1:"reduced ?x" using assms(1) red_rep_def red_rep_the unfolding freegroup_def by fastforce
  moreover have 2:"reduced ?y" using assms(2) red_rep_def red_rep_the
    unfolding freegroup_def by fastforce
  ultimately have "((red_rep S X) @ (red_rep S Y)) ~ ((a2 ?xy) @ (b2 ?xy))"
    by (metis cancel2_reln cancel2_the)
  then have "(red_rep S (X \<otimes>\<^bsub>F\<^bsub>S\<^esub>\<^esub> Y)) ~ ((a2 ?xy) @ (b2 ?xy))"
    using assms mult_reln using reln.trans by blast
  moreover have "reduced ((a2 ?xy) @ (b2 ?xy))" by (simp add: "1" "2" cancel2_the)
  moreover have "reduced (red_rep S (X \<otimes>\<^bsub>F\<^bsub>S\<^esub>\<^esub> Y))"
    using xy red_rep_def red_rep_the unfolding freegroup_def by fastforce
  ultimately have 3: "(red_rep S (X \<otimes>\<^bsub>F\<^bsub>S\<^esub>\<^esub> Y)) = ((a2 ?xy) @ (b2 ?xy))"
    by (simp add: reduced_reln_eq)
  have "?x = (a2 ?xy) @ (p2 ?xy)" using 1 2 by (simp add: cancel2_the)
  then have "length ((a2 ?xy) @ (b2 ?xy)) \<ge> length ((a2 ?xy) @ (p2 ?xy))"
    using assms(3) 3 by auto
  then have A:"length (b2 ?xy) \<ge> length (p2 ?xy)" by auto
  have "?y =  wordinverse (p2 ?xy) @ (b2 ?xy)" using 1 2 by (simp add: cancel2_the)
  then have "length ((a2 ?xy) @ (b2 ?xy)) \<ge> length (wordinverse (p2 ?xy) @ (b2 ?xy))"
    using 3 assms(3) by auto
  then have "length (a2 ?xy) \<ge> length (wordinverse (p2 ?xy))" by auto
  then have "length (a2 ?xy) \<ge> length (p2 ?xy)" by (metis length_wordinverse)
  then show ?thesis unfolding N1_def using A by blast
qed

fun a3 ("\<pi>\<^bsub>1\<^esub>") where
"a3 (v,w,x,y,z) = v"

fun b3  ("\<pi>\<^bsub>3\<^esub>") where
"b3 (v,w,x,y,z) = x"

fun c3  ("\<pi>\<^bsub>5\<^esub>") where
"c3 (v,w,x,y,z) = z"

fun p3 ("\<pi>\<^bsub>2\<^esub>") where
"p3 (v,w,x,y,z) = w"

fun q3 ("\<pi>\<^bsub>4\<^esub>") where
"q3 (v,w,x,y,z) = y"

text\<open>This is analogous to cancel2 , and is defined on three words, cancel3 then
proves the unique existence of such a word by constructive means.\<close>

definition cancel3 :: "('a,'b) word \<Rightarrow> ('a,'b) word \<Rightarrow> ('a,'b) word \<Rightarrow> (('a,'b) word \<times> ('a,'b) word \<times> ('a,'b) word \<times> ('a,'b) word \<times> ('a,'b) word)" ("\<oslash>\<^bsub>3\<^esub>")
  where
"cancel3 xs ys zs = (THE ws. xs = a3 ws @  (p3 ws)
                  \<and> ys = wordinverse  (p3 ws) @ b3 ws @ (q3 ws)
                  \<and> zs = (wordinverse  (q3 ws)) @ (c3 ws)
                  \<and> reduced (a3 ws@b3 ws @ q3 ws)
                  \<and> reduced (wordinverse  (p3 ws) @ b3 ws @ c3 ws))"

lemma tuple3:
"\<forall>v. v  = (a3 v, p3 v, b3 v, q3 v, c3 v)"
  by simp

lemma appendeq_length1:
  assumes "a@b = c@d"
      and "length a < length b"
      and "length d < length c"
    shows "length a < length c"
  using assms by (metis (no_types, lifting) length_append less_add_eq_less linorder_neqE_nat order.strict_trans)

lemma appendeq_length2:
  assumes "a@b = c@d"
      and "length a < length b"
      and "length d < length c"
    shows "length d < length b"
  using assms by (metis (no_types, lifting) length_append less_add_eq_less linorder_neqE_nat order.strict_trans)

lemma appendeq_length3:
  assumes "a@b = c@d"
      and "length a < length b"
      and "length d = length c"
    shows "length a < length c"
  using assms  by (metis (no_types, lifting) length_append less_add_eq_less linorder_neqE_nat order.strict_trans)

lemma appendeq_length4:
  assumes "a@b = c@d"
      and "length a < length b"
      and "length d = length c"
    shows "length d < length b"
  using assms by (metis (no_types, lifting) length_append less_add_eq_less linorder_neqE_nat order.strict_trans)

lemma appendeq_length5:
  assumes "a@b = c@d"
      and "length a = length b"
      and "length d < length c"
    shows "length a < length c"
  using assms by (metis (no_types, lifting) append_eq_append_conv dual_order.strict_trans length_append less_add_eq_less linorder_neqE_nat)

lemma appendeq_length6:
  assumes "a@b = c@d"
      and "length a = length b"
      and "length d < length c"
    shows "length d < length b"
  using assms by (metis (no_types, lifting) append_eq_append_conv dual_order.strict_trans length_append less_add_eq_less linorder_neqE_nat)

lemma overlap_middle_exists:
  assumes "a@b = c@d"
      and "length a \<le> length b"
      and "length d \<le> length c"
    shows "\<exists>x. a@x@d = a@b"
proof(cases "length a < length b")
  case True note ab = this
  then show ?thesis
  proof(cases "length d < length c")
    case True
    from assms(1) have "length a < length c" using ab True appendeq_length1 by auto
    hence y:"\<exists>y. a@y = c" using assms(1) overlapleftexist by blast
    from assms(1) have "length d < length b" using ab True appendeq_length2 by auto
    hence x:"\<exists>x. x@d = b" using assms(1) overlaprightexist by metis
    from x y assms(1) show ?thesis by auto
  next
    case False
    then have l:"length d = length c" using assms(3) by simp
    then have "length a < length c" using assms(1) ab appendeq_length3 by blast
    hence y:"\<exists>y. a@y = c" using assms(1) overlapleftexist by blast
    from assms(1) have "length d < length b" using ab l appendeq_length4 by blast
    hence x:"\<exists>x. x@d = b" using assms(1) overlaprightexist by metis
    from x y assms(1) show ?thesis by auto
  qed
next
  case False
  then have la:"length a = length b" using assms(2) by auto
  then show ?thesis
  proof(cases "length d < length c")
    case True
    from assms(1) have "length a < length c" using True la appendeq_length5 by blast
    hence y:"\<exists>y. a@y = c" using assms(1) overlapleftexist by blast
    from assms(1) have "length d < length b" using True la appendeq_length6 by blast
    hence x:"\<exists>x. x@d = b" using assms(1) overlaprightexist by metis
    from x y assms(1) show ?thesis by auto
  next
    case False
    then have l:"length d = length c" using assms(3) by simp
    then have "length a = length c" using assms(1) la by (metis (mono_tags, lifting) "appendeq_length1" length_append less_add_eq_less nat_neq_iff)
    then show ?thesis using assms(1) by auto
  qed
qed

lemma cancel3E:
  assumes "reduced xs"
      and "reduced ys"
      and "reduced zs"
      and "N1 xs ys"
      and "N1 ys zs"
      and "xs \<noteq>  wordinverse ys"
      and "ys \<noteq>  wordinverse zs"
    shows "\<exists>ws. xs = a3 ws @  (p3 ws)
                \<and> ys = wordinverse  (p3 ws) @ b3 ws @ (q3 ws)
                \<and> zs = (wordinverse  (q3 ws)) @ (c3 ws) \<and> reduced (a3 ws @ b3 ws @ q3 ws)
                \<and> reduced (wordinverse  (p3 ws) @ b3 ws @ c3 ws)"
proof-
  have xy:"xs = a2 (xs\<oslash>\<^bsub>2\<^esub>ys)  @  p2 (xs\<oslash>\<^bsub>2\<^esub>ys) \<and> ys = (wordinverse (p2 (xs\<oslash>\<^bsub>2\<^esub>ys))) @ b2 (xs\<oslash>\<^bsub>2\<^esub>ys) \<and> reduced (a2 (xs\<oslash>\<^bsub>2\<^esub>ys)@b2 (xs\<oslash>\<^bsub>2\<^esub>ys))" using assms(1,2) cancel2_the by fastforce
  then have 1:"(less_eq (length (p2 (xs\<oslash>\<^bsub>2\<^esub>ys))) (length (a2 (xs\<oslash>\<^bsub>2\<^esub>ys))) \<and> less_eq (length (p2 (xs\<oslash>\<^bsub>2\<^esub>ys))) (length (b2 (xs\<oslash>\<^bsub>2\<^esub>ys))))" using assms(4,6) unfolding N1_def by blast
  have yz:"ys = a2 (ys\<oslash>\<^bsub>2\<^esub>zs)  @  p2 (ys\<oslash>\<^bsub>2\<^esub>zs) \<and> zs = (wordinverse (p2 (ys\<oslash>\<^bsub>2\<^esub>zs))) @ b2 (ys\<oslash>\<^bsub>2\<^esub>zs) \<and> reduced (a2 (ys\<oslash>\<^bsub>2\<^esub>zs)@b2 (ys\<oslash>\<^bsub>2\<^esub>zs))" using assms(2,3) cancel2_the by fastforce
  then have 2:"(less_eq (length (p2 (ys\<oslash>\<^bsub>2\<^esub>zs))) (length (a2 (ys\<oslash>\<^bsub>2\<^esub>zs))) \<and> less_eq (length (p2 (ys\<oslash>\<^bsub>2\<^esub>zs))) (length (b2 (ys\<oslash>\<^bsub>2\<^esub>zs))))" using assms(5,7) unfolding N1_def by blast
  let ?a = "a2 (xs\<oslash>\<^bsub>2\<^esub>ys)"
  let ?b1 = "b2 (xs\<oslash>\<^bsub>2\<^esub>ys)"
  let ?b2 = "a2  (ys\<oslash>\<^bsub>2\<^esub>zs)"
  let ?c = "b2  (ys\<oslash>\<^bsub>2\<^esub>zs)"
  let ?p = "p2 (xs\<oslash>\<^bsub>2\<^esub>ys)"
  let ?q = "p2 (ys\<oslash>\<^bsub>2\<^esub>zs)"
  have "wordinverse (p2 (xs \<oslash>\<^bsub>2\<^esub> ys)) @ b2 (xs \<oslash>\<^bsub>2\<^esub> ys) = a2 (ys \<oslash>\<^bsub>2\<^esub> zs) @ p2 (ys \<oslash>\<^bsub>2\<^esub> zs)" using xy yz by simp
  moreover have "(length ?p) = (length (wordinverse ?p))" using length_wordinverse by blast
  moreover then have "length (wordinverse (p2 (xs \<oslash>\<^bsub>2\<^esub> ys))) \<le> length (b2 (xs \<oslash>\<^bsub>2\<^esub> ys))" using 1 by auto
  moreover have "length (p2 (ys \<oslash>\<^bsub>2\<^esub> zs)) \<le> length (a2 (ys \<oslash>\<^bsub>2\<^esub> zs))" using 2 by simp
  ultimately obtain b where b:"(wordinverse ?p)@b@(?q) = ys" using 1 2 xy yz overlap_middle_exists[of "(wordinverse ?p)" "?b1" "?b2" "?q"] by auto
  define w where w:"w = (?a, ?p, b, ?q, ?c)"
  then have "xs = a3 w @ (p3 w)" using xy by auto
  moreover have "ys = wordinverse  (p3 w) @ b3 w @ (q3 w)" using w b by auto
  moreover have "zs = (wordinverse  (q3 w)) @ (c3 w)" using w yz by auto
  moreover have "reduced (a3 w @ b3 w @ q3 w)" using xy yz w b a3.simps b3.simps q3.simps by (metis same_append_eq)
  moreover have "reduced (wordinverse  (p3 w) @ b3 w @ c3 w)" using xy yz w b p3.simps b3.simps c3.simps by (metis (no_types, lifting) append.assoc append_same_eq)
  ultimately show ?thesis using w by blast
qed

lemma cancel3E':
  assumes "reduced xs"
      and "reduced ys"
      and "reduced zs"
      and "N1 xs ys"
      and "N1 ys zs"
      and "xs \<noteq> wordinverse ys"
      and "ys \<noteq>  wordinverse zs"
    shows "\<exists>!ws. xs = a3 ws @  (p3 ws)
                \<and> ys = wordinverse  (p3 ws) @ b3 ws @ (q3 ws)
                \<and> zs = (wordinverse (q3 ws)) @ (c3 ws)
                \<and> reduced (a3 ws@b3 ws @ q3 ws) \<and> reduced (wordinverse  (p3 ws) @ b3 ws @ c3 ws)"
proof(rule ex_ex1I)
  show "\<exists>w. xs = a3 w @ p3 w \<and>
        ys = wordinverse (p3 w) @ b3 w @ q3 w \<and>
        zs = wordinverse (q3 w) @ c3 w \<and>
        reduced (a3 w @ b3 w @ q3 w) \<and> reduced (wordinverse (p3 w) @ b3 w @ c3 w)"
    using cancel3E assms by blast
next
  fix v w assume v:"xs = a3 (v::(('a,'b) word \<times> ('a,'b) word \<times> ('a,'b) word \<times> ('a,'b) word \<times> ('a,'b) word))
       @ p3 v \<and>
       ys = wordinverse (p3 v) @ b3 v @ q3 v \<and>
       zs = wordinverse (q3 v) @ c3 v \<and>
       reduced (a3 v @ b3 v @ q3 v) \<and> reduced (wordinverse (p3 v) @ b3 v @ c3 v)"
          and w: "xs = a3 (w::(('a,'b) word \<times> ('a,'b) word \<times> ('a,'b) word \<times> ('a,'b) word \<times> ('a,'b) word))
       @ p3 w \<and>
       ys = wordinverse (p3 w) @ b3 w @ q3 w \<and>
       zs = wordinverse (q3 w) @ c3 w \<and>
       reduced (a3 w @ b3 w @ q3 w) \<and> reduced (wordinverse (p3 w) @ b3 w @ c3 w)"
  define v1 where v1:"v1 = (a3 v, p3 v, (b3 v @ q3 v))"
  define w1 where w1:"w1 = (a3 w, p3 w, (b3 w @ q3 w))"
  have "xs = a2 v1 @ p2 v1 \<and>
       ys = wordinverse (p2 v1) @ b2 v1 \<and>
       reduced (a2 v1 @ b2 v1)" using v v1 by simp
  moreover have "xs = a2 w1 @ p2 w1 \<and>
       ys = wordinverse (p2 w1) @ b2 w1 \<and>
       reduced (a2 w1 @ b2 w1)" using w w1 by simp
  ultimately have 1:"v1 = w1" using cancel2E' assms(1,2) by blast
  define v2 where v2:"v2 = (wordinverse (p3 v) @ b3 v, q3 v, c3 v)"
  define w2 where w2:"w2 = (wordinverse (p3 w) @ b3 w, q3 w, c3 w)"
  have "ys = a2 v2 @ p2 v2 \<and>
       zs = wordinverse (p2 v2) @ b2 v2 \<and>
       reduced (a2 v2 @ b2 v2)" using v v2 by simp
  moreover have "ys = a2 w2 @ p2 w2 \<and>
       zs = wordinverse (p2 w2) @ b2 w2 \<and>
       reduced (a2 w2 @ b2 w2)" using w w2 by simp
  ultimately have "v2 = w2" using cancel2E' assms(2,3) by blast
  then have 2:"a3 v = a3 w \<and> p3 v = p3 w \<and> q3 v = q3 w \<and> c3 v = c3 w" using 1 v1 v2 w1 w2 by fast
  then moreover have "b3 v = b3 w" using v w by simp
  moreover have "v  = (a3 v, p3 v, b3 v, q3 v, c3 v)" using tuple3 by blast
  moreover have "w  = (a3 w, p3 w, b3 w, q3 w, c3 w)" using tuple3 by blast
  ultimately show "v = w" by presburger
qed

lemma cancel3_the:
  assumes "reduced xs"
      and "reduced ys"
      and "reduced zs"
      and "N1 xs ys"
      and "N1 ys zs"
      and "xs \<noteq>  wordinverse ys"
      and "ys \<noteq>  wordinverse zs"
    shows "xs = a3 (\<oslash>\<^bsub>3\<^esub> xs ys zs) @  (p3 (\<oslash>\<^bsub>3\<^esub> xs ys zs))
            \<and> ys = wordinverse  (p3 (\<oslash>\<^bsub>3\<^esub> xs ys zs)) @ b3 (\<oslash>\<^bsub>3\<^esub> xs ys zs) @ (q3 (\<oslash>\<^bsub>3\<^esub> xs ys zs))
            \<and> zs = (wordinverse  (q3 (\<oslash>\<^bsub>3\<^esub> xs ys zs))) @ (c3 (\<oslash>\<^bsub>3\<^esub> xs ys zs))
            \<and> reduced (a3 (\<oslash>\<^bsub>3\<^esub> xs ys zs)@b3 (\<oslash>\<^bsub>3\<^esub> xs ys zs) @ q3 (\<oslash>\<^bsub>3\<^esub> xs ys zs))
            \<and> reduced (wordinverse  (p3 (\<oslash>\<^bsub>3\<^esub> xs ys zs)) @ b3 (\<oslash>\<^bsub>3\<^esub> xs ys zs) @ c3 (\<oslash>\<^bsub>3\<^esub> xs ys zs))"
    unfolding cancel3_def
    by(rule theI', simp add: assms cancel3E')

lemma cancel3_reln:
  assumes "xs = a @ p  \<and> ys = (wordinverse  p)  @ b @ q \<and> zs = (wordinverse  q) @ c"
  shows "(xs@ys@zs) ~ (a@b@c)"
proof-
  have "(p @ wordinverse p) ~ []" by (simp add: wordinverse_inverse)
  then have 1:"(xs@ys@zs) ~ (a@b@q@(wordinverse q)@c)" using assms cancel2_reln by auto
  have "(q @ wordinverse q) ~ []" by (simp add: wordinverse_inverse)
  then have "(a@b@q@(wordinverse q)@c) ~ (a@b@c)"  by (metis append_assoc cancel2_reln)
  then show ?thesis using trans 1  by fast
qed

text\<open>N2 of three words x, y, and z, is defined here as the property that
     a subword of y occurs in the reduced form of the word x@y@z.
 This is equivalent to claiming that all the elements in y do not cancel out in the product.
This definition varies in form, from the definition provided in Lyndon and Schupp,
stated in the text at the beginning of the file.\<close>

definition N2 :: "('a,'b) word \<Rightarrow> ('a, 'b) word \<Rightarrow> ('a, 'b) word \<Rightarrow> bool"
  where
"N2 xs ys zs = ((xs \<noteq>  wordinverse ys \<and> ys \<noteq>  wordinverse zs)
                              \<longrightarrow> (\<pi>\<^bsub>3\<^esub> (\<oslash>\<^bsub>3\<^esub> xs ys zs) \<noteq>  []))"

lemma reduced_overlap:
  assumes "reduced (a@b)"
      and "reduced (b@c)"
      and "b \<noteq>  []"
    shows "reduced (a@b@c)"
  using assms
proof(induction a)
  case Nil
  then show ?case by simp
next
  case (Cons a1 a2)
  then moreover have "reduced (a2 @ b)" by (metis assoc_Cons reduced_tl)
  ultimately have r:"reduced (a2@b@c)" by simp
  obtain b1 b2 where b:"b = b1#b2" using Cons.prems(3) list.exhaust by blast
  show ?case
  proof(cases "a2 = []")
    case True
    then have "a1 \<noteq>  inverse b1" using Cons.prems(1) b by auto
    then show ?thesis using b True r by auto
  next
    case False
    then obtain a3 a4 where "a2 = a3#a4" using list.exhaust by blast
    moreover then have "a1 \<noteq>  inverse a3" using Cons.prems(1) by auto
    ultimately show ?thesis  using r by auto
  qed
qed

text\<open>Following lemmas relate cancel2 to cancel3.\<close>

lemma cancel3_b:
  assumes "reduced xs"
      and "reduced ys"
      and "reduced zs"
      and "N1 xs ys"
      and "N1 ys zs"
      and "N2 xs ys zs"
      and "xs \<noteq>  wordinverse ys"
      and "ys \<noteq>  wordinverse zs"
    shows "reduced (a3 (\<oslash>\<^bsub>3\<^esub> xs ys zs) @ b3 (\<oslash>\<^bsub>3\<^esub> xs ys zs) @ c3 (\<oslash>\<^bsub>3\<^esub> xs ys zs))"
proof-
  have 1:"xs = a3 (\<oslash>\<^bsub>3\<^esub> xs ys zs) @  (p3 (\<oslash>\<^bsub>3\<^esub> xs ys zs)) \<and> ys = wordinverse  (p3 (\<oslash>\<^bsub>3\<^esub> xs ys zs)) @ b3 (\<oslash>\<^bsub>3\<^esub> xs ys zs) @ (q3 (\<oslash>\<^bsub>3\<^esub> xs ys zs)) \<and> zs = (wordinverse  (q3 (\<oslash>\<^bsub>3\<^esub> xs ys zs))) @ (c3 (\<oslash>\<^bsub>3\<^esub> xs ys zs)) \<and> reduced (a3 (\<oslash>\<^bsub>3\<^esub> xs ys zs)@b3 (\<oslash>\<^bsub>3\<^esub> xs ys zs) @ q3 (\<oslash>\<^bsub>3\<^esub> xs ys zs)) \<and> reduced (wordinverse  (p3 (\<oslash>\<^bsub>3\<^esub> xs ys zs)) @ b3 (\<oslash>\<^bsub>3\<^esub> xs ys zs) @ c3 (\<oslash>\<^bsub>3\<^esub> xs ys zs))" using assms cancel3_the by blast
  then have "reduced (b3 (\<oslash>\<^bsub>3\<^esub> xs ys zs) @ c3 (\<oslash>\<^bsub>3\<^esub> xs ys zs))" using reduced_leftappend by auto
  moreover have "reduced (a3 (\<oslash>\<^bsub>3\<^esub> xs ys zs)@b3 (\<oslash>\<^bsub>3\<^esub> xs ys zs))" using reduced_rightappend 1  by (metis append.assoc)
  moreover have "(b3 (\<oslash>\<^bsub>3\<^esub> xs ys zs) \<noteq>  [])" using assms(6,7,8) unfolding N2_def by blast
  ultimately show ?thesis using reduced_overlap by blast
qed

lemma cancel_a2_pb3:
  assumes "reduced xs"
      and "reduced ys"
      and "reduced zs"
      and "N1 xs ys"
      and "N1 ys zs"
      and "xs \<noteq>  wordinverse ys"
      and "ys \<noteq>  wordinverse zs"
    shows "a2 (cancel2 ys zs) = wordinverse  (p3 (cancel3 xs ys zs)) @ b3 (cancel3 xs ys zs)"
proof-
  have 1:"xs = a3 (cancel3 xs ys zs) @  (p3 (cancel3 xs ys zs)) \<and> ys = wordinverse  (p3 (cancel3 xs ys zs)) @ b3 (cancel3 xs ys zs) @ (q3 (cancel3 xs ys zs)) \<and> zs = (wordinverse  (q3 (cancel3 xs ys zs))) @ (c3 (cancel3 xs ys zs)) \<and> reduced (a3 (cancel3 xs ys zs) @ b3 (cancel3 xs ys zs) @ q3 (cancel3 xs ys zs)) \<and> reduced (wordinverse  (p3 (cancel3 xs ys zs)) @ b3 (cancel3 xs ys zs) @ c3 (cancel3 xs ys zs))" using assms cancel3_the by blast
  have 2:"ys = (a2 (cancel2 ys zs)) @ (p2 (cancel2 ys zs)) \<and> zs = (wordinverse (p2 (cancel2 ys zs))) @ (b2 (cancel2 ys zs)) \<and> reduced ((a2 (cancel2 ys zs)) @ (b2 (cancel2 ys zs)))" using assms(2,3) by (simp add: cancel2_the)
  define w2 where 3:"w2 = ((wordinverse  (p3 (cancel3 xs ys zs)) @ b3 (cancel3 xs ys zs)), (q3 (cancel3 xs ys zs)), (c3 (cancel3 xs ys zs)))"
  then have "ys = (a2 w2) @ (p2 w2) \<and> zs = (wordinverse (p2 w2)) @ (b2 w2) \<and> reduced ((a2 w2) @ (b2 w2))" using 1 by auto
  then have "w2 = (cancel2 ys zs)" using 2 assms(2,3) cancel2E' by blast
  then have "a2 w2 = a2 (cancel2 ys zs)" by simp
  then show ?thesis using 3 by simp
qed

lemma cancel_a2_a3:
  assumes "reduced xs"
      and "reduced ys"
      and "reduced zs"
      and "N1 xs ys"
      and "N1 ys zs"
      and "xs \<noteq>  wordinverse ys"
      and "ys \<noteq>  wordinverse zs"
    shows "a2 (cancel2 xs ys) = a3 (cancel3 xs ys zs)"
proof-
  have 1:"xs = a3 (cancel3 xs ys zs) @  (p3 (cancel3 xs ys zs)) \<and> ys = wordinverse  (p3 (cancel3 xs ys zs)) @ b3 (cancel3 xs ys zs) @ (q3 (cancel3 xs ys zs)) \<and> zs = (wordinverse  (q3 (cancel3 xs ys zs))) @ (c3 (cancel3 xs ys zs)) \<and> reduced (a3 (cancel3 xs ys zs) @ b3 (cancel3 xs ys zs) @ q3 (cancel3 xs ys zs)) \<and> reduced (wordinverse  (p3 (cancel3 xs ys zs)) @ b3 (cancel3 xs ys zs) @ c3 (cancel3 xs ys zs))" using assms cancel3_the by blast
  have 2:"xs = (a2 (cancel2 xs ys)) @ (p2 (cancel2 xs ys)) \<and> ys = (wordinverse (p2 (cancel2 xs ys))) @ (b2 (cancel2 xs ys)) \<and> reduced ((a2 (cancel2 xs ys)) @ (b2 (cancel2 xs ys)))" using assms(1,2) by (simp add: cancel2_the)
  define w2 where 3:"w2 = (a3 (cancel3 xs ys zs), (p3 (cancel3 xs ys zs)), b3 (cancel3 xs ys zs) @ (q3 (cancel3 xs ys zs)))"
  then have "xs = (a2 w2) @ (p2 w2) \<and> ys = (wordinverse (p2 w2)) @ (b2 w2) \<and> reduced ((a2 w2) @ (b2 w2))" using 1 by auto
  then have "w2 = (cancel2 xs ys)" using 2 assms(1,2) cancel2E' by blast
  then have "a2 w2 = a2 (cancel2 xs ys)" by simp
  then show ?thesis using 3 by simp
qed

text\<open>The following definition G returns the span set of all elements of H,
 less than a given element g.\<close>

definition G'
  where
"G' G S X = \<langle>{Y \<in> carrier G. (Y,X) \<in> (lex_L2_word S)}\<rangle>\<^bsub>G\<^esub>"

text\<open>The following definition X' returns all the elements g of a group H,
 which do not belong to the G' H A g. We implicitly assume that H is a subgroup of freegroup of A,
which is the context in which this definition is deployed.\<close>

definition X'
  where
"X' G S = {X \<in> carrier G. X \<notin> (G' G S X)}"

lemma subset_span:
  assumes "B \<subseteq> \<langle>A\<rangle>\<^bsub>G\<^esub>"
  shows "\<langle>B\<rangle>\<^bsub>G\<^esub> \<subseteq> \<langle>A\<rangle>\<^bsub>G\<^esub>"
proof
  fix x assume "x \<in> \<langle>B\<rangle>\<^bsub>G\<^esub>"
  then show "x \<in> \<langle>A\<rangle>\<^bsub>G\<^esub>"
  proof(induction rule: gen_span.induct)
    case gen_one
    then show ?case by simp
  next
    case (gen_gens x)
    then show ?case using assms by blast
  next
    case (gen_inv x)
    then show ?case by (simp add: gen_span.gen_inv)
  next
    case (gen_mult x y)
    then show ?case by (simp add: gen_span.gen_mult)
  qed
qed

lemma subgroup_is_group:
  assumes "group G"
      and "subgroup H G"
  shows "group (G\<lparr>carrier := H\<rparr>)"
  by (simp add: assms(1) assms(2) subgroup.subgroup_is_group)

definition SG where "SG H G = (H\<lparr> carrier := G \<rparr>)"

text\<open>Follow lemma tells us that X' H A, spans the subgroup H.
   The proof uses well ordering property to show that every subset contains a
    least element.\<close>
lemma span_X_SG_eq_SG:
  assumes "G \<le> freegroup S"
  shows "\<langle>X' (SG (freegroup S) G) S\<rangle>\<^bsub>(SG (freegroup S) G)\<^esub> = carrier (SG (freegroup S) G)"
proof(rule ccontr)
  assume a:"\<langle>X' (SG (freegroup S) G) S\<rangle>\<^bsub>(SG (freegroup S) G)\<^esub> \<noteq>  carrier (SG (freegroup S) G)"
  have "X' (SG (freegroup S) G) S \<subseteq> carrier (SG (freegroup S) G)" unfolding X'_def SG_def by fastforce
  moreover have "group (SG (freegroup S) G)" using assms freegroup_is_group subgroup_is_group unfolding SG_def by blast
  ultimately have "\<langle>X' (SG (freegroup S) G) S\<rangle>\<^bsub>(SG (freegroup S) G)\<^esub> \<subseteq> carrier (SG (freegroup S) G)" using group.gen_span_closed by blast
  then have "carrier (SG (freegroup S) G) - \<langle>X' (SG (freegroup S) G) S\<rangle>\<^bsub>(SG (freegroup S) G)\<^esub>
                  \<noteq>  {}" using a by blast
  then obtain x where "x \<in> (carrier (SG (freegroup S) G) - \<langle>X' (SG (freegroup S) G) S\<rangle>\<^bsub>(SG (freegroup S) G)\<^esub>)" by blast
  then obtain x' where 1:"x'\<in> (carrier (SG (freegroup S) G) - \<langle>X' (SG (freegroup S) G) S\<rangle>\<^bsub>(SG (freegroup S) G)\<^esub>) \<and>  (\<forall>y. (y, x') \<in> lex_L2_word S \<longrightarrow> y \<notin> (carrier (SG (freegroup S) G) - \<langle>X' (SG (freegroup S) G) S\<rangle>\<^bsub>(SG (freegroup S) G)\<^esub>))" using wfE_min[of "(lex_L2_word S)" "x" "(carrier (SG (freegroup S) G) - \<langle>X' (SG (freegroup S) G) S\<rangle>\<^bsub>(SG (freegroup S) G)\<^esub>)"] wf_lex_L2_word by metis
  then have "\<forall>y \<in> (carrier (SG (freegroup S) G)). (y,x') \<in> (lex_L2_word S) \<longrightarrow> y \<in> \<langle>X' (SG (freegroup S) G) S\<rangle>\<^bsub>(SG (freegroup S) G)\<^esub>" by blast
  then have "{h \<in> (carrier (SG (freegroup S) G)). (h,x') \<in> (lex_L2_word S)} \<subseteq> \<langle>X' (SG (freegroup S) G) S\<rangle>\<^bsub>(SG (freegroup S) G)\<^esub>" by blast
  then have "\<langle>{h \<in> (carrier (SG (freegroup S) G)). (h,x') \<in> (lex_L2_word S)}\<rangle>\<^bsub>(SG (freegroup S) G)\<^esub> \<subseteq> \<langle>X' (SG (freegroup S) G) S\<rangle>\<^bsub>(SG (freegroup S) G)\<^esub>" using subset_span by blast
  moreover have 2: "x' \<notin> \<langle>X' (SG (freegroup S) G) S\<rangle>\<^bsub>(SG (freegroup S) G)\<^esub>" using 1 by blast
  ultimately have "x' \<notin> G' (SG (freegroup S) G) S x'" unfolding G'_def X'_def by blast
  moreover have "x' \<in> (carrier (SG (freegroup S) G))" using 1 by blast
  ultimately have "x' \<in> X' (SG (freegroup S) G) S" unfolding X'_def by blast
  then have "x' \<in> (\<langle>X' (SG (freegroup S) G) S\<rangle>\<^bsub>(SG (freegroup S) G)\<^esub>)" by (simp add: gen_span.gen_gens)
  then show False using 2 by blast
qed

lemma span_X'_SG_eq_SG:
  assumes "H \<le> freegroup S"
  shows "(let SubGp = ((freegroup S)\<lparr> carrier := H\<rparr>)
             in \<langle>X' SubGp S\<rangle>\<^bsub>(SubGp)\<^esub> = carrier (SubGp))"
  using assms unfolding SG_def
  by (metis SG_def span_X_SG_eq_SG)

text\<open>Here we define the property N0, as the the property that word is nonempty\<close>

definition N0
  where
"N0 xs = (xs \<noteq>  [])"

lemma sublist_inverse:
"\<forall>n < (length (x#xs) - 1). ((x#xs)!n) \<noteq>  (wordinverse ((x#xs)!(n+1))) \<Longrightarrow> \<forall>n < (length (xs) - 1). ((xs)!n) \<noteq>  (wordinverse ((xs)!(n+1)))"
proof-
  assume assm:"\<forall>n < (length (x#xs) - 1). ((x#xs)!n) \<noteq>  (wordinverse ((x#xs)!(n+1)))"
  show "\<forall>n < (length (xs) - 1). ((xs)!n) \<noteq>  (wordinverse ((xs)!(n+1)))"
    apply(rule allI)
    apply(rule impI)
  proof-
    fix n assume n:"n < length xs - 1"
    have 1:"((x#xs)!(n+1)) = (xs!n)" by auto
    have 2: "((x#xs)!(n+2)) = (xs!(n+1))" by simp
    have 3:"(n+1) < length (x#xs) - 1" using n by simp
    show "((xs)!n) \<noteq>  (wordinverse ((xs)!(n+1)))"
    proof(rule ccontr)
      assume " \<not> xs ! n \<noteq>  wordinverse (xs ! (n + 1))"
      then have "xs ! n = wordinverse (xs ! (n + 1))" by blast
      then have "((x#xs)!(n+1)) = wordinverse ((x#xs)!(n+2))" using 1 2 by argo
      then show False using 3 assm by fastforce
    qed
  qed
qed

lemma hd_notempty:
  assumes "A \<subseteq> (red_rep S ` carrier (freegroup S))"
      and "\<forall>xs \<in> A. N0 xs"
      and "\<forall>xs \<in> A. \<forall>ys \<in> A. N1 xs ys"
      and "\<forall>xs \<in> A. \<forall>ys \<in> A. \<forall>zs \<in> A. N2 xs ys zs"
      and "set (l#ls) \<subseteq> A"
      and "\<forall>n < (length (l#ls) - 1). ((l#ls)!n) \<noteq>  (wordinverse ((l#ls)!(n+1)))"
    shows "\<exists>a b c. l = a@b \<and> l_concat (l#ls) ~ a@c \<and> reduced (a@c) \<and> a \<noteq>  [] \<and> ((ls \<noteq>  [])
            \<longrightarrow> a =  a2 (cancel2 l (hd ls)))"
  using assms
proof(induction "(l#ls)" arbitrary: l ls)
  case (Cons y z)
    have y: "y \<in> A" using Cons.prems(5) by auto
    moreover then obtain Y where "Y \<in> carrier (freegroup S) \<and> y = red_rep S Y" using Cons.prems(1) by blast
    ultimately have ry:"reduced y" using Cons.prems(1) unfolding freegroup_def by (simp add: red_rep_the)
    have y0:"y \<noteq>  []" using N0_def y assms(2) by auto
  then show ?case
  proof(cases "z = []")
    case True
    have "l_concat (y # z) = y" using True unfolding l_concat_def by simp
    moreover have "y = y@[]" by simp
    moreover then have "y ~ y" using refl by fast
    ultimately show ?thesis using ry y0 True by metis
  next
    case False
    then obtain z1 z2 where z:"z = (z1#z2)" using list.exhaust by blast
    have z1:"z1 \<in> A" using Cons.prems(5) z by auto
    then have z10:"z1 \<noteq>  []" using N0_def assms(2) by auto
    obtain Z1 where "Z1 \<in> carrier (freegroup S) \<and> z1 = red_rep S Z1" using Cons.prems(1) z1 by blast
    then have rz1: "reduced z1" using z1 using Cons.prems(1) unfolding freegroup_def by (simp add: red_rep_the)
    then show ?thesis
    proof(cases "z2 = []")
      case True
      then have 1:"l_concat (y#z) = (y@z1)" using z unfolding l_concat_def by simp
      have N1:"N1 y z1" using Cons.prems(3) y z1 by simp
      have yz1:"y \<noteq>  wordinverse z1" using z True Cons.prems(6) by force
      define w where w:"w = cancel2 y z1"
      then have w':"y = a2 w @  p2 w \<and> z1 = (wordinverse (p2 w)) @ b2 w \<and> reduced (a2 w@b2 w)" unfolding cancel2_def using cancel2_the ry rz1 w by fastforce
      moreover then have "(y@z1) ~ (a2 w@b2 w)" using cancel2_reln by blast
      moreover have "a2 w \<noteq>  []"
      proof(rule ccontr)
        assume "\<not> a2 w \<noteq>  []"
        then have a2w:"a2 w = []" by blast
        have "p2 w = []" using w a2w N1 yz1 unfolding N1_def by simp
        then have "y = []" using w' a2w  by simp
        then show False using y0 by blast
      qed
      moreover have "hd z = z1" using z by simp
      ultimately show ?thesis using 1 w by force
    next
      case False
      then obtain z3 z4 where z2:"z2 = (z3#z4)" using list.exhaust by auto
      then have "set (z1#z3#z4) \<subseteq> A" using z using Cons.prems(5) by auto
      moreover have "\<forall>n < (length (z1#z3#z4) - 1). ((z1#z3#z4)!n) \<noteq>  (wordinverse ((z1#z3#z4)!(n+1)))" using z2 z Cons.prems(6) sublist_inverse by blast
      ultimately obtain a b c where  1:"z1 = a @ b \<and>
       l_concat (z1 # z3 # z4) ~ a @ c \<and> reduced (a @ c) \<and> a \<noteq>  [] \<and>  ((z3#z4 \<noteq>  []) \<longrightarrow> (a = a2 (z1 \<oslash>\<^bsub>2\<^esub> hd (z3#z4))))" using Cons z2 z by blast
      then have a:"a = a2 (z1 \<oslash>\<^bsub>2\<^esub> z3)" using False z2 by fastforce
      have N2:"N2 y z1 z3" using Cons.prems(1,4,5) z z2 by auto
      have 11:"N1 y z1" using Cons.prems(1,3,5) z z2  by fastforce
      have 12:"N1 z1 z3" using Cons.prems(1,3,5) z z2  by fastforce
      obtain Z3 where "Z3 \<in> carrier (freegroup S) \<and> z3 = red_rep S Z3" using Cons.prems(1,5) z z2 by auto
      then have rz3: "reduced z3" using z1 using Cons.prems(1) unfolding freegroup_def by (simp add: red_rep_the)
      define w where w:"w = cancel3 y z1 z3"
      have "(y#z) = (y#z1#z3#z4)"using z z2 by auto
      then have inv:"y \<noteq>  wordinverse z1 \<and> z1 \<noteq>  wordinverse z3" using Cons.prems(6) Ex_list_of_length by auto
      then have 2:"y = a3 w @ (p3 w) \<and> z1 = wordinverse  (p3 w) @ b3 w @ (q3 w) \<and> z3 = (wordinverse  (q3 w)) @ (c3 w) \<and> reduced (a3 w @ b3 w @ q3 w) \<and> reduced (wordinverse  (p3 w) @ b3 w @ c3 w)" using N2 11 12 ry rz1 rz3 w by (simp add: cancel3_the)
      have apb:"a =  wordinverse (p3 w) @ b3 w" using N2 11 12 ry rz1 rz3 w a cancel_a2_pb3 inv by blast
      have "l_concat (y # z) ~ a3 w @ (b3 w @ c)"
      proof-
        have "l_concat (y # z) = y@ l_concat (z1 # z3 # z4)" unfolding l_concat_def using z z2 by auto
        then have "l_concat (y # z) ~ y@a@c" using 1  mult reln.refl by metis
        moreover have "y@a@c = a3 w @ (p3 w) @ wordinverse (p3 w) @ b3 (w)@c" using 2 apb by simp
        moreover have "(a3 w @ (p3 w) @ wordinverse (p3 w) @ b3 w @ c) ~ (a3 w @ (b3 w @ c))" using cancel2_reln by auto
        ultimately show ?thesis using reln.trans by auto
      qed
      moreover have "reduced (a3 w @ (b3 w @ c))"
      proof-
        have A:"reduced (wordinverse (p3 w) @ b3 w @ c)" using 1 apb by force
        then have "reduced (b3 w @ c)" using reduced_leftappend by blast
        moreover have "reduced (a3 w @ b3 w)" using 2 reduced_rightappend by (metis append.assoc)
        ultimately show ?thesis using N2 N2_def inv reduced_overlap w by blast
      qed
      moreover have "a3 w \<noteq>  [] \<and> a3 w = a2 (cancel2 y (hd z))"
      proof-
        have "hd z = z1" using z by force
        then have A:"a3 w = a2 (cancel2 y (hd z))" using w N2 11 12 ry rz1 rz3 inv cancel_a2_a3 by metis
        define v where v:"v = cancel2 y z1"
        then have vv:"y = a2 v @  p2 v \<and> z1 = (wordinverse (p2 v)) @ b2 v \<and> reduced (a2 v@b2 v)" using cancel2_the ry rz1 w by fastforce
        have B: "a3 w \<noteq>  []"
        proof(rule ccontr)
          assume "\<not> a3 w \<noteq>  []"
          then have "a3 w = []" by simp
          then have "a2 v = []" using v w N2 11 12 ry rz1 rz3 inv cancel_a2_a3 by metis
          moreover then have "p2 v = []" using v 11 inv unfolding N1_def by simp
          ultimately have "y = []" using vv by simp
          then show "False" using y0 by blast
        qed
        then show ?thesis using A B by blast
      qed
      ultimately show ?thesis using 2 by blast
    qed
  qed
qed

text\<open>In the lemma n reduced cancel, we prove that if B is a subset of reduced words of elements
    of a free group, and if all the words in B, satisfy the properties N0, N1, and N2,
    then any word constructed by concatenating elements of B, such that successive elements
    in the word are not wordinverses of each other, does not reduced to an empty word.
 \<close>
lemma n_reduced_cancel:
  assumes "A \<subseteq> (red_rep S ` carrier (freegroup S))"
      and "\<forall>xs \<in> A. N0 xs"
      and "\<forall>xs \<in> A. \<forall>ys \<in> A. N1 xs ys"
      and "\<forall>xs \<in> A. \<forall>ys \<in> A. \<forall>zs \<in> A. N2 xs ys zs"
      and "set ls \<subseteq> A"
      and "\<forall>n < (length ls - 1). (ls!n) \<noteq>  (wordinverse (ls!(n+1)))"
      and "ls \<noteq>  []"
    shows "\<not> (l_concat ls ~ [])"
proof-
  obtain x xs where l:"ls = (x#xs)" using assms(7) list.exhaust by blast
  then obtain a b c where A:"x = a@b \<and> l_concat (x#xs) ~ a@c \<and> reduced (a@c) \<and> a \<noteq>  [] \<and> ((xs \<noteq>  []) \<longrightarrow> a =  a2 (cancel2 x (hd xs)))" using assms hd_notempty[of "A" "S"] by presburger
  show ?thesis
  proof(rule ccontr)
    assume "\<not> \<not> l_concat ls ~ []"
    then have "l_concat ls ~ []" by blast
    moreover have "l_concat ls ~ (a@c)" using l A by blast
    ultimately have "(a@c) ~ []" using reln.sym reln.trans by blast
    moreover have "reduced (a@c)" using A by blast
    moreover have "reduced []" by simp
    ultimately have "(a@c) = []" using reduced_reln_eq by blast
    moreover have "(a@c) \<noteq>  []" using A by blast
    ultimately show False by blast
  qed
qed

lemma span_subset:
  assumes "A \<subseteq> B"
  shows "\<langle>A\<rangle>\<^bsub>H\<^esub> \<subseteq> \<langle>B\<rangle>\<^bsub>H\<^esub>"
  using assms gen_span.gen_gens subset_iff subset_span by metis

lemma one_SG:  "\<one>\<^bsub>G\<^esub> = \<one>\<^bsub>SG G H\<^esub>"
  unfolding SG_def by simp

lemma mult_SG: "x \<otimes>\<^bsub>G\<^esub> y = x \<otimes>\<^bsub>SG G H\<^esub> y"
  by (simp add: SG_def)

lemma inv_SG: "group G \<Longrightarrow> y \<in> H \<Longrightarrow> subgroup H G \<Longrightarrow> inv\<^bsub>G\<^esub> y = inv\<^bsub>SG G H\<^esub> y"
  unfolding SG_def by (simp add: group.m_inv_consistent)

text\<open>The following lemmas are used to obtain a contradiction in the proof to show that
reduced words corresponding to elements of X` H A and their inverses, where H is a subgroup of
freegroup on A, satisfy N1 and N2. These lemmas make the proof of Proposition 2.9 in
Lyndon and Schupp more explicit.\<close>

lemma lex_cont1:
  assumes "(Y,X) \<in> lex_L2_word S"
      and "(X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y, X) \<in> lex_L2_word S"
      and "X \<in> G"
      and "Y \<in> G"
      and "G \<le> F\<^bsub>S\<^esub>"
    shows "X \<notin> X' (SG (F\<^bsub>S\<^esub>) G) S"
proof-
  have "group F\<^bsub>S\<^esub>"  by (simp add: freegroup_is_group)
  then have 1: "group (SG (F\<^bsub>S\<^esub>) G)"  unfolding SG_def by (simp add: subgroup_is_group assms(5))
  have xH:"X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y \<in> G" by (metis assms(3) assms(4) assms(5) mult_SG subgroup_def)
  then have "{Y, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y} \<subseteq> {h \<in> G. (h,X) \<in> (lex_L2_word S)}" using assms(1) assms(2) assms(4) by auto
  moreover have H:"G = carrier (SG F\<^bsub>S\<^esub> G)" unfolding SG_def by simp
  ultimately have 2:"\<langle>{Y, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> \<subseteq> G' (SG (F\<^bsub>S\<^esub>) G) S X" unfolding G'_def using span_subset by (metis (no_types, lifting) Collect_cong)
  have "inv \<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y \<in> \<langle>{Y, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" by (simp add: gen_span.gen_gens gen_span.gen_inv)
  moreover have 3: "X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y \<in> \<langle>{Y, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" by (simp add: gen_span.gen_gens)
  ultimately have "X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> inv \<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y \<in> \<langle>{Y, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" by (simp add: gen_span.gen_mult)
  then have "X  \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> \<one>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> \<in> \<langle>{Y, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" using 1 3 xH H  assms(3) assms(4) gen_span.gen_mult gen_span.gen_one by (metis group.inv_solve_right')
  then have "X \<in> \<langle>{Y, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" using 1 H assms(3) group.is_monoid by force
  then have "X \<in>  G' (SG (F\<^bsub>S\<^esub>) G) S X" using 2 by auto
  then show ?thesis by (simp add: X'_def)
qed

lemma lex_cont1_inv:
  assumes "(Y,X) \<in> lex_L2_word S"
      and "(X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y, X) \<in> lex_L2_word S"
      and "X \<in> G"
      and "Y \<in> G"
      and "G \<le> F\<^bsub>S\<^esub>"
    shows "inv\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> X \<notin> X' (SG (F\<^bsub>S\<^esub>) G) S"
proof-
  have "group F\<^bsub>S\<^esub>"  by (simp add: freegroup_is_group)
  then have 1: "group (SG (F\<^bsub>S\<^esub>) G)"  unfolding SG_def by (simp add: subgroup_is_group assms(5))
  have y:"(Y,inv\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> X) \<in> lex_L2_word S" using freegroup_is_group assms(1) assms(3) assms(5) inv_SG lex_L2_inv by metis
  have xy: "(X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y, inv\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> X) \<in> lex_L2_word S"  using freegroup_is_group assms(2) assms(3) assms(5) inv_SG lex_L2_inv by metis
  have xH:"X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y \<in> G" by (metis assms(3) assms(4) assms(5) mult_SG subgroup_def)
  then have "{Y, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y} \<subseteq> {h \<in> G. (h,inv\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> X) \<in> (lex_L2_word S)}" using y xy assms(4) by auto
  moreover have H:"G = carrier (SG F\<^bsub>S\<^esub> G)" unfolding SG_def by simp
  ultimately have 2:"\<langle>{Y, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> \<subseteq> G' (SG (F\<^bsub>S\<^esub>) G) S (inv\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> X)" unfolding G'_def using span_subset by (metis (no_types, lifting) Collect_cong)
  have "inv \<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y \<in> \<langle>{Y, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" by (simp add: gen_span.gen_gens gen_span.gen_inv)
  moreover have 3: "X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y \<in> \<langle>{Y, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" by (simp add: gen_span.gen_gens)
  ultimately have "X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> inv \<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y \<in> \<langle>{Y, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" by (simp add: gen_span.gen_mult)
  then have "X  \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> \<one>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> \<in> \<langle>{Y, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" using 1 3 xH H  assms(3) assms(4) gen_span.gen_mult gen_span.gen_one by (metis group.inv_solve_right')
  then have "X \<in> \<langle>{Y, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" using 1 H assms(3) group.is_monoid by force
  then have "(inv\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> X) \<in> \<langle>{Y, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>"  by (simp add: gen_span.gen_inv)
  then have "(inv\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> X) \<in>  G' (SG (F\<^bsub>S\<^esub>) G) S (inv\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> X)" using 2 by blast
  then show ?thesis by (simp add: X'_def)
qed

lemma lex_cont2_inv:
  assumes "(X,Y) \<in> lex_L2_word S"
      and "(X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y, Y) \<in> lex_L2_word S"
      and "X \<in> G"
      and "Y \<in> G"
      and "G \<le> F\<^bsub>S\<^esub>"
    shows "inv\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y \<notin> X' (SG (F\<^bsub>S\<^esub>) G) S"
proof-
  have "group F\<^bsub>S\<^esub>"  by (simp add: freegroup_is_group)
  then have 1: "group (SG (F\<^bsub>S\<^esub>) G)"  unfolding SG_def by (simp add: subgroup_is_group assms(5))
  have x:"(X,inv\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y) \<in> lex_L2_word S" using freegroup_is_group assms(1) assms(4) assms(5) inv_SG lex_L2_inv by metis
  have xy: "(X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y, inv\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y) \<in> lex_L2_word S" using freegroup_is_group assms(2) assms(4) assms(5) inv_SG lex_L2_inv by metis
  have xH:"X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y \<in> G" by (metis assms(3) assms(4) assms(5) mult_SG subgroup_def)
  then have "{X, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y} \<subseteq> {h \<in> G. (h,inv\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y) \<in> (lex_L2_word S)}" using x xy assms(3) by auto
  moreover have H:"G = carrier (SG F\<^bsub>S\<^esub> G)" unfolding SG_def by simp
  ultimately have 2:"\<langle>{X, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> \<subseteq> G' (SG (F\<^bsub>S\<^esub>) G) S (inv\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y)" unfolding G'_def using span_subset by (metis (no_types, lifting) Collect_cong)
  have "inv \<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> X \<in> \<langle>{X, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" by (simp add: gen_span.gen_gens gen_span.gen_inv)
  moreover have 3: "X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y \<in> \<langle>{X, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" by (simp add: gen_span.gen_gens)
  ultimately have "inv \<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y  \<in> \<langle>{X, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" using 1 H assms(3) assms(4) gen_span.gen_mult group.inv_closed group.is_monoid monoid.m_assoc by fastforce
  then have "\<one>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>  \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y \<in> \<langle>{X, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" using 1 3 xH H  assms(3) assms(4) group.l_inv by fastforce
  then have "Y \<in> \<langle>{X, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" using 1 H assms(4) group.is_monoid by force
  then have "inv\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y \<in> \<langle>{X, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" by (simp add: gen_span.gen_inv)
  then have "inv\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y \<in>  G' (SG (F\<^bsub>S\<^esub>) G) S (inv\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y)" using 2 by auto
  then show ?thesis by (simp add: X'_def)
qed

lemma lex_cont2:
  assumes "(X,Y) \<in> lex_L2_word S"
      and "(X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y, Y) \<in> lex_L2_word S"
      and "X \<in> G"
      and "Y \<in> G"
      and "G \<le> F\<^bsub>S\<^esub>"
    shows "Y \<notin> X' (SG (F\<^bsub>S\<^esub>) G) S"
proof-
  have "group F\<^bsub>S\<^esub>"  by (simp add: freegroup_is_group)
  then have 1: "group (SG (F\<^bsub>S\<^esub>) G)"  unfolding SG_def by (simp add: subgroup_is_group assms(5))
  have xH:"X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y \<in> G" by (metis assms(3) assms(4) assms(5) mult_SG subgroup_def)
  then have "{X, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y} \<subseteq> {h \<in> G. (h,Y) \<in> (lex_L2_word S)}" using assms(1) assms(2) assms(3) by auto
  moreover have H:"G = carrier (SG F\<^bsub>S\<^esub> G)" unfolding SG_def by simp
  ultimately have 2:"\<langle>{X, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> \<subseteq> G' (SG (F\<^bsub>S\<^esub>) G) S Y" unfolding G'_def using span_subset by (metis (no_types, lifting) Collect_cong)
  have "inv \<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> X \<in> \<langle>{X, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" by (simp add: gen_span.gen_gens gen_span.gen_inv)
  moreover have 3: "X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y \<in> \<langle>{X, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" by (simp add: gen_span.gen_gens)
  ultimately have "inv \<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y  \<in> \<langle>{X, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" using 1 H assms(3) assms(4) gen_span.gen_mult group.inv_closed group.is_monoid monoid.m_assoc by fastforce
  then have "\<one>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>  \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y \<in> \<langle>{X, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" using 1 3 xH H  assms(3) assms(4) group.l_inv by fastforce
  then have "Y \<in> \<langle>{X, X \<otimes>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> Y}\<rangle>\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub>" using 1 H assms(4) group.is_monoid by force
  then have "Y \<in>  G' (SG (F\<^bsub>S\<^esub>) G) S Y" using 2 by auto
  then show ?thesis by (simp add: X'_def)
qed

lemma inv_X_clos: assumes "H \<le> freegroup A"
  shows "m_inv F\<^bsub>A\<^esub> ` {g \<in> carrier (F\<^bsub>A\<^esub>\<lparr>carrier := H\<rparr>). g \<notin> G (F\<^bsub>A\<^esub>\<lparr>carrier := H\<rparr>) A g}
    \<subseteq> carrier F\<^bsub>A\<^esub>"
proof
  fix x assume "x \<in> m_inv F\<^bsub>A\<^esub> `
             {g \<in> carrier (F\<^bsub>A\<^esub>\<lparr>carrier := H\<rparr>). g \<notin> G (F\<^bsub>A\<^esub>\<lparr>carrier := H\<rparr>) A g}"
  then obtain y where y: "m_inv F\<^bsub>A\<^esub> y = x \<and> y \<in> {g \<in> carrier (F\<^bsub>A\<^esub>\<lparr>carrier := H\<rparr>). g \<notin> G (F\<^bsub>A\<^esub>\<lparr>carrier := H\<rparr>) A g}" by blast
  then have "y \<in> carrier F\<^bsub>A\<^esub>" using assms freegroup_is_group group.subgroupE(1) by auto
  then have "m_inv F\<^bsub>A\<^esub> y \<in> carrier F\<^bsub>A\<^esub>" using y assms subgroup.m_inv_closed subgroup.mem_carrier by fastforce
  then show "x \<in> carrier F\<^bsub>A\<^esub>" using y by blast
qed

lemma union_inv_clos:
  assumes "G \<le> freegroup S"
  shows "(union_inv (X' (SG (freegroup S) G) S) S) \<subseteq> carrier (freegroup S)"
  unfolding X'_def union_inv_def SG_def
proof-
  have "{g \<in> carrier (F\<^bsub>S\<^esub>\<lparr>carrier := G\<rparr>). g \<notin> G' (F\<^bsub>S\<^esub>\<lparr>carrier := G\<rparr>) S g} \<subseteq> carrier (freegroup S)" using assms subgroup.subset by auto
  moreover have "m_inv F\<^bsub>S\<^esub> ` {g \<in> carrier (F\<^bsub>S\<^esub>\<lparr>carrier := G\<rparr>). g \<notin> G' (F\<^bsub>S\<^esub>\<lparr>carrier := G\<rparr>) S g}
    \<subseteq> carrier F\<^bsub>S\<^esub>" using assms inv_X_clos by blast
  ultimately show "{g \<in> carrier (F\<^bsub>S\<^esub>\<lparr>carrier := G\<rparr>). g \<notin> G' (F\<^bsub>S\<^esub>\<lparr>carrier := G\<rparr>) S g} \<union>
    m_inv F\<^bsub>S\<^esub> ` {g \<in> carrier (F\<^bsub>S\<^esub>\<lparr>carrier := G\<rparr>). g \<notin> G' (F\<^bsub>S\<^esub>\<lparr>carrier := G\<rparr>) S g}
    \<subseteq> carrier F\<^bsub>S\<^esub>" by blast
qed

lemma union_inv_sub_H:
  assumes "G \<le> freegroup S" "X \<in> (union_inv (X' (SG (freegroup S) G) S) S)"
  shows "X \<in> G"
proof-
  have 1:"X \<in> (X' (SG (freegroup S) G) S) \<union> (m_inv (freegroup S) ` (X' (SG (freegroup S) G) S))" using union_inv_def using assms(2) by auto
  then show ?thesis
  proof(cases "X \<in> (X' (SG (freegroup S) G) S)")
    case True
    then have "X \<in> {g \<in> carrier (SG (freegroup S) G). g \<notin> (G' (SG (freegroup S) G) S g)}" using X'_def by auto
    then have "X \<in> carrier (SG (freegroup S) G)" by simp
    then have "X \<in> carrier ((freegroup S)\<lparr>carrier := G\<rparr>)" using SG_def by metis
    then show ?thesis using assms(1) by auto
  next
    case False
    then have "X \<in> (m_inv (freegroup S) ` (X' (SG (freegroup S) G) S))" using 1 by auto
    moreover then have "X \<in> carrier ((freegroup S)\<lparr>carrier := G\<rparr>)" using m_inv_def assms(1) SG_def X'_def union_inv_clos by (smt (verit)  image_iff mem_Collect_eq partial_object.select_convs(1) partial_object.surjective partial_object.update_convs(1) subgroup.m_inv_closed)
    ultimately show ?thesis using assms(1) by auto
  qed
qed

lemma min_L2_inv:
  assumes "X \<in> carrier (freegroup S)"
  shows "min lex_word (L2(red_rep S X)) = min lex_word( L2(wordinverse (red_rep S X)))"
unfolding left_tuple_def min.simps by (metis FreeGroupMain.wordinverse_of_wordinverse lex_word_total wf_lex_word wf_not_sym)

lemma length_eq:
  assumes "xs = a@c" "ys = b@c" "length a = length b"
  shows "length xs = length ys" using assms by simp

lemma lex_word_one: "(xs,ys) \<in> lex_word \<Longrightarrow> xs \<noteq> ys \<Longrightarrow> \<not> (ys,xs) \<in> lex_word"
  by (metis wf_lex_word wf_not_sym)

lemma trans_lex_word:"trans lex_word"
proof-
  have 1: "trans (r_gen - Id)" using r_gen strict_linear_order_on_def strict_linear_order_on_diff_Id well_order_on_def by blast
  show ?thesis by (simp add: 1 lenlex_transI lex_word_def)
qed

lemma trans_lex_L2_word': "trans (lex_L2_word' S)"
  unfolding lex_L2_word'_def using trans_lex_word
  by (smt (z3) case_prodD case_prodI mem_Collect_eq trans_def trans_lex_prod)

lemma trans_nat_less: "trans nat_less"
  unfolding nat_less_def
  by (metis (no_types, lifting) less_than_iff mem_Collect_eq old.prod.case transD transI trans_less_than)

lemma trans_lex_L2_word: "trans (lex_L2_word S)"
  unfolding lex_L2_word_def using trans_lex_L2_word' trans_nat_less
  by (smt (z3) case_prodD case_prodI mem_Collect_eq trans_def trans_lex_prod)

lemma lex_L2_word_total_1:
  assumes "X \<in> carrier (freegroup S)"
      and "Y \<in> carrier (freegroup S)"
      and "length (red_rep S X) = length (red_rep S Y)"
    shows "\<not> (X,Y) \<in> lex_L2_word S \<and> \<not> (Y, X) \<in> lex_L2_word S
      \<Longrightarrow> red_rep S X = red_rep S Y \<or> red_rep S X = wordinverse (red_rep S Y)"
  using assms unfolding freegroup_def using lex_L2_word_total1
        lex_L2_word_total2 eq_L2_eq rev_L2_inv
  by (metis partial_object.select_convs(1))

lemma lex_L2_word_total_2:
  assumes "X \<in> carrier (freegroup S)"
      and "Y \<in> carrier (freegroup S)"
      and "length (red_rep S X) = length (red_rep S Y)"
    shows "red_rep S X \<noteq> red_rep S Y \<and> red_rep S X \<noteq> wordinverse (red_rep S Y) \<Longrightarrow> (X,Y) \<in> lex_L2_word S \<or> (Y, X) \<in> lex_L2_word S"
  using assms lex_L2_word_total_1 by blast

lemma lex_total:
  assumes "X \<in> carrier (freegroup S)"
      and "Y \<in> carrier (freegroup S)"
      and "red_rep S X \<noteq> wordinverse (red_rep S Y)"
      and "red_rep S X \<noteq> (red_rep S Y)"
  shows "(X,Y) \<in> lex_L2_word S \<or> (Y, X) \<in> lex_L2_word S"
proof(cases "length (red_rep S X) > length (red_rep S Y)")
  case True
  then have "(Y,X) \<in> lex_L2_word S" using assms(1) assms(2) length_lex by blast
  then show ?thesis by blast
next
  case False note F = this
  then show ?thesis
  proof(cases "length (red_rep S X) < length (red_rep S Y)")
    case True
    then have "(X,Y) \<in> lex_L2_word S" using assms(1) assms(2) length_lex by blast
    then show ?thesis by blast
  next
    case False
    then have "length (red_rep S X) = length (red_rep S Y)" using F by simp
    then show ?thesis using assms(1,2,3,4) lex_L2_word_total_2 by blast
  qed
qed

lemma reduced_inv_eq_imp_nil: "xs = wordinverse xs \<Longrightarrow> reduced xs \<Longrightarrow> xs = []"
proof-
  assume xs:"xs = wordinverse xs " and rxs:"reduced xs"
  then show "xs = []"
  proof(cases "odd (length xs)")
    case True
      then have 1:"length xs > 0" using True by fastforce
      then have 2:"length xs > (length xs div 2)" by simp
      have "length (drop (length xs div 2) xs) = length xs - (length xs div 2) " by simp
      then have "length (drop (length xs div 2) xs) > 0" using 2 by simp
      then have "(drop (length xs div 2) xs) \<noteq> []" by fast
      moreover have "drop ((length xs div 2)+1) xs = tl (drop ((length xs div 2)) xs)" using drop_Suc tl_drop by (simp add: drop_Suc tl_drop)
      ultimately have  "[hd (drop (length xs div 2) xs)] @  drop ((length xs div 2)+1) xs = (drop (length xs div 2) xs)" by simp
      moreover have "xs = take (length xs div 2) xs @ drop (length xs div 2) xs" by simp
      ultimately have 3:"xs = take (length xs div 2) xs @ [hd (drop (length xs div 2) xs)] @ drop ((length xs div 2)+1) xs" by presburger
      then have "wordinverse xs = (map inverse) (rev (take (length xs div 2) xs @ [hd (drop (length xs div 2) xs)] @ drop ((length xs div 2)+1) xs))" using wordinverse_redef2 by auto
      then have "wordinverse xs = (map inverse) (rev (drop ((length xs div 2)+1) xs)  @ rev [hd (drop (length xs div 2) xs)] @ rev (take (length xs div 2) xs))" by simp
      then have "wordinverse xs = ((map inverse) (rev (drop ((length xs div 2)+1) xs))  @ [inverse (hd (drop (length xs div 2) xs))] @ (map inverse) (rev (take (length xs div 2) xs)))" by simp
      moreover have "length (take (length xs div 2) xs) = length ((map inverse)(rev (drop ((length xs div 2)+1) xs)))" using True drop_odd_length by fastforce
      ultimately have "[inverse (hd (drop (length xs div 2) xs))] = [hd (drop (length xs div 2) xs)]" using 3 xs by (metis (no_types, lifting) append_eq_append_conv hd_append2 list.sel(1) not_Cons_self2)
      then show ?thesis by (metis inverse_neq list.sel(1))
  next
    case False
    then have "even (length xs)" by blast
    then have x:"xs = L xs @ R xs" unfolding left_subword_def right_subword_def by simp
    moreover then have "wordinverse xs = wordinverse (R xs) @ wordinverse (L xs)" using wordinverse_append by metis
    moreover have "length (L xs) = length (wordinverse (R xs))" using False even_R xs by force
    ultimately have "(L xs) = wordinverse (R xs)" by (metis append_eq_append_conv xs)
    then have "xs = wordinverse (R xs) @ (R xs)" using x by auto
    then have  "\<not> reduced xs \<or> xs = []" by (metis inverse_wordinverse reduced.simps(1) reduced_reln_eq)
    then show ?thesis using rxs by blast
  qed
qed

lemma square_length:
  assumes "X \<in> carrier (freegroup S)"
  shows "length (red_rep S (X \<otimes>\<^bsub> F\<^bsub>S\<^esub>\<^esub> X)) \<ge> length (red_rep S X)"
proof-
  let ?x = "(red_rep S X)"
  let ?xx = "(cancel2 ?x ?x)"
  have xx: "(X \<otimes>\<^bsub>F\<^bsub>S\<^esub>\<^esub> X) \<in> carrier (freegroup S)" by (simp add: assms(1) freegroup_is_group group.subgroupE(4) group.subgroup_self)
  have 1:"reduced ?x" using assms(1) red_rep_def red_rep_the unfolding freegroup_def by fastforce
  then have "((red_rep S X) @ (red_rep S X)) ~ ((a2 ?xx) @ (b2 ?xx))" by (metis cancel2_reln cancel2_the)
  then have "(red_rep S (X \<otimes>\<^bsub>F\<^bsub>S\<^esub>\<^esub> X)) ~ ((a2 ?xx) @ (b2 ?xx))" using assms mult_reln using reln.trans by blast
  moreover have "reduced ((a2 ?xx) @ (b2 ?xx))" by (simp add: "1" cancel2_the)
  moreover have "reduced (red_rep S (X \<otimes>\<^bsub>F\<^bsub>S\<^esub>\<^esub> X))" using xx red_rep_def red_rep_the unfolding freegroup_def by fastforce
  ultimately have 3: "(red_rep S (X \<otimes>\<^bsub>F\<^bsub>S\<^esub>\<^esub> X)) = ((a2 ?xx) @ (b2 ?xx))" by (simp add: reduced_reln_eq)
  have A:"?x = (a2 ?xx) @ (p2 ?xx)" using 1 by (simp add: cancel2_the)
  then have rp:"reduced (p2 ?xx)" using "1" reduced_leftappend by metis
  have B:"?x =  wordinverse (p2 ?xx) @ (b2 ?xx)" using 1 by (simp add: cancel2_the)
  have C:"length (p2 ?xx) = length (wordinverse (p2 ?xx))" using length_wordinverse by blast
  then have D:"length (a2 ?xx) = length (b2 ?xx)" using A B by (metis add_diff_cancel_left' add_diff_cancel_right' length_append)
  show ?thesis
  proof(cases "length (b2 ?xx) > length (p2 ?xx)")
    case True
    then have "length ((a2 ?xx) @ (p2 ?xx)) \<le> length ((a2 ?xx) @ (b2 ?xx))" by simp
    then show ?thesis using 3 A by auto
  next
    case False
    then have F:"length (b2 ?xx) \<le> length (p2 ?xx)" by auto
    then show ?thesis
    proof(cases "length (b2 ?xx) = length (p2 ?xx)")
      case True
      then have "?x = wordinverse (p2 ?xx) @ (p2 ?xx)" by (metis A B D append_eq_append_conv)
      then have "\<not> reduced ?x \<or> ?x = []"  by (metis inverse_wordinverse reduced.simps(1) reduced_reln_eq)
      then show ?thesis by (simp add: 1)
    next
      case False
      then have cont:"length (b2 ?xx) < length (p2 ?xx)" using F by auto
      then obtain c where c:"?x = (a2 ?xx) @ c @ (b2 ?xx)" using A B by (metis D overlaprightexist)
      then have pc:"p2 ?xx = (c @ b2 ?xx)" using A by (metis same_append_eq)
      moreover have "wordinverse (p2 ?xx) = (a2 ?xx) @ c" using c B by (metis append.assoc append_same_eq)
      ultimately have "(c @ b2 ?xx) = (wordinverse c) @ (wordinverse (a2 ?xx))" by (simp add: wordinverse_append wordinverse_symm)
      then have "c = wordinverse c" using append_eq_append_conv length_wordinverse by fast
      moreover have "reduced c" using rp pc using reduced_rightappend by auto
      ultimately have "c = []" using reduced_inv_eq_imp_nil by blast
      then have "length (b2 ?xx) = length (p2 ?xx)" using pc by auto
      then show ?thesis using cont by auto
    qed
  qed
qed

lemma neq_N1:
  assumes "X \<in> carrier (freegroup S)"
    and "Y \<in> carrier (freegroup S)"
    and "length (red_rep S (X \<otimes>\<^bsub> F\<^bsub>S\<^esub>\<^esub> Y)) < length (red_rep S X)
          \<or> length (red_rep S (X \<otimes>\<^bsub> F\<^bsub>S\<^esub>\<^esub> Y)) <  length (red_rep S Y)"
  shows "red_rep S X \<noteq> red_rep S Y"
proof(rule ccontr)
  assume "\<not> red_rep S X \<noteq> red_rep S Y"
  then have a: "red_rep S X = red_rep S Y" by blast
  then have "X = Y" using red_rep_the assms(1,2) unfolding freegroup_def by (metis partial_object.select_convs(1))
  then have "length (red_rep S (X \<otimes>\<^bsub> F\<^bsub>S\<^esub>\<^esub> Y)) \<ge> length (red_rep S X) \<and> length (red_rep S (X \<otimes>\<^bsub> F\<^bsub>S\<^esub>\<^esub> Y)) \<ge>  length (red_rep S Y)" using assms(1) square_length by auto
  then show False using assms(3) by auto
qed

lemma SG_subgroup:
  assumes "G \<le> (freegroup S)"
  shows "group (SG (freegroup S) G)"
  unfolding SG_def using freegroup_is_group assms group.subgroup_imp_group by blast

lemma notin_union_inv:
  assumes "G \<le> (freegroup S)" "X \<notin> A" "m_inv (SG (freegroup S) G) X \<notin> A" "A \<subseteq> G"
  shows "X \<notin> union_inv A S"
proof(rule ccontr)
  assume "\<not> X \<notin> union_inv A S"
  then have "X \<in> union_inv A S"  by blast
  then have "X \<in> A \<or> X \<in> m_inv F\<^bsub>S\<^esub> ` A" unfolding union_inv_def by auto
  then have c:"X \<in> A \<or> X \<in> m_inv (SG (freegroup S) G) ` A" using inv_SG freegroup_is_group assms(1,4) by (metis (no_types, lifting) image_cong subset_eq)
  show False
  proof(cases "X \<in> A")
    case True
    then show ?thesis using assms(2) by blast
  next
    case False
    then have "X \<in> m_inv (SG (freegroup S) G) ` A" using c by blast
    then obtain y where y:"X = m_inv (SG (freegroup S) G) y \<and> y \<in> A" by blast
    moreover then have "y \<in> G" using assms(4) by auto
    moreover then have "y \<in> carrier (SG (freegroup S) G)" unfolding SG_def by simp
    ultimately have "y = m_inv (SG (freegroup S) G) X" using assms(1) by (simp add: SG_subgroup)
    then show ?thesis using y assms(3) by blast
  qed
qed

text\<open>In the following lemma, we prove that for a subgroup H of a freegroup generated by A,
   the set of reduced words of X` H A and their inverses, satisfy the N1 property.\<close>

lemma N1:
  assumes "G \<le> freegroup S"
  shows "\<forall>xs \<in> (red_rep S) ` (union_inv (X' (SG (freegroup S) G) S) S)
            . \<forall>ys \<in> (red_rep S) ` (union_inv (X' (SG (freegroup S) G) S) S). N1 xs ys"
  apply(rule ballI)+
proof-
  fix x y assume x: "x \<in> red_rep S ` union_inv (X' (SG F\<^bsub>S\<^esub> G) S) S" and  y: "y \<in> red_rep S ` union_inv (X' (SG F\<^bsub>S\<^esub> G) S) S"
  show "N1 x y"
  proof(rule ccontr)
    assume N1: "\<not> N1 x y"
    then have nxiy:"x \<noteq> wordinverse y" using N1_def by auto
    obtain x1 where x1:"red_rep S x1 = x \<and> x1 \<in> (union_inv (X' (SG (freegroup S) G) S) S)" using x by blast
    then have x1A: "x1 \<in> carrier (freegroup S)" using assms union_inv_clos by blast
    obtain y1 where y1:"red_rep S y1 = y \<and> y1 \<in> (union_inv (X' (SG (freegroup S) G) S) S)" using y by blast
    then have y1A: "y1 \<in> carrier (freegroup S)" using assms union_inv_clos by blast
    have H:"x1 \<in> G \<and> y1 \<in> G" using assms x1 x1A y1 using union_inv_sub_H by blast
    have "\<not> (length (red_rep S (x1 \<otimes>\<^bsub> F\<^bsub>S\<^esub>\<^esub> y1)) \<ge> length (red_rep S x1) \<and> length (red_rep S (x1 \<otimes>\<^bsub> F\<^bsub>S\<^esub>\<^esub> y1)) \<ge> length (red_rep S y1))" using N1 x1 y1 y1A x1A length_N1 by blast
    then have t:"length (red_rep S (x1 \<otimes>\<^bsub> F\<^bsub>S\<^esub>\<^esub> y1)) < length (red_rep S x1) \<or> length (red_rep S (x1 \<otimes>\<^bsub> F\<^bsub>S\<^esub>\<^esub> y1)) <  length (red_rep S y1)" by auto
    moreover have "(x1 \<otimes>\<^bsub> F\<^bsub>S\<^esub>\<^esub> y1) \<in> carrier (freegroup S)" using x1A y1A by (simp add: freegroup_is_group group.subgroupE(4) group.subgroup_self)
    ultimately have cases:"((x1 \<otimes>\<^bsub> F\<^bsub>S\<^esub>\<^esub> y1), x1) \<in> lex_L2_word S \<or> ((x1 \<otimes>\<^bsub> F\<^bsub>S\<^esub>\<^esub> y1), y1) \<in> lex_L2_word S" using x1A y1A length_lex by blast
    have nxy:"x \<noteq> y" using neq_N1 t x1A y1A x1 y1 by auto
    have XH: "(X' (SG F\<^bsub>S\<^esub> G) S) \<subseteq> G" unfolding X'_def SG_def by simp
    have "x1 \<notin> (union_inv (X' (SG (freegroup S) G) S) S) \<or> y1 \<notin> (union_inv (X' (SG (freegroup S) G) S) S)"
  proof(cases "((x1 \<otimes>\<^bsub>F\<^bsub>S\<^esub>\<^esub> y1), x1) \<in> lex_L2_word S")
    case True note xy_x = this
    then have subcases: "(x1,y1) \<in> lex_L2_word S \<or> (y1, x1) \<in> lex_L2_word S" using lex_total nxy nxiy x1 y1 x1A y1A  by auto
    then show ?thesis
    proof (cases "(x1,y1) \<in> lex_L2_word S")
      case True
      then have xy_y:"((x1 \<otimes>\<^bsub>F\<^bsub>S\<^esub>\<^esub> y1), y1) \<in> lex_L2_word S" using xy_x trans_lex_L2_word unfolding trans_def by blast
      then have "y1 \<notin> X' (SG (F\<^bsub>S\<^esub>) G) S" using True assms H lex_cont2 by (metis mult_SG)
      moreover have "m_inv ((SG (F\<^bsub>S\<^esub>) G)) y1 \<notin> (X' (SG (F\<^bsub>S\<^esub>) G) S)" using True xy_y H assms lex_cont2_inv by (metis mult_SG)
      ultimately have "y1 \<notin> (union_inv (X' (SG (F\<^bsub>S\<^esub>) G) S) S)" using notin_union_inv XH assms by blast
      then show ?thesis by meson
    next
      case False
      then have yx:"(y1, x1) \<in> lex_L2_word S" using subcases by auto
      then have "x1 \<notin> X' (SG (F\<^bsub>S\<^esub>) G) S" using xy_x H assms lex_cont1 by (metis mult_SG)
      moreover have "m_inv ((SG (F\<^bsub>S\<^esub>) G)) x1 \<notin> (X' (SG (F\<^bsub>S\<^esub>) G) S)" using yx xy_x H assms lex_cont1_inv by (metis mult_SG)
      ultimately have "x1 \<notin> (union_inv (X' (SG (F\<^bsub>S\<^esub>) G) S) S)" using notin_union_inv XH assms by blast
      then show ?thesis by blast
    qed
  next
    case False
    then have xyy:"((x1 \<otimes>\<^bsub>F\<^bsub>S\<^esub>\<^esub> y1), y1) \<in> lex_L2_word S" using cases by auto
    then have subcases: "(x1,y1) \<in> lex_L2_word S \<or> (y1, x1) \<in> lex_L2_word S" using lex_total nxy nxiy x1 y1 x1A y1A by auto
    then show ?thesis
    proof (cases "(x1,y1) \<in> lex_L2_word S")
      case True
      have "y1 \<notin> X' (SG (F\<^bsub>S\<^esub>) G) S" using True xyy H assms lex_cont2 by (metis mult_SG)
      moreover have "m_inv ((SG (F\<^bsub>S\<^esub>) G)) y1 \<notin> (X' (SG (F\<^bsub>S\<^esub>) G) S)" using True xyy H assms lex_cont2_inv by (metis mult_SG)
      ultimately have "y1 \<notin> (union_inv (X' (SG (F\<^bsub>S\<^esub>) G) S) S)" using notin_union_inv XH assms by blast
      then show ?thesis by meson
    next
      case False
      then have yx:"(y1, x1) \<in> lex_L2_word S" using subcases by simp
      then have xy_x: "((x1 \<otimes>\<^bsub>F\<^bsub>S\<^esub>\<^esub> y1), x1) \<in> lex_L2_word S" using xyy trans_lex_L2_word unfolding trans_def by blast
      then have "x1 \<notin> X' (SG (F\<^bsub>S\<^esub>) G) S" using yx H assms lex_cont1 by (metis mult_SG)
      moreover have "m_inv ((SG (F\<^bsub>S\<^esub>) G)) x1 \<notin> (X' (SG (F\<^bsub>S\<^esub>) G) S)" using yx xy_x H assms lex_cont1_inv by (metis mult_SG)
      ultimately have "x1 \<notin> (union_inv (X' (SG (F\<^bsub>S\<^esub>) G) S) S)" using notin_union_inv XH assms by blast
      then show ?thesis by blast
     qed
   qed
   then show False using y1 x1 by blast
 qed
qed

lemma L_inv_eq: "L(xs) = L(wordinverse xs) \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> \<not> (reduced xs)"
proof-
  assume xs: "L(xs) = L(wordinverse xs)" and rxs:"xs \<noteq> []"
  then show "\<not> (reduced xs)"
  proof-
    have "L2 xs = \<down> (L2 xs)" unfolding left_tuple_def rev_tuple.simps using xs by simp
    moreover have "length xs = length xs" by simp
    ultimately have "xs = wordinverse xs" using rev_L2_inv by force
    then show ?thesis using rxs reduced_inv_eq_imp_nil by blast
  qed
qed

lemma lex_word_init:
  "(xs, ys) \<in> lex_word \<Longrightarrow> (length us = length vs) \<Longrightarrow> (xs@us, ys@vs) \<in> lex_word"
  unfolding lex_word_def by (simp add: lenlex_append1)

lemma left_includes: "xs = a @ b \<Longrightarrow> length a \<le> length b \<Longrightarrow> \<exists>c. L xs = a @ c"
  unfolding left_subword_def by (simp add: take_append take_length)

lemma take_bigger_half:"length a \<ge> length  b \<Longrightarrow> take (((length (a@b)+1) div 2)) (a@b) = take (((length (a@b)+1) div 2)) a"
  by simp

lemma lex_word_rightappend:
  assumes "(xs,ys) \<in> lex_word"
  shows "(xs@zs, ys@zs) \<in> lex_word"
  using lex_word_def lenlex_def assms lenlex_append1 by blast

lemma L_inverse_eq:
  assumes "xs = (p @ (wordinverse a))"
          and "ys = (q @ (wordinverse a))"
          and "length p = length q"
          and "length p \<le> length (wordinverse a)"
          and "length q \<le> length (wordinverse a)"
        shows "L (wordinverse xs) = L (wordinverse ys)"
proof-
  have "wordinverse xs = a @ wordinverse p" using assms(1) by (metis FreeGroupMain.wordinverse_append FreeGroupMain.wordinverse_of_wordinverse)
  moreover have "length (wordinverse  p) \<le> length a" by (metis assms(4) length_wordinverse)
  ultimately have 1:"L (wordinverse xs) = take (((length (wordinverse xs)+1) div 2)) a" unfolding left_subword_def using take_bigger_half by auto
  have "wordinverse ys = a @ wordinverse q" using assms(2) by (metis FreeGroupMain.wordinverse_append FreeGroupMain.wordinverse_of_wordinverse)
  moreover have "length (wordinverse  q) \<le> length a" by (metis assms(5) length_wordinverse)
  ultimately have "L (wordinverse ys) = take (((length (wordinverse ys)+1) div 2)) a" unfolding left_subword_def using take_bigger_half by auto
  then show ?thesis using 1 assms(3) length_wordinverse by (metis assms(1) assms(2) length_append)
qed

lemma neq_left_neq: "p \<noteq> q \<Longrightarrow> length p = length q \<Longrightarrow> length p \<le> length r \<Longrightarrow> L (p @ r) \<noteq> L (q @ r)"
  unfolding left_subword_def by simp

lemma lex_L2_inv2:
  assumes "(ys,xs) \<in> lex_L2_word S"
  shows "(inv\<^bsub>freegroup S\<^esub> ys, xs) \<in> lex_L2_word S"
proof-
  have 1:"ys \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>))" using assms(1) unfolding lex_L2_word_def by blast
  then obtain invx where "invx = (inv\<^bsub>freegroup S\<^esub> ys)" using freegroup_is_group by simp
  then have x:"(inv\<^bsub>freegroup S\<^esub> ys) \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>))" using m_inv_def[of "freegroup S" "ys"] freegroup_def
    by (metis (no_types, lifting) freegroup_is_group group.inv_closed partial_object.select_convs(1) 1)
  have y: "xs \<in> (\<langle>S\<rangle> // (reln_tuple \<langle>S\<rangle>))" using assms(1) unfolding lex_L2_word_def by blast
  have 2:"(length (red_rep S ys) < length (red_rep S xs)) \<or> ((length (red_rep S ys) = length (red_rep S xs) \<and> (ys,xs) \<in> lex_L2_word' S))"
    using nat_less_def assms unfolding lex_L2_word_def lex_prod_def by fastforce
  then show ?thesis
  proof(cases "(length (red_rep S ys) < length (red_rep S xs))")
    case True
    then have "length (wordinverse (red_rep S ys)) < length (red_rep S xs)" using length_wordinverse by metis
    then have "length (red_rep S (inv\<^bsub>freegroup S\<^esub> ys)) < length (red_rep S xs)" using 1 red_rep_inv by metis
    then show ?thesis using x y by (simp add: lex_L2_word_def nat_less_def)
  next
    case False
    then have 3:"((length (red_rep S ys) = length (red_rep S xs) \<and> (ys,xs) \<in> lex_L2_word' S))" using 2 by blast
    then have 4:"length (red_rep S (inv\<^bsub>freegroup S\<^esub> ys)) = length (red_rep S xs)" using 1 red_rep_inv by (metis length_wordinverse)
    then have "((\<lambda>x. (min lex_word (L2 (red_rep S x)), max lex_word (L2 (red_rep S x)))) ys
                , (\<lambda>x. (min lex_word (L2 (red_rep S x)), max lex_word (L2 (red_rep S x)))) xs) \<in> (lex_word <*lex*> lex_word)" using 3 unfolding lex_L2_word'_def by fastforce
    then have 5:"((min lex_word (L2 (red_rep S ys))), (min lex_word (L2 (red_rep S xs)))) \<in> lex_word \<or>
               (min lex_word (L2 (red_rep S ys))) = (min lex_word (L2 (red_rep S xs))) \<and>
               (max lex_word (L2 (red_rep S ys)), max lex_word (L2 (red_rep S xs))) \<in> lex_word" using lex_prod_def[of "lex_word" "lex_word"] by simp
    have "L2 (wordinverse (red_rep S ys)) = (snd (L2 (red_rep S ys)), fst (L2 (red_rep S ys)))" using L2_wordinv by blast
    then have L2_winv:"min lex_word (L2 (red_rep S ys)) = min lex_word (L2 (wordinverse (red_rep S ys))) \<and>
                       max lex_word (L2 (red_rep S ys)) = max lex_word (L2 (wordinverse (red_rep S ys)))" using  wf_lex_word min.simps  by (metis (no_types, lifting) lex_word_total max.simps prod.exhaust_sel wf_asym)
    then have "((min lex_word (L2 (wordinverse(red_rep S ys)))), (min lex_word (L2 (red_rep S xs)))) \<in> lex_word \<or>
               (min lex_word (L2 (wordinverse(red_rep S ys)))) = (min lex_word (L2 (red_rep S xs))) \<and>
               (max lex_word (L2 (wordinverse(red_rep S ys))), max lex_word (L2 (red_rep S xs))) \<in> lex_word" using 5 by auto
    then have "((min lex_word (L2 (red_rep S(inv\<^bsub>freegroup S\<^esub> ys)))), (min lex_word (L2 (red_rep S xs)))) \<in> lex_word \<or>
               (min lex_word (L2 (red_rep S(inv\<^bsub>freegroup S\<^esub> ys)))) = (min lex_word (L2 (red_rep S xs))) \<and>
               (max lex_word (L2 (red_rep S(inv\<^bsub>freegroup S\<^esub> ys))), max lex_word (L2 (red_rep S xs))) \<in> lex_word" using red_rep_inv 1 by force
    then have "((inv\<^bsub>freegroup S\<^esub> ys),xs) \<in> lex_L2_word' S" unfolding lex_L2_word'_def using x y by auto
    then show ?thesis using x y 2 4 lex_L2_word_length by blast
  qed
qed

lemma three_point_six:
  assumes "X \<in> carrier (freegroup S) \<and> XY \<in> carrier (freegroup S)"
          "red_rep S X =  p@c \<and> red_rep S XY = q@c"
          "length p = length q" "length p \<le> length c" "length q \<le> length c"
          "(p,q) \<in> lex_word" "p \<noteq> q" "N0 (red_rep S X)" "N0 (red_rep S XY)"
  shows   "(X, XY) \<in> lex_L2_word S"
proof-
  let ?X = "(red_rep S X)"
  let ?XY = "(red_rep S XY)"
  have rx:"reduced ?X" using freegroup_def[of "S"] assms(1) red_rep_the[of "X" "S"] by (simp add: red_rep_def)
  have rxy:"reduced ?XY" using freegroup_def[of "S"] assms(1) red_rep_the[of "XY" "S"] by (simp add: red_rep_def)
  have "L(?X) \<noteq> L (?XY)" using assms(2,3,4,7) neq_left_neq by fastforce
  obtain r where r:"L(?X) = (p @ r)" using assms(2,4) left_includes by blast
  obtain s where s:"L(?XY) = (q @ s)" using assms(2,5) left_includes by blast
  have lxxy:"length (L(?X)) = length (L(?XY))" using assms(2,3) rx rxy unfolding left_subword_def by auto
  then have "length (p@r) = length (q@s)" using r s by simp
  moreover then have "length r = length s" using assms(3) by simp
  ultimately have "((p@r), (q@s)) \<in> lex_word" using assms(6) lex_word_def lenlex_append1 by blast
  then have L_lex:"(L(?X), L(?XY)) \<in> lex_word" using r s by simp
  have L_eq:"L(wordinverse ?X) = L(wordinverse ?XY)" using L_inverse_eq assms(2,3,5) by (metis (no_types, lifting) wordinverse_symm)
  have length:"length (?X) = length (?XY)" using assms(2,3) length_eq by simp
  show ?thesis
  proof(cases "(L(wordinverse ?X), L(?X)) \<in> lex_word")
    case True
    then have "min lex_word (L2 (wordinverse ?X)) = L(wordinverse ?X)"
      unfolding left_tuple_def min.simps by (simp add: wordinverse_of_wordinverse)
    then have min1:"min lex_word (L2 (?X)) = L(wordinverse ?X)"
      using min_L2_inv using assms(1) by fastforce
    moreover then have max1:"max lex_word (L2 (?X)) = L (?X)"
      by (metis lex_word_one True left_tuple_def max.simps)
    ultimately have "min lex_word (L2 ?XY) = L(wordinverse ?XY)"
      using L_eq L_lex transD lex_word_one trans_lex_word left_tuple_def min.simps by metis
    then have 1:"(L(wordinverse ?XY), L(?XY)) \<in> lex_word"
      unfolding left_tuple_def min.simps using L_eq L_lex True lex_word_one lex_word_total by fastforce
    then have "min lex_word (L2 (wordinverse ?XY)) = L(wordinverse ?XY)"
      unfolding left_tuple_def min.simps by (simp add: wordinverse_of_wordinverse)
    then have min2:"min lex_word (L2 (?XY)) = L(wordinverse ?XY)"
      using min_L2_inv using assms(1) by fastforce
    then have max2:"max lex_word (L2 (wordinverse ?XY)) = L(?XY)"
      by (metis FreeGroupMain.wordinverse_symm 1 left_tuple_def max.simps)
    have "X \<in> \<langle>S\<rangle> // reln_tuple \<langle>S\<rangle> \<and> XY \<in> \<langle>S\<rangle> // reln_tuple \<langle>S\<rangle>" using assms(1) freegroup_def[of "S"] by auto
    moreover have "(min lex_word (L2 (?X))) = (min lex_word (L2 (?XY)))" using min1 min2 L_eq by auto
    moreover have "((max lex_word (L2 (wordinverse (?X))), max lex_word (L2 (wordinverse (?XY))))) \<in> lex_word" using max1 max2 L_lex by (metis FreeGroupMain.wordinverse_symm True left_tuple_def max.simps)
    ultimately have "(X, XY) \<in> lex_L2_word' S" unfolding lex_L2_word'_def lex_prod_def left_tuple_def using wordinverse_symm left_tuple_def
      by (smt (z3) True lex_word_one max.simps max2 mem_Collect_eq old.prod.case)
    then show ?thesis by (simp add: \<open>X \<in> \<langle>S\<rangle> // reln_tuple \<langle>S\<rangle> \<and> XY \<in> \<langle>S\<rangle> // reln_tuple \<langle>S\<rangle>\<close> length lex_L2_word_length)
   next
    case False
    then have "(L(?X),L(wordinverse ?X)) \<in> lex_word" using L_inv_eq N0_def assms(8) lex_word_total rx by auto
    then have "min lex_word (L2 (wordinverse ?X)) = L(?X)" unfolding left_tuple_def min.simps by (simp add: False FreeGroupMain.wordinverse_of_wordinverse)
    then have min1:"min lex_word (L2 (?X)) = L(?X)" using min_L2_inv using assms(1) by fastforce
    then have max1:"max lex_word (L2 (wordinverse ?X)) = L (wordinverse ?X)" by (metis FreeGroupMain.wordinverse_symm False left_tuple_def max.simps)
    then show ?thesis
    proof(cases "(L(wordinverse ?XY), L(?XY)) \<in> lex_word")
      case True
      then have "min lex_word (L2 (wordinverse ?XY)) = L(wordinverse ?XY)" unfolding left_tuple_def min.simps by (simp add: wordinverse_of_wordinverse)
      then have min2:"min lex_word (L2 (?XY)) = L(wordinverse ?XY)" using min_L2_inv using assms(1) by fastforce
      then have max2:"max lex_word (L2 (wordinverse ?XY)) = L(?XY)" by (metis FreeGroupMain.wordinverse_symm True left_tuple_def max.simps)
      have "X \<in> \<langle>S\<rangle> // reln_tuple \<langle>S\<rangle> \<and> XY \<in> \<langle>S\<rangle> // reln_tuple \<langle>S\<rangle>" using assms(1) freegroup_def[of "S"] by auto
      moreover have "((min lex_word (L2 (red_rep S X))),(min lex_word (L2 (red_rep S XY)))) \<in> lex_word" using min1 min2 max2 L_eq using \<open>(L (red_rep S X), L (wordinverse (red_rep S X))) \<in> lex_word\<close> by auto
      ultimately have "(X, XY) \<in> lex_L2_word' S" unfolding lex_L2_word'_def lex_prod_def left_tuple_def using wordinverse_symm left_tuple_def by (smt (z3) case_prod_conv  max.simps max1 mem_Collect_eq min.simps min1)
      then show ?thesis unfolding lex_L2_word'_def using assms(1,6,7) freegroup_def length \<open>(X, XY) \<in> lex_L2_word' S\<close> lex_L2_word_length by blast
    next
      case False
      then have subcases:"(L(wordinverse ?XY) = L(?XY)) \<or> (L(?XY),(L(wordinverse ?XY))) \<in> lex_word" using lex_word_total by blast
      then show ?thesis
      proof(cases "(L(wordinverse ?XY) = L(?XY))")
        case True
        then have "reduced ?XY" using assms(1) freegroup_def red_rep_the by (metis partial_object.select_convs(1))
        then have "?XY = []" using L_inv_eq True by metis
        then have "(red_rep S XY) = []" by blast
        then show ?thesis using assms(9) N0_def by auto
      next
        case False
        then have false:"(L(?XY),(L(wordinverse ?XY))) \<in> lex_word" using subcases by simp
        then have 2:"min lex_word (L2 ?XY) = L(?XY)" unfolding left_tuple_def min.simps by (simp add: wordinverse_of_wordinverse)
        have 1:"(L ?XY, L (wordinverse ?X)) \<in> lex_word" using false L_eq by simp
        have "X \<in> \<langle>S\<rangle> // reln_tuple \<langle>S\<rangle> \<and> XY \<in> \<langle>S\<rangle> // reln_tuple \<langle>S\<rangle>" using assms(1) freegroup_def[of "S"] by auto
        moreover have "((min lex_word (L2 (red_rep S X))),(min lex_word (L2 (red_rep S XY)))) \<in> lex_word" using 1 2 false L_eq min1 using L_lex by auto
        ultimately have "(X, XY) \<in> lex_L2_word' S" unfolding lex_L2_word'_def lex_prod_def left_tuple_def using wordinverse_symm left_tuple_def by (smt (z3) case_prod_conv  max.simps max1 mem_Collect_eq min.simps min1)
        then show ?thesis
          unfolding lex_L2_word'_def using assms(1,6,7) freegroup_def length \<open>(X, XY) \<in> lex_L2_word' S\<close> lex_L2_word_length by blast
      qed
    qed
  qed
qed

lemma three_point_seven:assumes "X \<in> (carrier (freegroup S))"
          and "XY \<in> (carrier (freegroup S))"
          and "red_rep S X = (a @ (wordinverse p))"
          and "red_rep S XY = (a @ (wordinverse q))"
          and "length (wordinverse p) = length (wordinverse q)"
          and "length (wordinverse p) \<le> length a"
          and "length (wordinverse q) \<le> length a"
          and "(q, p) \<in> lex_word"
          and "p \<noteq> q"
          and "(red_rep S X) \<noteq> []"
          and "(red_rep S XY) \<noteq> []"
        shows "(XY, X) \<in> lex_L2_word S"
proof-
  let ?X = "(red_rep S (m_inv (freegroup S) X))"
  have 1:"(red_rep S (m_inv (freegroup S) X)) = wordinverse (red_rep S X)"
    using assms(1) unfolding freegroup_def
    using red_rep_inv by (metis freegroup_def partial_object.select_convs(1))
  then have x:"?X = (p @ (wordinverse a))"
    using assms(3) wordinverse_append wordinverse_of_wordinverse by metis
  let ?XY = "(red_rep S (m_inv (freegroup S) XY))"
  have 2:"(red_rep S (m_inv (freegroup S) XY)) = wordinverse (red_rep S XY)"
    using assms(2) unfolding freegroup_def using red_rep_inv
    by (metis freegroup_def partial_object.select_convs(1))
  then have xy:"?XY = (q @ (wordinverse a))"
    using assms(4) wordinverse_append wordinverse_of_wordinverse by metis
  have "L (?XY) \<noteq> L (?X)" using xy x neq_left_neq assms(5,9) assms(7) by (metis length_wordinverse)
  have pq:"length p = length q" using assms(5) by (metis length_wordinverse)
  have p:"length p \<le> length (wordinverse a)" by (metis assms(6) length_wordinverse)
  then obtain r where r:"p @ r = L (?X)" using x left_includes by metis
  have "length q \<le> length (wordinverse a)" by (metis assms(7) length_wordinverse)
  then obtain s where s:"q @ s = L (?XY)" using xy left_includes by metis
  have "length (L ?X) = length (L ?XY)" using x xy pq unfolding left_subword_def by simp
  then have "length (p @ r) = length (q @ s)" using r s by simp
  moreover then have "length r = length s" using pq by simp
  ultimately have "((q@s), (p@r)) \<in> lex_word" by (simp add: lex_word_init assms(8))
  then have L:"((L ?XY),(L ?X)) \<in> lex_word" by (simp add: r s)
  have R:"L (wordinverse ?X) = L (wordinverse ?XY)" using L_inverse_eq x xy pq assms(6) assms(7) p by fastforce
  have Xneq: "L (?X) \<noteq> L (wordinverse ?X)"
  proof(rule ccontr)
    assume "\<not> L (red_rep S (inv\<^bsub>F\<^bsub>S\<^esub>\<^esub> X)) \<noteq> L (wordinverse (red_rep S (inv\<^bsub>F\<^bsub>S\<^esub>\<^esub> X)))"
    then have "L (red_rep S (inv\<^bsub>F\<^bsub>S\<^esub>\<^esub> X)) = L (wordinverse (red_rep S (inv\<^bsub>F\<^bsub>S\<^esub>\<^esub> X)))" by blast
    moreover have "reduced ?X" unfolding red_rep_def using red_rep_the assms(1) unfolding freegroup_def
      by (metis "1" freegroup_def partial_object.select_convs(1) red_rep_def reduced_wordinverse)
    ultimately have "?X = []" using L_inv_eq by blast
    then have "(red_rep S X) = []" by (metis "1" FreeGroupMain.wordinverse_symm wordinverse.simps(1))
    then show False using assms(10) by blast
  qed
  have XYneq: "L (?XY) \<noteq> L (wordinverse ?XY)"
  proof(rule ccontr)
    assume "\<not> L (red_rep S (inv\<^bsub>F\<^bsub>S\<^esub>\<^esub> XY)) \<noteq> L (wordinverse (red_rep S (inv\<^bsub>F\<^bsub>S\<^esub>\<^esub> XY)))"
    then have "L (red_rep S (inv\<^bsub>F\<^bsub>S\<^esub>\<^esub> XY)) = L (wordinverse (red_rep S (inv\<^bsub>F\<^bsub>S\<^esub>\<^esub> XY)))" by blast
    moreover have "reduced ?XY" unfolding red_rep_def using red_rep_the assms(2) unfolding freegroup_def by (metis "2" freegroup_def partial_object.select_convs(1) red_rep_def reduced_wordinverse)
    ultimately have "?XY = []" using L_inv_eq by blast
    then have "(red_rep S XY) = []" by (metis "2" FreeGroupMain.wordinverse_symm wordinverse.simps(1))
    then show False using assms(11) by blast
  qed
  have xyin:"(inv\<^bsub>F\<^bsub>S\<^esub>\<^esub> XY) \<in> \<langle>S\<rangle> // reln_tuple \<langle>S\<rangle>" using assms(2) freegroup_is_group
    unfolding freegroup_def using group.inv_closed by fastforce
  have xin: "(inv\<^bsub>F\<^bsub>S\<^esub>\<^esub> X) \<in> \<langle>S\<rangle> // reln_tuple \<langle>S\<rangle>" using assms(1) freegroup_is_group
    unfolding freegroup_def using group.inv_closed by fastforce
  have "length ?XY = length ?X" using x xy pq by simp
  then have "((m_inv (freegroup S) XY, m_inv (freegroup S) X) \<in> lex_L2_word S) = ((m_inv (freegroup S) XY, m_inv (freegroup S) X) \<in> lex_L2_word' S)" using lex_L2_word_def lex_L2_word_length mem_Collect_eq xin xyin
    by blast
  moreover have "((m_inv (freegroup S) XY, m_inv (freegroup S) X) \<in> lex_L2_word' S)"
  proof(cases "(L (?XY), L (wordinverse ?XY)) \<in> lex_word")
    case True note first = this
    then have 1:"(min lex_word (L2 ?XY)) = L (?XY)" unfolding left_tuple_def min.simps by simp
    then show ?thesis
    proof(cases "(L (?X), L (wordinverse ?X)) \<in> lex_word")
      case True
      then have "(min lex_word (L2 ?X)) = L ((?X))" unfolding left_tuple_def min.simps by simp
      then have "((min lex_word (L2 ?XY)), min lex_word (L2 ?X)) \<in> lex_word" using L 1 by fastforce
      then show ?thesis unfolding lex_L2_word'_def lex_prod_def using xin xyin by fast
    next
      case False
      then have "(min lex_word (L2 ?X)) = L (wordinverse ?X)" unfolding left_tuple_def min.simps by simp
      moreover have "(L ?XY, L (wordinverse ?X)) \<in> lex_word" using R first by simp
      ultimately have "((min lex_word (L2 ?XY)), min lex_word (L2 ?X)) \<in> lex_word" using R 1 by fastforce
      then show ?thesis unfolding lex_L2_word'_def lex_prod_def using xin xyin by fast
    qed
  next
    case False
    then have 1: "(L (wordinverse ?XY),L ?XY) \<in> lex_word" using XYneq lex_word_total by auto
    have A:"(min lex_word (L2 ?XY)) = L (wordinverse ?XY)" unfolding left_tuple_def min.simps using False by simp
    have 2:"(L (wordinverse ?X),L (?X)) \<in> lex_word" using 1 L R trans_lex_word transD by fastforce
    then have "(min lex_word (L2 ?X)) = L (wordinverse ?X)" unfolding left_tuple_def min.simps
      using lex_word_one by auto
    then have min:"(min lex_word (L2 ?X)) = (min lex_word (L2 ?XY))" using A R by simp
    have "max lex_word (L2 ?XY) = L (?XY)" by (simp add: False left_tuple_def)
    moreover have "max lex_word (L2 ?X) = L (?X)" using 2 lex_word_one
      unfolding left_tuple_def max.simps by force
    ultimately have "((max lex_word (L2 ?XY)), max lex_word (L2 ?X)) \<in> lex_word" using L by simp
    then show ?thesis unfolding lex_L2_word'_def lex_prod_def using xin xyin min by auto
  qed
  ultimately have "((m_inv (freegroup S) XY, m_inv (freegroup S) X) \<in> lex_L2_word S)" by simp
  then have "(m_inv (freegroup S) (m_inv (freegroup S) XY), m_inv (freegroup S) X) \<in> lex_L2_word S" by (simp add: lex_L2_inv2)
  then have "(m_inv (freegroup S) (m_inv (freegroup S) XY), m_inv (freegroup S) (m_inv (freegroup S) X)) \<in> lex_L2_word S" by (simp add: lex_L2_inv)
  then show ?thesis using assms(1,2) by (simp add: freegroup_is_group)
qed

text\<open>If H is a subgroup of the freegroup generated by A, the set of reduced words of X H A,
and their inverses, satisfy the N0 property. Following lemma asserts this fact.\<close>
lemma N0:
  assumes "G \<le> freegroup S"
  shows "\<forall>xs \<in> (red_rep S) ` (union_inv (X' (SG (freegroup S) G) S) S). N0 xs"
proof
  fix x assume x:"x \<in> red_rep S ` union_inv (X' (SG F\<^bsub>S\<^esub> G) S) S"
  show "N0 x"
  proof(rule ccontr)
    assume "\<not> N0 x"
    then have "x = []" unfolding N0_def by simp
    moreover obtain x1 where x1:"red_rep S x1 = x \<and> x1 \<in> (union_inv (X' (SG (freegroup S) G) S) S)" using x by blast
    moreover then have xin:"x1 \<in> carrier(freegroup S)" using assms assms union_inv_clos by blast
    ultimately have 1:"x1 = \<one>\<^bsub>freegroup S\<^esub>" unfolding red_rep_def freegroup_def using red_rep_the x1 by force
    then have "x1 \<in> (X' (SG (freegroup S) G) S) "
    proof(cases "x1 \<in> (X' (SG (freegroup S) G) S)")
      case True
      then show ?thesis  by simp
    next
      case False
      then have "x1 \<in> m_inv (freegroup S) ` (X' (SG (freegroup S) G) S)" using x1 unfolding union_inv_def  by simp
      then obtain x2 where x2:"m_inv (freegroup S) x2 = x1 \<and> x2 \<in> (X' (SG (freegroup S) G) S)" by blast
      moreover then have "x2 \<in> carrier(freegroup S)"  using assms union_inv_clos union_inv_def by fastforce
      ultimately have "m_inv (freegroup S) x1 = x2" using freegroup_is_group group.inv_inv  by fast
      then have "x2 = \<one>\<^bsub>freegroup S\<^esub>" using 1 freegroup_is_group by (metis group.inv_eq_1_iff xin)
      then show ?thesis using x2 1 by simp
    qed
    moreover have "\<one>\<^bsub>freegroup S\<^esub> \<in> G' (SG (freegroup S) G) S (\<one>\<^bsub>freegroup S\<^esub>)" unfolding G'_def by (metis (no_types, lifting) gen_span.simps one_SG)
    ultimately show False  unfolding X'_def using 1 by blast
  qed
qed

lemma cancel_p2_q3:
  assumes "reduced xs"
      and "reduced ys"
      and "reduced zs"
      and "N1 xs ys"
      and "N1 ys zs"
      and "xs \<noteq> wordinverse ys"
      and "ys \<noteq> wordinverse zs"
    shows "p2 (cancel2 ys zs) = q3 (cancel3 xs ys zs)"
proof-
  have 1:"xs = a3 (cancel3 xs ys zs) @  (p3 (cancel3 xs ys zs)) \<and> ys = wordinverse  (p3 (cancel3 xs ys zs)) @ b3 (cancel3 xs ys zs) @ (q3 (cancel3 xs ys zs)) \<and> zs = (wordinverse  (q3 (cancel3 xs ys zs))) @ (c3 (cancel3 xs ys zs)) \<and> reduced (a3 (cancel3 xs ys zs) @ b3 (cancel3 xs ys zs) @ q3 (cancel3 xs ys zs)) \<and> reduced (wordinverse  (p3 (cancel3 xs ys zs)) @ b3 (cancel3 xs ys zs) @ c3 (cancel3 xs ys zs))" using assms cancel3_the by blast
  have 2:"ys = (a2 (cancel2 ys zs)) @ (p2 (cancel2 ys zs)) \<and> zs = (wordinverse (p2 (cancel2 ys zs))) @ (b2 (cancel2 ys zs)) \<and> reduced ((a2 (cancel2 ys zs)) @ (b2 (cancel2 ys zs)))" using assms(2,3) by (simp add: cancel2_the)
  define w2 where 3:"w2 = ((wordinverse  (p3 (cancel3 xs ys zs)) @ b3 (cancel3 xs ys zs)), (q3 (cancel3 xs ys zs)), (c3 (cancel3 xs ys zs)))"
  then have "ys = (a2 w2) @ (p2 w2) \<and> zs = (wordinverse (p2 w2)) @ (b2 w2) \<and> reduced ((a2 w2) @ (b2 w2))" using 1 by auto
  then have "w2 = (cancel2 ys zs)" using 2 assms(2,3) cancel2E' by blast
  then have "p2 w2 = p2 (cancel2 ys zs)" by simp
  then show ?thesis using 3 by simp
qed

lemma cancel_b2_c3:
  assumes "reduced xs"
      and "reduced ys"
      and "reduced zs"
      and "N1 xs ys"
      and "N1 ys zs"
      and "xs \<noteq> wordinverse ys"
      and "ys \<noteq> wordinverse zs"
    shows "b2 (cancel2 ys zs) = c3 (cancel3 xs ys zs)"
proof-
  have 1:"xs = a3 (cancel3 xs ys zs) @  (p3 (cancel3 xs ys zs)) \<and> ys = wordinverse  (p3 (cancel3 xs ys zs)) @ b3 (cancel3 xs ys zs) @ (q3 (cancel3 xs ys zs)) \<and> zs = (wordinverse  (q3 (cancel3 xs ys zs))) @ (c3 (cancel3 xs ys zs)) \<and> reduced (a3 (cancel3 xs ys zs) @ b3 (cancel3 xs ys zs) @ q3 (cancel3 xs ys zs)) \<and> reduced (wordinverse  (p3 (cancel3 xs ys zs)) @ b3 (cancel3 xs ys zs) @ c3 (cancel3 xs ys zs))" using assms cancel3_the by blast
  have 2:"ys = (a2 (cancel2 ys zs)) @ (p2 (cancel2 ys zs)) \<and> zs = (wordinverse (p2 (cancel2 ys zs))) @ (b2 (cancel2 ys zs)) \<and> reduced ((a2 (cancel2 ys zs)) @ (b2 (cancel2 ys zs)))" using assms(2,3) by (simp add: cancel2_the)
  define w2 where 3:"w2 = ((wordinverse  (p3 (cancel3 xs ys zs)) @ b3 (cancel3 xs ys zs)), (q3 (cancel3 xs ys zs)), (c3 (cancel3 xs ys zs)))"
  then have "ys = (a2 w2) @ (p2 w2) \<and> zs = (wordinverse (p2 w2)) @ (b2 w2) \<and> reduced ((a2 w2) @ (b2 w2))" using 1 by auto
  then have "w2 = (cancel2 ys zs)" using 2 assms(2,3) cancel2E' by blast
  then have "b2 w2 = b2 (cancel2 ys zs)" by simp
  then show ?thesis using 3 by simp
qed

lemma cancel_b2_bq3:
  assumes "reduced xs"
      and "reduced ys"
      and "reduced zs"
      and "N1 xs ys"
      and "N1 ys zs"
      and "xs \<noteq> wordinverse ys"
      and "ys \<noteq> wordinverse zs"
    shows "b2 (cancel2 xs ys) =  (b3 (cancel3 xs ys zs)) @ q3 (cancel3 xs ys zs)"
proof-
  have 1:"xs = a3 (cancel3 xs ys zs) @  (p3 (cancel3 xs ys zs)) \<and> ys = wordinverse  (p3 (cancel3 xs ys zs)) @ b3 (cancel3 xs ys zs) @ (q3 (cancel3 xs ys zs)) \<and> zs = (wordinverse  (q3 (cancel3 xs ys zs))) @ (c3 (cancel3 xs ys zs)) \<and> reduced (a3 (cancel3 xs ys zs) @ b3 (cancel3 xs ys zs) @ q3 (cancel3 xs ys zs)) \<and> reduced (wordinverse  (p3 (cancel3 xs ys zs)) @ b3 (cancel3 xs ys zs) @ c3 (cancel3 xs ys zs))" using assms cancel3_the by blast
  have 2:"ys = (a2 (cancel2 ys zs)) @ (p2 (cancel2 ys zs)) \<and> zs = (wordinverse (p2 (cancel2 ys zs))) @ (b2 (cancel2 ys zs)) \<and> reduced ((a2 (cancel2 ys zs)) @ (b2 (cancel2 ys zs)))" using assms(2,3) by (simp add: cancel2_the)
  define w2 where 3:"w2 = ((a3 (cancel3 xs ys zs)), ((p3 (cancel3 xs ys zs))), b3 (cancel3 xs ys zs)@ (q3 (cancel3 xs ys zs)))"
  then have "ys = (wordinverse (p2 w2)) @ (b2 w2) \<and> xs = ((a2 w2)) @ (p2 w2) \<and> reduced ((a2 w2) @ (b2 w2))" using 1 by auto
  then have "w2 = (cancel2 xs ys)" using 2 3 assms(1,2,3) cancel2E' cancel2_the[of "xs" "ys"] by blast
  then have "b2 w2 = b2 (cancel2 xs ys)" by simp
  then show ?thesis using 3 by simp
qed

lemma cancel_p2_p3:
  assumes "reduced xs"
      and "reduced ys"
      and "reduced zs"
      and "N1 xs ys"
      and "N1 ys zs"
      and "xs \<noteq> wordinverse ys"
      and "ys \<noteq> wordinverse zs"
    shows "p2 (cancel2 xs ys) = p3 (cancel3 xs ys zs)"
proof-
  have "xs = a3 (cancel3 xs ys zs) @  (p3 (cancel3 xs ys zs))" using assms cancel3_the by blast
  moreover have "xs = (a2 (cancel2 xs ys)) @ (p2 (cancel2 xs ys))" using assms(1,2) by (simp add: cancel2_the)
  ultimately show ?thesis using cancel_a2_a3 assms by (metis same_append_eq)
qed

lemma neq_imp_invneq: "p \<noteq> q \<Longrightarrow> wordinverse p \<noteq> wordinverse q"
  by (metis FreeGroupMain.wordinverse_symm)

lemma reln_eq_image:
  assumes "xs \<in> \<langle>S\<rangle> \<and> ys \<in> \<langle>S\<rangle> \<and> xs ~ ys"
  shows "((reln_tuple \<langle>S\<rangle>) `` {xs}) = ((reln_tuple \<langle>S\<rangle>) `` {ys})" using assms reln_tuple_def[of "\<langle>S\<rangle>"] equiv_class_eq reln_equiv by fastforce

lemma red_repI: assumes "X \<in> \<langle>S\<rangle> // reln_tuple \<langle>S\<rangle>"
              "X = reln_tuple \<langle>S\<rangle> `` {xs}"
              "reduced xs"
            shows "red_rep S X = xs"
proof-
  have "xs \<in> X"
    by (metis Image_singleton_iff assms(1) assms(2) equiv_class_eq_iff red_rep_the reln_equiv)
  then have "xs \<in> X \<and> reduced xs \<and> X = reln_tuple \<langle>S\<rangle> `` {xs}" using assms by auto
  then show ?thesis using assms(1) red_rep_the[of "X" "S"] unfolding red_rep_def using redelem_unique by fastforce
qed

text\<open>If H is a subgroup of the freegroup generated by A, the set of reduced words of
X` H A, and their inverses, satisfy the N2 property, and thus as a consequence of
the previous results N0 and N1, all the three N-properties. This is proved in the
lemma N2 stated below.\<close>

lemma N2:
 assumes "G \<le> freegroup S"
     and "\<forall>xs \<in> (red_rep S) ` (union_inv (X' (SG (freegroup S) G) S) S). N0 xs"
     and "\<forall>xs \<in> (red_rep S) ` (union_inv (X' (SG (freegroup S) G) S) S).
             \<forall>ys \<in> (red_rep S) ` (union_inv (X' (SG (freegroup S) G) S) S). N1 xs ys"
   shows "\<forall>xs \<in> (red_rep S) ` (union_inv (X' (SG (freegroup S) G) S) S).
            \<forall>ys \<in> (red_rep S) ` (union_inv (X' (SG (freegroup S) G) S) S).
            \<forall>zs \<in> (red_rep S) ` (union_inv (X' (SG (freegroup S) G) S) S). N2 xs ys zs"
  apply(rule ballI)+
proof-
  fix x y z
  assume
       x: "x \<in> red_rep S ` union_inv (X' (SG F\<^bsub>S\<^esub> G) S) S"
   and y: "y \<in> red_rep S ` union_inv (X' (SG F\<^bsub>S\<^esub> G) S) S"
   and z: "z \<in> red_rep S ` union_inv (X' (SG F\<^bsub>S\<^esub> G) S) S"
  show "N2 x y z"
  proof(rule ccontr)
    assume N2: "\<not> N2 x y z"
    then have invxyz:"x \<noteq> wordinverse y \<and> y \<noteq> wordinverse z" using N2_def by auto
    obtain x1 where x1:"red_rep S x1 = x \<and> x1 \<in> (union_inv (X' (SG (freegroup S) G) S) S)" using x by blast
    moreover then have x1A: "x1 \<in> carrier (freegroup S)" using assms union_inv_clos by blast
    ultimately have rx:"reduced x" using red_rep_the unfolding red_rep_def freegroup_def by auto
    have xA: "x \<in> \<langle>S\<rangle>"  using redrep_in x1 x1A by fastforce
    obtain y1 where y1:"red_rep S y1 = y \<and> y1 \<in> (union_inv (X' (SG (freegroup S) G) S) S)" using y by blast
    moreover then have y1A: "y1 \<in> carrier (freegroup S)" using assms union_inv_clos by blast
    ultimately have ry:"reduced y" using red_rep_the unfolding red_rep_def freegroup_def by auto
    have yA: "y \<in> \<langle>S\<rangle>"  using redrep_in y1 y1A by fastforce
    obtain z1 where z1:"red_rep S z1 = z \<and> z1 \<in> (union_inv (X' (SG (freegroup S) G) S) S)" using z by blast
    moreover then have z1A: "z1 \<in> carrier (freegroup S)" using assms union_inv_clos by blast
    ultimately have rz:"reduced z" using red_rep_the unfolding red_rep_def freegroup_def by auto
    have zA: "z \<in> \<langle>S\<rangle>"  using redrep_in z1 z1A by fastforce
    have H:"x1 \<in> G \<and> y1 \<in> G \<and> z1 \<in> G" using assms x1 x1A y1 z1 z1A using union_inv_sub_H by blast
    have b:"(b3 (\<oslash>\<^bsub>3\<^esub> x y z) = [])" using N2 unfolding N2_def by fastforce
    then have xyz:"x = a3 (\<oslash>\<^bsub>3\<^esub> x y z) @ p3 (\<oslash>\<^bsub>3\<^esub> x y z) \<and>
           y = wordinverse (p3 (\<oslash>\<^bsub>3\<^esub> x y z)) @ q3 (\<oslash>\<^bsub>3\<^esub> x y z) \<and>
           z = wordinverse (q3 (\<oslash>\<^bsub>3\<^esub> x y z)) @ c3 (\<oslash>\<^bsub>3\<^esub> x y z) \<and>
           reduced (a3 (\<oslash>\<^bsub>3\<^esub> x y z) @ q3 (\<oslash>\<^bsub>3\<^esub> x y z)) \<and>
           reduced (wordinverse (p3 (\<oslash>\<^bsub>3\<^esub> x y z)) @ c3 (\<oslash>\<^bsub>3\<^esub> x y z))" using assms(3) rx ry rz x y z cancel3_the invxyz by (metis append.left_neutral)
    then have neq:"(p3 (\<oslash>\<^bsub>3\<^esub> x y z)) \<noteq> q3 (\<oslash>\<^bsub>3\<^esub> x y z)" using y assms(2) ry by (metis FreeGroupMain.inverse_wordinverse N0_def reduced.simps(1) reduced_reln_eq)
    have pa:"length (p3 (\<oslash>\<^bsub>3\<^esub> x y z)) \<le> length (a3 (\<oslash>\<^bsub>3\<^esub> x y z))" using assms(3) xyz rx ry rz x y z invxyz cancel2_the cancel_a2_a3 unfolding N1_def by (metis (no_types, lifting)  same_append_eq)
    have "length (p2 (y \<oslash>\<^bsub>2\<^esub> z)) \<le> length (b2 (y \<oslash>\<^bsub>2\<^esub> z))" using assms(3) ry rz y z xyz invxyz cancel2_the N1_def by blast
    then have qc: "length (q3 (\<oslash>\<^bsub>3\<^esub> x y z)) \<le> length (c3 (\<oslash>\<^bsub>3\<^esub> x y z))" using assms(3) xyz rx ry rz x y z invxyz cancel_b2_c3 cancel_p2_q3 by (metis (no_types, lifting))
    have "length (p2 (x \<oslash>\<^bsub>2\<^esub> y)) \<le> length (b2 (x \<oslash>\<^bsub>2\<^esub> y))"  using assms(3) rx ry x y xyz invxyz cancel2_the N1_def by blast
    then have pq: "length (p3 (\<oslash>\<^bsub>3\<^esub> x y z)) \<le> length (q3 (\<oslash>\<^bsub>3\<^esub> x y z))" using assms(3) xyz rx ry rz x y z invxyz cancel_b2_bq3 cancel_p2_p3 b by (metis append.left_neutral)
    have "length (p2 (y \<oslash>\<^bsub>2\<^esub> z)) \<le> length (b2 (y \<oslash>\<^bsub>2\<^esub> z))"  using assms(3) ry rz y z xyz invxyz cancel2_the N1_def by blast
    then have qp: "length (q3 (\<oslash>\<^bsub>3\<^esub> x y z)) \<le> length (p3 (\<oslash>\<^bsub>3\<^esub> x y z))" using assms(3) xyz rx ry rz x y z invxyz cancel_p2_q3 b by (metis N1_def append_Nil2 cancel_a2_pb3 length_wordinverse)
    then have leq:"length (q3 (\<oslash>\<^bsub>3\<^esub> x y z)) = length (p3 (\<oslash>\<^bsub>3\<^esub> x y z))" using pq by simp
    then have pc: "length (p3 (\<oslash>\<^bsub>3\<^esub> x y z)) \<le> length (c3 (\<oslash>\<^bsub>3\<^esub> x y z))" using qc by simp
    have qa: "length (q3 (\<oslash>\<^bsub>3\<^esub> x y z)) \<le> length (a3 (\<oslash>\<^bsub>3\<^esub> x y z))" using pa leq by simp
    have xneqy: "x \<noteq> y" using xyz neq by (metis append_eq_append_conv leq)
    have yneqz: "y \<noteq> z" using xyz neq leq neq_imp_invneq by (metis append_eq_conv_conj length_wordinverse)
    have x1y1in:"x1 \<otimes>\<^bsub>freegroup S\<^esub> y1 \<in> carrier (freegroup S)" by (meson H assms(1) subgroup.m_closed subgroup.mem_carrier)
    have "(a3 (\<oslash>\<^bsub>3\<^esub> x y z) @ p3 (\<oslash>\<^bsub>3\<^esub> x y z) @ wordinverse (p3 (\<oslash>\<^bsub>3\<^esub> x y z)) @ q3 (\<oslash>\<^bsub>3\<^esub> x y z)) ~ (a3 (\<oslash>\<^bsub>3\<^esub> x y z) @ q3 (\<oslash>\<^bsub>3\<^esub> x y z)) \<and> x1 \<otimes>\<^bsub>freegroup S\<^esub> y1 = reln_tuple \<langle>S\<rangle> `` {a3 (\<oslash>\<^bsub>3\<^esub> x y z) @ p3 (\<oslash>\<^bsub>3\<^esub> x y z) @ wordinverse (p3 (\<oslash>\<^bsub>3\<^esub> x y z)) @ q3 (\<oslash>\<^bsub>3\<^esub> x y z)}"
      unfolding freegroup_def by (metis (no_types, lifting) append_assoc cancel2_reln freegroup_def monoid.select_convs(1) partial_object.select_convs(1) proj_append_wd red_rep_the redrep_in x1 x1A xyz y1 y1A)
    moreover have "(a3 (\<oslash>\<^bsub>3\<^esub> x y z) @ p3 (\<oslash>\<^bsub>3\<^esub> x y z) @ wordinverse (p3 (\<oslash>\<^bsub>3\<^esub> x y z)) @ q3 (\<oslash>\<^bsub>3\<^esub> x y z)) \<in> \<langle>S\<rangle>"
    proof-
      have "x @ y \<in> \<langle>S\<rangle>" using xA yA unfolding freewords_on_def by (simp add: span_append)
      moreover have "x = a3 (\<oslash>\<^bsub>3\<^esub> x y z) @ p3 (\<oslash>\<^bsub>3\<^esub> x y z) \<and> y = wordinverse (p3 (\<oslash>\<^bsub>3\<^esub> x y z)) @ q3 (\<oslash>\<^bsub>3\<^esub> x y z)" using xyz by blast
      ultimately show ?thesis by (metis append.assoc)
    qed
    moreover have "(a3 (\<oslash>\<^bsub>3\<^esub> x y z) @ q3 (\<oslash>\<^bsub>3\<^esub> x y z)) \<in> \<langle>S\<rangle>"
    proof-
      have 1:"x = a3 (\<oslash>\<^bsub>3\<^esub> x y z) @ p3 (\<oslash>\<^bsub>3\<^esub> x y z) \<and> y = wordinverse (p3 (\<oslash>\<^bsub>3\<^esub> x y z)) @ q3 (\<oslash>\<^bsub>3\<^esub> x y z)" using xyz by blast
      then have "a3 (\<oslash>\<^bsub>3\<^esub> x y z) \<in> \<langle>S\<rangle>" unfolding freewords_on_def by (metis freewords_on_def leftappend_span xA)
      moreover have "q3 (\<oslash>\<^bsub>3\<^esub> x y z) \<in> \<langle>S\<rangle>" unfolding freewords_on_def by (metis freewords_on_def rightappend_span 1 yA)
      ultimately show ?thesis unfolding freewords_on_def by (simp add: span_append)
    qed
    ultimately have "x1 \<otimes>\<^bsub>freegroup S\<^esub> y1 = reln_tuple \<langle>S\<rangle> `` {a3 (\<oslash>\<^bsub>3\<^esub> x y z)  @ q3 (\<oslash>\<^bsub>3\<^esub> x y z)}"  by (simp add: reln_eq_image)
    then have x1y1:"red_rep S (x1 \<otimes>\<^bsub>freegroup S\<^esub> y1) = (a3 (\<oslash>\<^bsub>3\<^esub> x y z) @ q3 (\<oslash>\<^bsub>3\<^esub> x y z))" using x1y1in unfolding freegroup_def using red_repI xyz by auto
    have y1z1in:"y1 \<otimes>\<^bsub>freegroup S\<^esub> z1 \<in> carrier (freegroup S)" by (meson H assms(1) subgroup.m_closed subgroup.mem_carrier)
    moreover have "(wordinverse (p3 (\<oslash>\<^bsub>3\<^esub> x y z)) @ q3 (\<oslash>\<^bsub>3\<^esub> x y z) @ wordinverse (q3 (\<oslash>\<^bsub>3\<^esub> x y z)) @ c3 (\<oslash>\<^bsub>3\<^esub> x y z))  ~ (wordinverse (p3 (\<oslash>\<^bsub>3\<^esub> x y z)) @ c3 (\<oslash>\<^bsub>3\<^esub> x y z)) \<and> y1 \<otimes>\<^bsub>freegroup S\<^esub> z1 = reln_tuple \<langle>S\<rangle> `` {(wordinverse (p3 (\<oslash>\<^bsub>3\<^esub> x y z)) @ q3 (\<oslash>\<^bsub>3\<^esub> x y z) @ wordinverse (q3 (\<oslash>\<^bsub>3\<^esub> x y z)) @ c3 (\<oslash>\<^bsub>3\<^esub> x y z))}"
      unfolding freegroup_def
      by (metis append_assoc cancel2_reln freegroup_def monoid.select_convs(1) partial_object.select_convs(1) proj_append_wd red_rep_the redrep_in xyz y1 y1A z1 z1A)
    moreover have "(wordinverse (p3 (\<oslash>\<^bsub>3\<^esub> x y z)) @ q3 (\<oslash>\<^bsub>3\<^esub> x y z) @ wordinverse (q3 (\<oslash>\<^bsub>3\<^esub> x y z)) @ c3 (\<oslash>\<^bsub>3\<^esub> x y z)) \<in> \<langle>S\<rangle> \<and> (wordinverse (p3 (\<oslash>\<^bsub>3\<^esub> x y z)) @ c3 (\<oslash>\<^bsub>3\<^esub> x y z)) \<in> \<langle>S\<rangle>" using xyz xA yA unfolding freewords_on_def by (metis freewords_on_def rightappend_span span_append span_wordinverse zA)
    ultimately have "y1 \<otimes>\<^bsub>freegroup S\<^esub> z1 = reln_tuple \<langle>S\<rangle> `` {(wordinverse (p3 (\<oslash>\<^bsub>3\<^esub> x y z)) @ c3 (\<oslash>\<^bsub>3\<^esub> x y z))}" by (simp add: reln_eq_image)
    then have y1z1:"red_rep S (y1 \<otimes>\<^bsub>freegroup S\<^esub> z1) = (wordinverse (p3 (\<oslash>\<^bsub>3\<^esub> x y z)) @ c3 (\<oslash>\<^bsub>3\<^esub> x y z))" using y1z1in unfolding freegroup_def using red_repI xyz  by auto
    have ineq:"wordinverse (p3 (\<oslash>\<^bsub>3\<^esub> x y z)) \<noteq> wordinverse (q3 (\<oslash>\<^bsub>3\<^esub> x y z))" by (simp add: neq neq_imp_invneq)
    then have cases:"(wordinverse (p3 (\<oslash>\<^bsub>3\<^esub> x y z)), wordinverse (q3 (\<oslash>\<^bsub>3\<^esub> x y z))) \<in> lex_word \<or> (wordinverse (q3 (\<oslash>\<^bsub>3\<^esub> x y z)), wordinverse ( p3 (\<oslash>\<^bsub>3\<^esub> x y z))) \<in> lex_word" unfolding lex_word_def using lex_word_def lex_word_total by auto
    show False
    proof(cases "(wordinverse (p3 (\<oslash>\<^bsub>3\<^esub> x y z)), wordinverse (q3 (\<oslash>\<^bsub>3\<^esub> x y z))) \<in> lex_word")
      case True
      let ?p = "wordinverse (p3 (\<oslash>\<^bsub>3\<^esub> x y z))"
      let ?q = "wordinverse (q3 (\<oslash>\<^bsub>3\<^esub> x y z))"
      let ?c = "c3 (\<oslash>\<^bsub>3\<^esub> x y z)"
      have "red_rep S z1 = ?q @ ?c"  using xyz z1 by force
      moreover have "red_rep S (y1 \<otimes>\<^bsub>freegroup S\<^esub> z1) = ?p @ ?c" by (simp add: y1z1)
      moreover have "length ?p = length ?q" using leq by (metis length_wordinverse)
      moreover have "?p \<noteq> ?q" using ineq .
      moreover have "length ?p \<le> length ?c" by (metis length_wordinverse pc)
      moreover have "length ?q \<le> length ?c" by (metis length_wordinverse qc)
      moreover have "red_rep S (y1 \<otimes>\<^bsub>freegroup S\<^esub> z1) \<noteq> []" using y1z1 FreeGroupMain.wordinverse_symm invxyz xyz by fastforce
      moreover have "red_rep S z1 \<noteq> []" using N0_def assms(2) z1 by auto
      ultimately have cont:"((y1 \<otimes>\<^bsub>freegroup S\<^esub> z1), z1) \<in> lex_L2_word S" using True z1A y1z1in xyz z three_point_six[of "z1" "A" "(y1 \<otimes>\<^bsub>freegroup A\<^esub> z1)" "?p" "?c" "?q"] by (metis N0_def three_point_six)
      have subcases:"(y1, z1) \<in> lex_L2_word S \<or> (z1, y1) \<in> lex_L2_word S" by (simp add: invxyz lex_total y1 y1A yneqz z1 z1A)
      then show ?thesis
      proof(cases "(y1, z1) \<in> lex_L2_word S")
        case True
        then have "z1 \<notin> X' (SG (F\<^bsub>S\<^esub>) G) S" using lex_cont2[of "y1" "z1" "S" "G"] H assms(1) cont by (metis mult_SG)
        moreover have "inv\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> z1 \<notin> X' (SG (F\<^bsub>S\<^esub>) G) S"  using lex_cont2_inv[of "y1" "z1" "S" "G"] H assms(1) cont True by (metis mult_SG)
        moreover have "X' (SG (F\<^bsub>S\<^esub>) G) S \<subseteq> G"  unfolding X'_def SG_def by simp
        ultimately have "z1 \<notin> (union_inv (X' (SG (freegroup S) G) S) S)" using notin_union_inv[of "G" "S" "z1" "X' (SG F\<^bsub>S\<^esub> G) S"] assms(1) by simp
        then show ?thesis using z1 by blast
      next
        case False
        then have F:"(z1, y1) \<in> lex_L2_word S" using subcases by blast
        moreover then have trans:"(y1 \<otimes>\<^bsub>F\<^bsub>S\<^esub>\<^esub> z1, y1) \<in> lex_L2_word S" using cont trans_lex_L2_word transD by fast
        ultimately have "y1 \<notin> X' (SG (F\<^bsub>S\<^esub>) G) S" using lex_cont1[of "z1" "y1"  "S" "G"] H assms(1) cont by (metis mult_SG)
        moreover have "inv\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> y1 \<notin> X' (SG (F\<^bsub>S\<^esub>) G) S"  using lex_cont1_inv[of "z1" "y1" "S" "G"] H assms(1) cont F trans by (metis mult_SG)
        moreover have "X' (SG (F\<^bsub>S\<^esub>) G) S \<subseteq> G"  unfolding X'_def SG_def by simp
        ultimately have "y1 \<notin> (union_inv (X' (SG (freegroup S) G) S) S)" using notin_union_inv[of "G" "S" "y1" "X' (SG F\<^bsub>S\<^esub> G) S"] assms(1) by simp
        then show ?thesis using y1 by blast
      qed
    next
      case False
      then have F:"(wordinverse (q3 (\<oslash>\<^bsub>3\<^esub> x y z)), wordinverse ( p3 (\<oslash>\<^bsub>3\<^esub> x y z))) \<in> lex_word" using cases by simp
      let ?p = "wordinverse (p3 (\<oslash>\<^bsub>3\<^esub> x y z))"
      let ?q = "wordinverse (q3 (\<oslash>\<^bsub>3\<^esub> x y z))"
      let ?a = "a3 (\<oslash>\<^bsub>3\<^esub> x y z)"
      have "red_rep S x1 = ?a @ wordinverse ?p" using xyz x1  by (metis FreeGroupMain.wordinverse_of_wordinverse)
      moreover have "red_rep S (x1 \<otimes>\<^bsub>freegroup S\<^esub> y1) = ?a @ wordinverse ?q" using x1y1 FreeGroupMain.wordinverse_of_wordinverse by metis
      moreover have "length (wordinverse ?p) = length (wordinverse ?q)" using leq by (metis length_wordinverse)
      moreover have "?p \<noteq> ?q" using ineq .
      moreover have "length (wordinverse ?p) \<le> length ?a" by (metis length_wordinverse pa)
      moreover have "length (wordinverse ?q) \<le> length ?a" by (metis length_wordinverse qa)
      moreover have "red_rep S (x1 \<otimes>\<^bsub>freegroup S\<^esub> y1) \<noteq> []" using x1y1 FreeGroupMain.wordinverse_symm invxyz xyz by fastforce
      moreover have "red_rep S x1 \<noteq> []" using N0_def assms(2) x1 by auto
      ultimately have cont:"((x1 \<otimes>\<^bsub>freegroup S\<^esub> y1), x1) \<in> lex_L2_word S" using F x1A x1y1in xyz three_point_seven[of "x1" "A" "(x1 \<otimes>\<^bsub>freegroup A\<^esub> y1)" "?p" "?a" "?q"] by (metis three_point_seven)
      have subcases:"(x1, y1) \<in> lex_L2_word S \<or> (y1, x1) \<in> lex_L2_word S" by (simp add: invxyz lex_total x1 x1A xneqy y1 y1A)
      then show ?thesis
      proof(cases "(x1, y1) \<in> lex_L2_word S")
        case True
        then have trans:"((x1 \<otimes>\<^bsub>freegroup S\<^esub> y1), y1) \<in> lex_L2_word S" using cont trans_lex_L2_word transD by fast
        then have "y1 \<notin> X' (SG (F\<^bsub>S\<^esub>) G) S" using lex_cont2[of "x1" "y1" "S" "G"] H assms(1) True by (metis mult_SG)
        moreover then have "inv\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> y1 \<notin> X' (SG (F\<^bsub>S\<^esub>) G) S"  using lex_cont2_inv[of "x1" "y1" "S" "G"] H assms(1) trans True by (metis mult_SG)
        moreover have "X' (SG (F\<^bsub>S\<^esub>) G) S \<subseteq> G"  unfolding X'_def SG_def by simp
        ultimately have "y1 \<notin> (union_inv (X' (SG (freegroup S) G) S) S)" using notin_union_inv[of "G" "S" "y1" "X' (SG F\<^bsub>S\<^esub> G) S"] assms(1) by simp
        then show ?thesis using y1 by blast
      next
        case False
        then have F:"(y1, x1) \<in> lex_L2_word S" using subcases by simp
        then have "x1 \<notin> X' (SG (F\<^bsub>S\<^esub>) G) S" using lex_cont1[of "y1" "x1" "S" "G"] cont H assms(1) by (metis mult_SG)
        moreover have "inv\<^bsub>SG F\<^bsub>S\<^esub> G\<^esub> x1 \<notin> X' (SG (F\<^bsub>S\<^esub>) G) S"  using lex_cont1_inv[of "y1" "x1" "S" "G"] H assms(1) F cont by (metis mult_SG)
        moreover have "X' (SG (F\<^bsub>S\<^esub>) G) S \<subseteq> G"  unfolding X'_def SG_def by simp
        ultimately have "x1 \<notin> (union_inv (X' (SG (freegroup S) G) S) S)" using notin_union_inv[of "G" "S" "x1" "X' (SG F\<^bsub>S\<^esub> G) S"] assms(1) by simp
        then show ?thesis using x1 by blast
      qed
    qed
  qed
qed

end