diff --git a/metadata/entries/Combinatorics_Words.toml b/metadata/entries/Combinatorics_Words.toml
--- a/metadata/entries/Combinatorics_Words.toml
+++ b/metadata/entries/Combinatorics_Words.toml
@@ -1,42 +1,46 @@
 title = "Combinatorics on Words Basics"
 date = 2021-05-24
 topics = [
   "Computer science/Automata and formal languages",
 ]
 abstract = """
 We formalize basics of Combinatorics on Words. This is an extension of
 existing theories on lists. We provide additional properties related
 to prefix, suffix, factor, length and rotation. The topics include
 prefix and suffix comparability, mismatch, word power, total and
 reversed morphisms, border, periods, primitivity and roots. We also
 formalize basic, mostly folklore results related to word equations:
 equidivisibility, commutation and conjugation. Slightly advanced
 properties include the Periodicity lemma (often cited as the Fine and
 Wilf theorem) and the variant of the Lyndon-Schützenberger theorem for
-words. We support the algebraic point of view which sees words as
-generators of submonoids of a free monoid. This leads to the concepts
-of the (free) hull, the (free) basis (or code)."""
+words, including its full parametric solution. We support the algebraic point of view which sees words as generators of submonoids of a free monoid. This leads to the concepts of the (free) hull, the (free) basis (or code). We also provide relevant proof methods and a tool to generate reverse-symmetric claims."""
 license = "bsd"
 note = ""
 
 [authors]
 
 [authors.holub]
 homepage = "holub_homepage"
 
 [authors.raska]
 
 [authors.starosta]
 homepage = "starosta_homepage"
 
 [contributors]
 
 [notify]
 holub = "holub_email"
 starosta = "starosta_email"
 
 [history]
+2022-08-24 = """
+Many updates and additions. New theories: Border_Array, Morphisms, Equations_Basic, and Binary_Code_Morphisms.
+"""
 
 [extra]
 
 [related]
+dois = ["10.4230/LIPIcs.ITP.2021.22"]
+pubs = ["<a href=\"https://arxiv.org/abs/2104.11622\">Producing symmetrical facts for lists induced by the list reversal mapping in Isabelle/HOL</a>", "<a  href=\"https://gitlab.com/formalcow/combinatorics-on-words-formalized\">Development repository</a>"]
+
diff --git a/metadata/entries/Combinatorics_Words_Graph_Lemma.toml b/metadata/entries/Combinatorics_Words_Graph_Lemma.toml
--- a/metadata/entries/Combinatorics_Words_Graph_Lemma.toml
+++ b/metadata/entries/Combinatorics_Words_Graph_Lemma.toml
@@ -1,33 +1,37 @@
 title = "Graph Lemma"
 date = 2021-05-24
 topics = [
   "Computer science/Automata and formal languages",
 ]
 abstract = """
 Graph lemma quantifies the defect effect of a system of word
 equations. That is, it provides an upper bound on the rank of the
 system. We formalize the proof based on the decomposition of a
 solution into its free basis. A direct application is an alternative
 proof of the fact that two noncommuting words form a code."""
 license = "bsd"
 note = ""
 
 [authors]
 
 [authors.holub]
 homepage = "holub_homepage"
 
 [authors.starosta]
 homepage = "starosta_homepage"
 
 [contributors]
 
 [notify]
 holub = "holub_email"
 starosta = "starosta_email"
 
 [history]
+2022-08-24 = """
+Reworked version. Added theory Glued_Codes.
+"""
 
 [extra]
 
 [related]
+pubs = ["<a  href=\"https://gitlab.com/formalcow/combinatorics-on-words-formalized\">Development repository</a>"]
diff --git a/metadata/entries/Combinatorics_Words_Lyndon.toml b/metadata/entries/Combinatorics_Words_Lyndon.toml
--- a/metadata/entries/Combinatorics_Words_Lyndon.toml
+++ b/metadata/entries/Combinatorics_Words_Lyndon.toml
@@ -1,34 +1,36 @@
 title = "Lyndon words"
 date = 2021-05-24
 topics = [
   "Computer science/Automata and formal languages",
 ]
 abstract = """
 Lyndon words are words lexicographically minimal in their conjugacy
 class. We formalize their basic properties and characterizations, in
 particular the concepts of the longest Lyndon suffix and the Lyndon
 factorization. Most of the work assumes a fixed lexicographical order.
 Nevertheless we also define the smallest relation guaranteeing
 lexicographical minimality of a given word (in its conjugacy class)."""
 license = "bsd"
 note = ""
 
 [authors]
 
 [authors.holub]
 homepage = "holub_homepage"
 
 [authors.starosta]
 homepage = "starosta_homepage"
 
 [contributors]
 
 [notify]
 holub = "holub_email"
 starosta = "starosta_email"
 
 [history]
 
 [extra]
 
 [related]
+dois = ["10.1007/978-3-030-81508-0_18"]
+pubs = ["<a  href=\"https://gitlab.com/formalcow/combinatorics-on-words-formalized\">Development repository</a>"]
diff --git a/thys/Combinatorics_Words/Arithmetical_Hints.thy b/thys/Combinatorics_Words/Arithmetical_Hints.thy
--- a/thys/Combinatorics_Words/Arithmetical_Hints.thy
+++ b/thys/Combinatorics_Words/Arithmetical_Hints.thy
@@ -1,60 +1,136 @@
 (*  Title:      CoW/Arithmetical_Hints.thy
     Author:     Štěpán Holub, Charles University
     Author:     Martin Raška, Charles University
     Author:     Štěpán Starosta, CTU in Prague
+
+Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/
 *)
 
 theory Arithmetical_Hints
   imports Main
 begin
 
 section "Arithmetical hints"
 
-text\<open>In this section we give some specific auxiliary lemmas on natural integers.\<close>
+text\<open>In this section we give some specific auxiliary lemmas on natural numbers.\<close>
 
 lemma zero_diff_eq: "i \<le> j \<Longrightarrow> (0::nat) = j - i  \<Longrightarrow> j = i"
   by simp
 
 lemma zero_less_diff': "i < j \<Longrightarrow> j - i \<noteq> (0::nat)" 
    by simp
 
 lemma nat_prod_le: "m \<noteq> (0 :: nat) \<Longrightarrow> m*n \<le> k \<Longrightarrow> n \<le> k"
   using le_trans[of n "m*n" k] by auto
 
 lemma get_div: "(p :: nat) < a \<Longrightarrow> m = (m * a + p) div a"
   by simp
 
 lemma get_mod: "(p :: nat) < a \<Longrightarrow> p = (m * a + p) mod a"
   by simp
 
 lemma plus_one_between:  "(a :: nat) < b \<Longrightarrow> \<not> b < a + 1"
   by auto
 
-lemma quotient_smaller: "a \<noteq> 0 \<Longrightarrow> a = k * b \<Longrightarrow> b \<le> (a::nat)" 
+lemma quotient_smaller: "k \<noteq> (0 :: nat) \<Longrightarrow>  b \<le> k * b" 
   by simp
 
 lemma mult_cancel_le: "b \<noteq> 0 \<Longrightarrow> a*b \<le> c*b \<Longrightarrow> a \<le> (c::nat)" 
   by simp
 
-lemma add_lessD2: assumes "k + m < (n::nat)" shows "m < n" 
-  using add_lessD1[OF assms[unfolded add.commute[of k m]]].
+lemma add_lessD2: "k + m < (n::nat) \<Longrightarrow> m < n"
+unfolding add.commute[of k] using add_lessD1.
 
 lemma mod_offset:  assumes "M \<noteq> (0 :: nat)"
   obtains k where "n mod M = (l + k) mod M"
 proof-
   have "(l + (M - l mod M)) mod M = 0"
     using mod_add_left_eq[of l M "(M - l mod M)", unfolded le_add_diff_inverse[OF mod_le_divisor[OF assms[unfolded neq0_conv]], of l] mod_self, symmetric].
   from mod_add_left_eq[of "(l + (M - l mod M))" M n, symmetric, unfolded this add.commute[of 0] add.comm_neutral]
   have "((l + (M - l mod M)) + n) mod M = n mod M".
   from that[OF this[unfolded add.assoc, symmetric]]
   show thesis.
 qed
 
 lemma assumes "q \<noteq> (0::nat)" shows "p \<le> p + q - gcd p q"
   using gcd_le2_nat[OF \<open>q \<noteq> 0\<close>, of p]
   by linarith
 
 lemma less_mult_one: assumes "(m-1)*k < k" obtains "m = 0" | "m = (1::nat)"
   using assms by fastforce
 
+lemma per_lemma_len_le: assumes le: "p + q - gcd p q \<le> (n :: nat)" and "q \<noteq> 0" shows "p \<le> n"
+  using le unfolding add_diff_assoc[OF gcd_le2_nat[OF \<open>q \<noteq> 0\<close>], symmetric] by (rule add_leD1)
+
+lemma predE: assumes "k \<noteq> 0" obtains pred where "k = Suc pred"
+  using assms not0_implies_Suc by auto
+
+lemma Suc_less_iff_Suc_le: "Suc n < k \<longleftrightarrow> Suc n \<le> k - 1"
+   by auto
+
+lemma nat_induct_pair: "P 0 0 \<Longrightarrow> (\<And> m n. P m n \<Longrightarrow> P m (Suc n)) \<Longrightarrow> (\<And> m n. P m n \<Longrightarrow> P (Suc m) n) \<Longrightarrow> P m n"
+  by (induction m arbitrary: n) (metis nat_induct, simp)
+
+lemma One_less_Two_le_iff: "1 < k \<longleftrightarrow> 2 \<le> (k :: nat)"
+  by fastforce 
+
+lemma at_least2_Suc: assumes "2 \<le> k"
+  obtains k' where "k = Suc(Suc k')"
+  using Suc3_eq_add_3  less_eqE[OF assms] by auto
+
+lemma at_least3_Suc: assumes "3 \<le> k"
+  obtains k' where "k = Suc(Suc(Suc k'))"
+  using Suc3_eq_add_3  less_eqE[OF assms] by auto
+
+lemma two_three_add_le_mult: assumes "2 \<le> (l::nat)" and  "3 \<le> k" shows "l + k + 1 \<le> l*k" 
+proof-
+  obtain l' where l: "l = Suc (Suc l')"
+     using  \<open>2 \<le> l\<close> at_least2_Suc[OF \<open>2 \<le> l\<close>] by blast
+  obtain k' where k: "k = Suc (Suc (Suc k'))"
+    using  \<open>3 \<le> k\<close> at_least3_Suc[OF \<open>3 \<le> k\<close>] by blast
+  show "l + k + 1 \<le> l*k"
+    unfolding l k
+  by (induct l' k' rule: nat_induct_pair, simp, simp add: add.commute[of "Suc (Suc l')"] mult.commute[of "Suc (Suc l')"], simp_all)
+qed
+
+lemmas not0_SucE = not0_implies_Suc[THEN exE] 
+
+lemma le1_SucE: assumes "1 \<le> n"
+  obtains k where "n = Suc k" using Suc_le_D[OF assms[unfolded One_nat_def]] by blast   
+
+lemma Suc_minus:  "k \<noteq> 0 \<Longrightarrow> Suc (k - 1) = k"
+   by simp 
+
+lemma Suc_minus': "1 \<le> k \<Longrightarrow> Suc(k - 1) = k"
+  by simp
+
+lemmas Suc_minus'' = Suc_diff_1
+
+lemma Suc_minus2: "2 \<le> k \<Longrightarrow> Suc (Suc(k - 2)) = k"
+  by auto
+
+lemma almost_equal_equal: assumes "(a:: nat) \<noteq> 0" and "b \<noteq> 0" and eq: "k*(a+b) + a = m*(a+b) + b" 
+  shows "k = m" and "a = b" 
+proof- 
+  show "k = m"
+  proof (rule linorder_cases[of k m])
+    assume "k < m" 
+    from add_le_mono1[OF mult_le_mono1[OF Suc_leI[OF this]]]
+    have "(Suc k)*(a + b) + b \<le> m*(a+b) + b".
+    hence False 
+      using  \<open>b \<noteq> 0\<close> unfolding mult_Suc eq[symmetric] by force
+    thus ?thesis by blast
+  next
+    assume "m < k" 
+    from add_le_mono1[OF mult_le_mono1[OF Suc_leI[OF this]]]
+    have "(Suc m)*(a + b) + a \<le> k*(a+b) + a".
+    hence False 
+      using  \<open>a \<noteq> 0\<close> unfolding mult_Suc eq by force
+    thus ?thesis by blast
+  qed (simp) 
+  thus "a = b"
+    using eq by auto
+qed
+
+
 end
\ No newline at end of file
diff --git a/thys/Combinatorics_Words/Binary_Code_Morphisms.thy b/thys/Combinatorics_Words/Binary_Code_Morphisms.thy
new file mode 100644
--- /dev/null
+++ b/thys/Combinatorics_Words/Binary_Code_Morphisms.thy
@@ -0,0 +1,1354 @@
+(*  Title:      Binary Code Morphisms
+    File:       CoW.Binary_Code_Morphisms
+    Author:     Štěpán Holub, Charles University
+
+Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/
+*)
+
+theory Binary_Code_Morphisms     
+  imports CoWBasic Submonoids Morphisms 
+
+begin
+
+chapter "Binary alphabet and binary morphisms"
+
+section "Datatype of a binary alphabet"
+
+text\<open>Basic elements for construction of binary words.\<close>
+
+type_notation Enum.finite_2 ("binA")
+notation finite_2.a\<^sub>1 ("bin0")
+notation finite_2.a\<^sub>2 ("bin1")
+
+lemmas bin_distinct = Enum.finite_2.distinct
+lemmas bin_exhaust = Enum.finite_2.exhaust
+lemmas bin_induct = Enum.finite_2.induct
+lemmas bin_UNIV = Enum.UNIV_finite_2 
+lemmas bin_eq_neq_iff = Enum.neq_finite_2_a\<^sub>2_iff
+lemmas bin_eq_neq_iff' = Enum.neq_finite_2_a\<^sub>1_iff
+
+abbreviation bin_word_0  :: "binA list" ("\<zero>") where
+  "bin_word_0 \<equiv> [bin0]"
+
+abbreviation bin_word_1 :: "binA list" ("\<one>") where
+  "bin_word_1 \<equiv> [bin1]"
+
+abbreviation binUNIV :: "binA set" where "binUNIV \<equiv> UNIV"
+
+lemma bin_basis_code: "code {\<zero>,\<one>}"
+  by (rule bin_code_code) blast
+
+lemma bin_num: "bin0 = 0" "bin1 = 1"
+  by simp_all
+
+lemma binsimp[simp]: "bin0 - bin1 = bin1" "bin1 - bin0 = bin1" "1 - bin0 = bin1" "1 - bin1 = bin0" "a - a = bin0" "1 - (1 - a) = a"
+  by simp_all
+
+definition bin_swap :: "binA \<Rightarrow> binA" where "bin_swap x \<equiv> 1 - x"
+
+lemma bin_swap_if_then: "1-x = (if x = bin0 then bin1 else bin0)"
+  by fastforce
+
+definition bin_swap_morph where "bin_swap_morph \<equiv> map bin_swap"
+
+lemma alphabet_or[simp]: "a = bin0 \<or> a = bin1" 
+  by auto
+
+lemma bin_im_or: "f [a] = f \<zero> \<or> f [a] = f \<one>" 
+  by (rule bin_exhaust[of a], simp_all) 
+
+thm triv_forall_equality
+
+lemma binUNIV_card: "card binUNIV = 2" 
+  unfolding bin_UNIV card_2_iff by auto
+
+lemma other_letter: obtains b where "b \<noteq> (a :: binA)"
+  using finite_2.distinct(1) by metis
+
+lemma alphabet_or_neq: "x \<noteq> y \<Longrightarrow> x = (a :: binA) \<or> y = a"
+  using alphabet_or[of x] alphabet_or[of y] alphabet_or[of a] by argo
+
+lemma binA_neq_cases: assumes neq: "a \<noteq> b"
+  obtains "a = bin0" and "b = bin1" | "a = bin1" and "b = bin0"
+  using alphabet_or_neq assms by auto
+
+lemma bin_neq_sym_pred: assumes "a \<noteq> b" and "P bin0 bin1" and "P bin1 bin0" shows "P a b" 
+  using assms(2-3) binA_neq_cases[OF \<open>a \<noteq> b\<close>, of "P a b"] by blast
+
+lemma no_third: "(c :: binA) \<noteq> a \<Longrightarrow> b \<noteq> a \<Longrightarrow> b = c"
+  using alphabet_or[of a] by fastforce  
+
+lemma two_in_bin_UNIV: assumes "a \<noteq> b" and  "a \<in> S" and "b \<in> S" shows "S = binUNIV"
+  using  \<open>a \<in> S\<close> \<open>b \<in> S\<close> alphabet_or_neq[OF \<open>a \<noteq> b\<close>] by fast
+
+lemmas two_in_bin_set = two_in_bin_UNIV[unfolded bin_UNIV]
+
+lemma bin_not_comp_set_UNIV: assumes "\<not> u \<bowtie> v" shows "set (u \<cdot> v) = binUNIV"
+proof-
+  have uv: "u \<cdot> v = ((u \<and>\<^sub>p v) \<cdot> ([hd ((u \<and>\<^sub>p v)\<inverse>\<^sup>>u)] \<cdot> tl ((u \<and>\<^sub>p v)\<inverse>\<^sup>>u)))  \<cdot> (u \<and>\<^sub>p v) \<cdot> ([hd ((u \<and>\<^sub>p v)\<inverse>\<^sup>>v)] \<cdot> tl ((u \<and>\<^sub>p v)\<inverse>\<^sup>>v))"
+    unfolding hd_tl[OF lcp_mismatch_lq(1)[OF assms]] hd_tl[OF lcp_mismatch_lq(2)[OF assms]] lcp_lq..
+  from this[unfolded rassoc]
+  have "hd ((u \<and>\<^sub>p v)\<inverse>\<^sup>>u) \<in> set (u \<cdot> v)" and "hd ((u \<and>\<^sub>p v)\<inverse>\<^sup>>v) \<in> set (u \<cdot> v)"
+    unfolding uv by simp_all
+  with lcp_mismatch_lq(3)[OF assms]
+  show ?thesis
+    using two_in_bin_UNIV by blast 
+qed
+
+lemma bin_basis_singletons: "{[q] |q.  q \<in> {bin0, bin1}} = {\<zero>,\<one>}"
+  by blast
+
+lemma bin_basis_generates: "\<langle>{\<zero>,\<one>}\<rangle> = UNIV" 
+  using sings_gen_lists[of binUNIV, unfolded lists_UNIV bin_UNIV bin_basis_singletons, folded bin_UNIV, unfolded lists_UNIV]. 
+
+lemma a_in_bin_basis: "[a] \<in> {\<zero>,\<one>}"
+  using Set.UNIV_I by auto
+
+lemma lcp_zero_one_emp: "\<zero> \<and>\<^sub>p \<one> = \<epsilon>" and lcp_one_zero_emp: "\<one> \<and>\<^sub>p \<zero> = \<epsilon>"
+  by simp+
+
+lemma neq_induct: "(a::binA) \<noteq> b \<Longrightarrow> P a \<Longrightarrow> P b \<Longrightarrow> P c"
+  by (elim binA_neq_cases) (hypsubst, rule finite_2.induct, assumption+)+
+
+lemma neq_exhaust: assumes "(a::binA) \<noteq> b" obtains "c = a" | "c = b"
+  using assms by (elim binA_neq_cases) (hypsubst, elim finite_2.exhaust, assumption)+
+
+lemma bin_swap_neq [simp]: "1-(a :: binA) \<noteq> a" 
+    by simp
+lemmas bin_swap_neq'[simp] = bin_swap_neq[symmetric]
+
+lemmas bin_swap_induct = neq_induct[OF bin_swap_neq']
+   and bin_swap_exhaust = neq_exhaust[OF bin_swap_neq']
+
+lemma bin_swap_induct': "P (a :: binA) \<Longrightarrow> P (1-a) \<Longrightarrow> (\<And> c. P c)"
+  using bin_swap_induct by auto 
+
+lemma bin_UNIV_swap: "{a, 1-a} = binUNIV" (is "?P a")
+  using bin_swap_induct[of ?P bin0, unfolded binsimp] by fastforce
+
+lemma neq_bin_swap: "c \<noteq> d \<Longrightarrow> d = 1-(c :: binA)"
+   by (rule bin_swap_exhaust[of d c]) blast+
+
+lemma neq_bin_swap': "c \<noteq> d \<Longrightarrow> c = 1-(d :: binA)"
+  using neq_bin_swap by presburger
+
+lemma bin_neq_iff: "c \<noteq> d \<longleftrightarrow> d = 1-(c :: binA)"
+  using neq_bin_swap[of c d] bin_swap_neq[of c]  by argo
+
+lemma bin_neq_iff': "c \<noteq> d \<longleftrightarrow> c = 1-(d :: binA)"
+  unfolding bin_neq_iff by force
+
+lemma bin_neq_swap': "a \<noteq> b \<Longrightarrow> b = 1-(a:: binA)"
+  by (simp add: bin_neq_iff')
+
+lemma binA_neq_cases_swap: assumes neq: "a \<noteq> (b :: binA)"
+  obtains "a = c" and "b = 1 - c" | "a = 1 - c" and "b = c"
+  using  bin_neq_swap'[OF assms] bin_swap_exhaust by auto
+
+lemma bin_without_letter: assumes "(a1 :: binA) \<notin> set w"
+  obtains k where "w = [1-a1]\<^sup>@k"
+proof-
+  have "\<forall> c. c \<in> set w \<longrightarrow> c = 1-a1"
+    using assms bin_swap_exhaust by blast 
+  from that unique_letter_wordE'[OF this]
+  show thesis by blast
+qed
+
+lemma bin_neq_swap[intro]: "a \<noteq> b \<Longrightarrow> a = 1-(b:: binA)"
+  by (simp add: bin_neq_iff')
+
+lemma bin_empty_iff: "S = {} \<longleftrightarrow> (a :: binA) \<notin> S \<and> 1-a \<notin> S"
+  using bin_swap_induct[of "\<lambda>a. a \<notin> S"] by blast
+
+lemma bin_UNIV_iff: "S = binUNIV \<longleftrightarrow> a \<in> S \<and> 1-a \<in> S"
+  using two_in_bin_UNIV[OF bin_swap_neq'] by blast
+
+lemma bin_UNIV_I: "a \<in> S \<Longrightarrow> 1-a \<in> S \<Longrightarrow> S = binUNIV"
+  using bin_UNIV_iff by blast
+ 
+lemma swap_UNIV: "{a,1-a} = binUNIV"
+  unfolding bin_UNIV_iff[of "{a,1-a}" a] by fast 
+
+lemma bin_sing_iff: "A = {a :: binA} \<longleftrightarrow> a \<in> A \<and> 1-a \<notin> A"
+proof (rule sym, intro iffI conjI, elim conjE)
+  assume "a \<in> A" and "1-a \<notin> A"
+  have "b \<in> A \<longleftrightarrow> b = a" for b 
+    using \<open>a \<in> A\<close> \<open>1-a \<notin> A\<close> bin_swap_neq
+    by (intro bin_swap_induct[of "\<lambda>c. (c \<in> A) = (c = a)" a b]) blast+
+  then show "A = {a}" by blast
+qed simp_all
+
+lemma bin_set_cases: obtains "S = {}" | "S = {bin0}" | "S = {bin1}" | "S = binUNIV"
+  unfolding bin_empty_iff[of _ "bin0"] bin_UNIV_iff[of _ "bin0"] bin_sing_iff  
+  by fastforce
+
+lemma not_UNIV_E: assumes "A \<noteq> binUNIV" obtains a where "A \<subseteq> {a}"
+  using assms by (cases rule: bin_set_cases[of A]) auto
+
+lemma not_UNIV_nempE: assumes "A \<noteq> binUNIV" and "A \<noteq> {}" obtains a where "A = {a}"
+  using assms by (cases rule: bin_set_cases[of A]) auto
+
+lemma bin_sing_gen_iff: "x \<in> \<langle>{[a]}\<rangle> \<longleftrightarrow> 1-(a :: binA) \<notin> set x"
+  unfolding sing_gen_lists[symmetric] in_lists_conv_set using bin_empty_iff bin_sing_iff by metis  
+
+lemma set_hd_pow_conv: "w \<in> [hd w]* \<longleftrightarrow> set w \<noteq> binUNIV"
+  unfolding root_sing_set_iff  
+proof
+  assume "set w \<subseteq> {hd w}"
+  thus "set w \<noteq> binUNIV" 
+    unfolding bin_UNIV  using bin_distinct(1) by force
+next 
+  assume "set w \<noteq> binUNIV"
+  thus "set w \<subseteq> {hd w}"
+  proof (cases "w = \<epsilon>", simp)
+    assume "set w \<noteq> binUNIV" and "w \<noteq> \<epsilon>"
+    from hd_tl[OF this(2)] this(2)
+    have "hd w \<in> set w" by simp
+    hence "1-hd w \<notin> set w" 
+      using \<open>set w \<noteq> binUNIV\<close> unfolding swap_UNIV[symmetric, of "hd w"] by fast
+    thus "set w \<subseteq> {hd w}"
+      using bin_sing_iff by auto
+  qed
+qed
+
+lemma not_swap_eq: "P a b \<Longrightarrow> (\<And> (c :: binA). \<not> P c (1-c)) \<Longrightarrow> a = b"
+  using bin_neq_iff by metis 
+
+lemma bin_distinct_letter: assumes "set w = binUNIV" 
+  obtains k w' where "[hd w]\<^sup>@Suc k \<cdot> [1-hd w] \<cdot> w' = w"
+proof-
+  from distinct_letter_in_hd'[of w, unfolded set_hd_pow_conv[of w] bool_simps(1), OF assms]
+  obtain m b q where "[hd w] \<^sup>@ Suc m \<cdot> [b] \<cdot> q = w" "b \<noteq> hd w".
+  from that[OF this(1)[unfolded bin_neq_swap[of _ "hd w", OF this(2)]]]
+  show thesis.
+qed
+
+lemma "P a \<longleftrightarrow> P (1-a) \<Longrightarrow> P a \<Longrightarrow> (\<And> (b :: binA). P b)"
+  using bin_swap_induct' by blast
+
+lemma bin_sym_all: "P (a :: binA) \<longleftrightarrow> P (1-a) \<Longrightarrow> P a \<Longrightarrow> P x"
+  using bin_swap_induct[of "\<lambda> a. P a" a, unfolded binsimp] by blast
+
+lemma bin_sym_all_comm:
+  "f [a] \<cdot> f [1-a] \<noteq> f [1-a] \<cdot> f [a] \<Longrightarrow> f [b] \<cdot> f [1-b] \<noteq> f [1-b] \<cdot> f [(b :: binA)]" (is "?P a \<Longrightarrow> ?P b")
+  using bin_sym_all[of ?P a, unfolded binsimp, OF neq_commute].
+
+lemma bin_sym_all_neq:
+  "f [(a :: binA)] \<noteq> f [1-a] \<Longrightarrow> f [b] \<noteq> f [1-b]" (is "?P a \<Longrightarrow> ?P b")
+  using bin_sym_all[of ?P a, unfolded binsimp, OF neq_commute].
+
+section \<open>Binary code morphism\<close>
+
+subsection \<open>From a binary code to a binary morphism\<close>
+
+definition bin_morph_of' :: "'a list \<Rightarrow> 'a list \<Rightarrow> binA list \<Rightarrow> 'a list" where "bin_morph_of' x y u = concat (map (\<lambda> a. (case a of bin0 \<Rightarrow> x | bin1 \<Rightarrow> y)) u)"
+
+definition bin_morph_of :: "'a list \<Rightarrow> 'a list \<Rightarrow> binA list \<Rightarrow> 'a list" where "bin_morph_of x y u = concat (map (\<lambda> a. if a = bin0 then x else y) u)"
+
+lemma case_finite_2_if_else: "case_finite_2 x y = (\<lambda> a. if a = bin0 then x else y)"
+    by (standard, simp split: finite_2.split)
+
+lemma bin_morph_of_case_def: "bin_morph_of x y u = concat (map (\<lambda> a. (case a of bin0 \<Rightarrow> x | bin1 \<Rightarrow> y)) u)"
+  unfolding bin_morph_of_def case_finite_2_if_else.. 
+
+lemma case_finiteD: "case_finite_2 (f \<zero>) (f \<one>) = f\<^sup>\<C>"
+proof
+  show "(case x of bin0 \<Rightarrow> f \<zero> | bin1 \<Rightarrow> f \<one>) = f\<^sup>\<C> x" for x 
+    unfolding core_def by (cases rule: finite_2.exhaust[of x]) auto  
+qed
+
+lemma case_finiteD': "case_finite_2 (f \<zero>) (f \<one>) u = f\<^sup>\<C> u"
+  using case_finiteD by metis  
+
+lemma bin_morph_of_maps: "bin_morph_of x y = List.maps (case_finite_2 x y)"
+  unfolding bin_morph_of_def maps_def unfolding case_finite_2_if_else by simp
+
+lemma bin_morph_of_morph: "morphism (bin_morph_of x y)"
+  unfolding bin_morph_of_def by (simp add: morphism.intro)
+
+lemma bin_morph_ofD: "(bin_morph_of x y) \<zero> = x" "(bin_morph_of x y) \<one> = y"
+  unfolding bin_morph_of_def by simp_all
+
+lemma bin_range: "range f = {f bin0, f bin1}"
+  unfolding bin_UNIV by simp
+
+lemma bin_range_swap: "range f = {f (a::binA), f (1-a)}" (is "?P a")
+  using bin_swap_induct[of ?P bin0] unfolding binsimp bin_UNIV by auto
+
+lemma bin_core_range: "range f\<^sup>\<C> = {f \<zero>, f \<one>}"
+  unfolding core_def bin_range..
+
+lemma bin_core_range_swap: "range f\<^sup>\<C> = {f [(a :: binA)], f [1-a]}" (is "?P a")
+  by (rule bin_induct[of ?P, unfolded binsimp], unfold bin_core_range, simp, force)
+
+lemma bin_map_core_lists: "(map f\<^sup>\<C> w) \<in> lists {f \<zero>, f \<one>}"
+  unfolding core_def by (induct w, simp, unfold map_hd)
+  (rule append_in_lists, simp_all add: bin_im_or) 
+
+lemma bin_map_core_lists_swap: "(map f\<^sup>\<C> w) \<in> lists {f [(a :: binA)], f [1-a]}"
+  using map_core_lists[of f, unfolded bin_core_range_swap[of f a]]. 
+
+lemma bin_morph_of_core_range: "range (bin_morph_of x y)\<^sup>\<C> = {x,y}" 
+  unfolding bin_core_range bin_morph_ofD.. 
+
+lemma bin_morph_of_range: "range (bin_morph_of x y) = \<langle>{x,y}\<rangle>"
+  using morphism.range_hull[of "bin_morph_of x y", unfolded bin_morph_of_core_range, OF bin_morph_of_morph]. 
+
+lemma bin_neq_inj_core: assumes "f [(a :: binA)] \<noteq> f [1-a]" shows "inj f\<^sup>\<C>"
+proof
+  show "f\<^sup>\<C> x = f\<^sup>\<C> y \<Longrightarrow> x = y" for x y
+  proof (rule ccontr)
+    assume "x \<noteq> y"
+    from bin_sym_all_neq[OF assms] 
+    have "f\<^sup>\<C> x \<noteq> f\<^sup>\<C> y"
+      unfolding core_def bin_neq_swap'[OF \<open>x \<noteq> y\<close>].
+    thus "f\<^sup>\<C> x = f\<^sup>\<C> y \<Longrightarrow> False"
+      by blast
+  qed
+qed
+
+lemma bin_code_morphismI: "morphism f \<Longrightarrow> f [a] \<cdot> f [1-a] \<noteq> f [1-a] \<cdot> f [(a :: binA)] \<Longrightarrow> code_morphism f"
+proof (standard, simp add: morphism.morph)
+  assume "morphism f" and "f [a] \<cdot> f [1-a] \<noteq> f [1-a] \<cdot> f [(a :: binA)]"
+  from bin_sym_all_comm[OF this(2)] 
+  have "f [b] \<cdot> f [1-b] \<noteq> f [1-b] \<cdot> f [b]" for b.
+  hence "inj f\<^sup>\<C>"
+    using bin_neq_inj_core[of f] by fastforce  
+  show "inj f"
+    unfolding inj_on_def
+  proof (standard+)
+    fix xs ys assume "f xs = f ys"
+    hence "concat (map f\<^sup>\<C> xs) = concat (map f\<^sup>\<C> ys)"
+      by (simp add: morphism.morph_concat_map[OF \<open>morphism f\<close>])
+    from bin_code_code[unfolded code_def, rule_format,
+      OF \<open>f [a] \<cdot> f [1-a] \<noteq> f [1-a] \<cdot> f [a]\<close> bin_map_core_lists_swap bin_map_core_lists_swap this] 
+    show "xs = ys"
+      using \<open>inj f\<^sup>\<C>\<close> by simp
+  qed
+qed
+
+subsection \<open>Locale - binary code morphism\<close>
+
+locale binary_code_morphism = code_morphism "f :: binA list \<Rightarrow> 'a list" for f  
+
+begin
+
+lemma morph_bin_morph_of: "f = bin_morph_of (f \<zero>) (f \<one>)" 
+  using morph_concat_map unfolding bin_morph_of_def case_finiteD
+  case_finite_2_if_else[symmetric] by simp
+
+lemma non_comm_morph [simp]: "f [a] \<cdot> f [1-a] \<noteq> f [1-a] \<cdot> f [a]"
+  unfolding morph[symmetric] using  code_morph_code bin_swap_neq by blast
+
+lemma non_comp_morph: "\<not> f [a] \<cdot> f [1-a] \<bowtie> f [1-a] \<cdot> f [a]"
+  using comm_comp_eq non_comm_morph by blast 
+
+lemma swap_non_comm_morph [simp, intro]: "a \<noteq> b \<Longrightarrow> f [a] \<cdot> f [b] \<noteq> f [b] \<cdot> f [a]"
+  using bin_neq_swap' non_comm_morph by blast
+
+thm bin_core_range[of f]
+
+lemma bin_code_morph_rev_map: "binary_code_morphism (rev_map f)" 
+  unfolding binary_code_morphism_def using code_morphism_rev_map.
+
+
+sublocale swap: binary_code "f \<one>" "f \<zero>"
+  using non_comm_morph[of bin1] unfolding binsimp by unfold_locales
+
+sublocale binary_code "f \<zero>" "f \<one>"
+  using swap.bin_code_swap.
+
+notation bin_code_lcp ("\<alpha>") and
+         bin_code_lcs ("\<beta>") and
+         bin_code_mismatch_fst ("c\<^sub>0") and
+         bin_code_mismatch_snd ("c\<^sub>1")
+term "bin_lcp (f \<zero>) (f \<one>)"
+abbreviation bin_morph_mismatch ("\<cc>")
+  where "bin_morph_mismatch a \<equiv> bin_mismatch (f[a]) (f[1-a])" 
+abbreviation bin_morph_mismatch_suf ("\<dd>")
+  where "bin_morph_mismatch_suf a \<equiv> bin_mismatch_suf (f[1-a]) (f[a])" 
+
+lemma bin_lcp_def': "\<alpha> =  f ([a] \<cdot> [1-a]) \<and>\<^sub>p f ([1-a] \<cdot> [a])" 
+  by (rule bin_exhaust[of a "\<alpha> =  f ([a] \<cdot> [1-a]) \<and>\<^sub>p f ([1-a] \<cdot> [a])"], 
+  unfold morph, use binsimp(3-4) bin_lcp_def in force)
+  (unfold bin_lcp_def lcp_sym[of "f[a] \<cdot> f[1-a]" "f[1-a] \<cdot> f[a]"],
+  use  binsimp(3-4) in auto)
+
+lemma bin_lcp_neq: "a \<noteq> b \<Longrightarrow> \<alpha> =  f ([a] \<cdot> [b]) \<and>\<^sub>p f ([b] \<cdot> [a])" 
+  using neq_bin_swap[of a b] unfolding bin_lcp_def'[of a] by blast
+
+lemma sing_im: "f [a] \<in>  {f \<zero>, f \<one>}" 
+  using finite_2.exhaust[of a ?thesis] by fastforce 
+
+lemma bin_mismatch_inj: "inj \<cc>"
+  unfolding inj_on_def
+  using non_comm_morph[folded bin_mismatch_comm] neq_bin_swap by force 
+
+lemma map_in_lists: "map (\<lambda>x. f [x]) w \<in> lists {f \<zero>, f \<one>}" 
+proof (induct w, simp)
+  case (Cons a w)
+  then show ?case
+    unfolding list.map(2)  using sing_im by simp
+qed
+
+lemma bin_morph_lcp_short: "\<^bold>|\<alpha>\<^bold>| < \<^bold>|f [a]\<^bold>| + \<^bold>|f[1-a]\<^bold>|"
+  using finite_2.exhaust[of a ?thesis] bin_lcp_short by force
+
+lemma swap_not_pref_bin_lcp:  "\<not> f([a] \<cdot> [1-a]) \<le>p \<alpha>" 
+  using pref_len[of "f [a] \<cdot> f [1-a]" \<alpha>] unfolding morph lenmorph using bin_morph_lcp_short[of a] by force  
+
+thm local.bin_mismatch_inj
+
+lemma bin_mismatch_suf_inj: "inj \<dd>"
+  using binary_code_morphism.bin_mismatch_inj[OF bin_code_morph_rev_map, reversed].
+
+lemma bin_lcp_sing: "bin_lcp (f [a]) (f [1-a]) = \<alpha>"
+  unfolding bin_lcp_def
+  by (rule finite_2.exhaust[of a], simp_all add: lcp_sym) 
+
+lemma bin_lcs_sing: "bin_lcs (f [a]) (f [1-a]) = \<beta>"
+  unfolding bin_lcs_def
+  by (rule finite_2.exhaust[of a], simp_all add: lcs_sym) 
+
+lemma bin_code_morph_sing: "binary_code (f [a]) (f [1-a])"
+  unfolding binary_code_def
+  by (cases rule: binA_neq_cases[OF bin_swap_neq', of a]) simp_all
+
+lemma bin_mismatch_swap_neq: "\<cc> a \<noteq> \<cc> (1-a)"
+  using bin_code_morph_sing binary_code.bin_mismatch_neq by auto 
+
+lemma long_bin_lcp_hd: assumes "\<^bold>|f w\<^bold>| \<le> \<^bold>|\<alpha>\<^bold>|" 
+  shows "w \<in> [hd w]*" 
+proof (rule ccontr)
+  assume "\<not> w \<in> [hd w]*"
+  from distinct_letter_in_hd[OF this]
+  obtain m b suf where w: "[hd w]\<^sup>@m \<cdot> [b]\<cdot> suf = w" and "b \<noteq> hd w" and "m \<noteq> 0".
+  have ineq: "\<^bold>|f [b]\<^bold>| + \<^bold>|f [hd w]\<^bold>| \<le> \<^bold>|f w\<^bold>|" 
+    using  quotient_smaller[OF \<open>m \<noteq> 0\<close>, of "\<^bold>|f [hd w]\<^bold>|"]
+    unfolding arg_cong[OF w, of "\<lambda> x. \<^bold>|f(x)\<^bold>|", unfolded morph lenmorph pow_morph pow_len, symmetric]
+    by linarith
+  hence "\<^bold>|f \<zero>\<^bold>| + \<^bold>|f \<one>\<^bold>| \<le> \<^bold>|f w\<^bold>|"
+    using \<open>b \<noteq> hd w\<close> alphabet_or[of b] alphabet_or[of "hd w"] add.commute by fastforce 
+  thus False
+    using bin_lcp_short \<open>\<^bold>|f w\<^bold>| \<le> \<^bold>|\<alpha>\<^bold>|\<close>  by linarith  
+qed
+
+(*registering nonerasing in binary_code_morphism*)
+lemmas nonerasing = nonerasing
+thm nonerasing_morphism.nonerasing
+    binary_code_morphism.nonerasing
+
+lemma bin_morph_lcp_mismatch_pref:
+ "\<alpha> \<cdot> [\<cc> a] \<le>p f [a] \<cdot> \<alpha>"
+  using binary_code.bin_fst_mismatch[OF bin_code_morph_sing] unfolding bin_lcp_sing.
+
+lemma "[\<dd> a] \<cdot> \<beta> \<le>s \<beta> \<cdot> f [a]"    using binary_code_morphism.bin_morph_lcp_mismatch_pref[OF bin_code_morph_rev_map, reversed].
+
+lemma bin_lcp_pref_all: "\<alpha> \<le>p f w \<cdot> \<alpha>" 
+proof(induct w rule: rev_induct, simp)
+  case (snoc x xs)
+  from pref_prolong[OF this, of "f[x]\<cdot>\<alpha>", unfolded lassoc]
+  show ?case
+    unfolding morph[of xs "[x]"] using bin_lcp_fst_lcp bin_lcp_snd_lcp alphabet_or[of x] by blast    
+qed
+
+lemma long_bin_lcp: assumes "w \<noteq> \<epsilon>" and "\<^bold>|f w\<^bold>| \<le> \<^bold>|\<alpha>\<^bold>|" 
+  shows "w \<in> [hd w]*"
+proof(rule ccontr)
+  assume "w \<notin> [hd w]*"
+    obtain m b q where "[hd w]\<^sup>@m \<cdot> [b] \<cdot> q = w" and "b \<noteq> hd w" and "m \<noteq> 0"
+      using  distinct_letter_in_hd[OF \<open>w \<notin> [hd w]*\<close>]. 
+    have ineq: "\<^bold>|f ([hd w]\<^sup>@m \<cdot> [b])\<^bold>| \<le> \<^bold>|f w\<^bold>|"
+      using arg_cong[OF \<open>[hd w] \<^sup>@ m \<cdot> [b] \<cdot> q = w\<close>, of "\<lambda> x. \<^bold>|f x\<^bold>|"]
+      unfolding morph lenmorph by force
+    have eq: "m*\<^bold>|f [hd w]\<^bold>| + \<^bold>|f [b]\<^bold>| = \<^bold>|f ([hd w]\<^sup>@m \<cdot> [b])\<^bold>|"
+      by (simp add: morph pow_len pow_morph) 
+    have  "\<^bold>|f [hd w]\<^bold>| + \<^bold>|f [b]\<^bold>|  \<le> m*\<^bold>|f [hd w]\<^bold>| + \<^bold>|f [b]\<^bold>|"
+      using ineq \<open>m \<noteq> 0\<close> by simp
+    hence "\<^bold>|f [hd w]\<^bold>| + \<^bold>|f [b]\<^bold>|  \<le> \<^bold>|f w\<^bold>|"
+      using eq ineq by linarith
+    hence "\<^bold>|f \<zero>\<^bold>| + \<^bold>|f \<one>\<^bold>| \<le> \<^bold>|f w\<^bold>|"
+      using binA_neq_cases [OF \<open>b \<noteq> hd w\<close>] by fastforce    
+    thus False
+      using bin_lcp_short \<open>\<^bold>|f w\<^bold>| \<le> \<^bold>|\<alpha>\<^bold>|\<close>  by linarith  
+qed
+
+thm sing_to_nemp
+    nonerasing
+
+lemma bin_mismatch_code_morph: "c\<^sub>0 = \<cc> 0" "c\<^sub>1 = \<cc> 1"
+  unfolding bin_mismatch_def bin_lcp_def by simp_all
+
+lemma bin_lcp_mismatch_pref_all: "\<alpha> \<cdot> [\<cc> a] \<le>p f [a] \<cdot> f w \<cdot> \<alpha>"
+  using pref_prolong[OF bin_fst_mismatch bin_lcp_pref_all[of w]]
+        pref_prolong[OF bin_snd_mismatch bin_lcp_pref_all[of w]] 
+  unfolding bin_mismatch_code_morph 
+  by (cases rule: finite_2.exhaust[of a]) simp_all
+
+lemma bin_fst_mismatch_all: "\<alpha> \<cdot> [c\<^sub>0] \<le>p f \<zero> \<cdot> f w \<cdot> \<alpha>"
+  using pref_prolong[OF bin_fst_mismatch bin_lcp_pref_all[of w]].
+
+lemma bin_snd_mismatch_all: "\<alpha> \<cdot> [c\<^sub>1] \<le>p f \<one> \<cdot> f w \<cdot> \<alpha>"
+  using pref_prolong[OF bin_snd_mismatch bin_lcp_pref_all[of w]] by simp
+
+lemma bin_long_mismatch: assumes "\<^bold>|\<alpha>\<^bold>| < \<^bold>|f w\<^bold>|" shows "\<alpha> \<cdot> [\<cc> (hd w)] \<le>p f w"
+proof-
+  have "w \<noteq> \<epsilon>"
+    using assms emp_to_emp emp_len by force
+  have "f w = f[hd w] \<cdot> f (tl w)"
+    unfolding pop_hd[symmetric] unfolding hd_word[of "hd w" "tl w"] 
+    hd_tl[OF \<open>w \<noteq> \<epsilon>\<close>]..
+  have "\<alpha> \<cdot> [\<cc> (hd w)] \<le>p f w \<cdot> \<alpha>"
+    using bin_lcp_mismatch_pref_all[of "hd w" "tl w"]
+    unfolding lassoc \<open>f w = f[hd w] \<cdot> f (tl w)\<close>[symmetric].
+  moreover have "\<^bold>|\<alpha> \<cdot> [\<cc> (hd w)]\<^bold>| \<le> \<^bold>|f w\<^bold>|" 
+    unfolding lenmorph sing_len using assms by linarith 
+  ultimately show ?thesis by blast
+qed
+
+lemma sing_pow_mismatch: assumes "f [a] = [b]\<^sup>@Suc n" shows "\<cc> a = b"
+proof-
+  \<comment> \<open>auxiliary\<close>
+  have aritm: "Suc n * Suc \<^bold>|\<alpha>\<^bold>|  = Suc (n*\<^bold>|\<alpha>\<^bold>| + n + \<^bold>|\<alpha>\<^bold>|)"
+    by auto
+  have set: "set ([b] \<^sup>@ (Suc n * Suc \<^bold>|\<alpha>\<^bold>|)) = {b}"
+    unfolding aritm using sing_pow_set_Suc. 
+  have elem: "\<cc> a \<in> set (\<alpha> \<cdot> [\<cc> a])" 
+    by simp
+  have hd: "hd ([a] \<^sup>@ Suc \<^bold>|\<alpha>\<^bold>|) = a"
+    by fastforce 
+  \<comment> \<open>proof\<close> 
+  let ?w = "[a]\<^sup>@Suc \<^bold>|\<alpha>\<^bold>|"
+  have fw: "f ?w = [b]\<^sup>@(Suc n*Suc \<^bold>|\<alpha>\<^bold>|)" 
+    unfolding power_mult assms[symmetric] pow_morph..  
+  have "\<^bold>|\<alpha>\<^bold>| < \<^bold>|f ?w\<^bold>|" 
+    unfolding fw pow_len sing_len by force 
+  from set_mono_prefix[OF bin_long_mismatch[OF this, unfolded fw]]
+  show "\<cc> a = b"
+    unfolding hd set using elem by blast
+qed
+
+lemma sing_pow_mismatch_suf: "f [a] = [b]\<^sup>@Suc n \<Longrightarrow> \<dd> a = b"
+  using binary_code_morphism.sing_pow_mismatch[OF bin_code_morph_rev_map, reversed].
+
+lemma bin_mismatch_swap_all: "f [a] \<cdot> f w \<cdot> \<alpha>  \<and>\<^sub>p f [1-a] \<cdot> f w' \<cdot> \<alpha> = \<alpha>"
+  using lcp_first_mismatch[OF bin_mismatch_swap_neq, of \<alpha> a]
+        bin_lcp_mismatch_pref_all[of a w] bin_lcp_mismatch_pref_all[of "1-a" w']
+  unfolding pref_def rassoc by force
+
+lemma bin_mismatch_all: "f \<zero> \<cdot> f w \<cdot> \<alpha>  \<and>\<^sub>p f \<one> \<cdot> f w' \<cdot> \<alpha> = \<alpha>"
+  using bin_mismatch_swap_all[of bin0, unfolded binsimp].
+
+lemma bin_mismatch_swap_not_comp: "\<not> f [a] \<cdot> f w \<cdot> \<alpha>  \<bowtie> f [1-a] \<cdot> f w' \<cdot> \<alpha>"
+  unfolding prefix_comparable_def lcp_pref_conv[symmetric] bin_mismatch_swap_all 
+            bin_mismatch_swap_all[of "1-a", unfolded binsimp] using sing_to_nemp by auto 
+
+lemma bin_lcp_root: "\<alpha> \<le>p (f [a])\<^sup>\<omega>"
+  using alphabet_or[of a] per_rootI[OF bin_lcp_pref_all[of \<one>] bin_snd_nemp] per_rootI[OF bin_lcp_pref_all[of \<zero>] bin_fst_nemp] by blast 
+
+lemma bin_lcp_pref: assumes "w \<notin> \<one>*" and  "w \<notin> \<zero>*"
+  shows "\<alpha> \<le>p (f w)"
+proof-
+  have "w \<noteq> \<epsilon>"
+    using \<open>\<not> (w \<in> \<one>*)\<close> emp_all_roots by blast
+  have "w \<notin> [hd w]*" 
+    using assms alphabet_or[of "hd w"]  by presburger
+  hence "\<^bold>|\<alpha>\<^bold>| \<le> \<^bold>|f w\<^bold>|"
+    using long_bin_lcp[OF \<open>w \<noteq> \<epsilon>\<close>] nat_le_linear[of "\<^bold>|f w\<^bold>|" "\<^bold>|\<alpha>\<^bold>|" ] by blast
+  show ?thesis
+    using  pref_prod_le[OF bin_lcp_pref_all \<open>\<^bold>|\<alpha>\<^bold>| \<le> \<^bold>|f w\<^bold>|\<close>].
+qed
+
+lemma bin_mismatch_sings: "a \<noteq> b \<Longrightarrow> f [a] \<cdot> \<alpha>  \<and>\<^sub>p f [b] \<cdot> \<alpha> = \<alpha>" 
+  using bin_mismatch bin_mismatch[unfolded lcp_sym[of "f \<zero> \<cdot> \<alpha>" "f \<one> \<cdot> \<alpha>"]]
+  by  (elim bin_neq_sym_pred)
+
+lemma bin_lcp_pref'': "[a] \<le>f w \<Longrightarrow> [1-a] \<le>f w  \<Longrightarrow> \<alpha> \<le>p (f w)"
+  using  bin_lcp_pref[of w]  sing_pow_fac'[OF bin_distinct(1),of w] sing_pow_fac'[OF bin_distinct(2), of w]
+  by (cases rule: finite_2.exhaust[of a]) force+
+
+lemma bin_lcp_pref': "\<zero> \<le>f w \<Longrightarrow> \<one> \<le>f w  \<Longrightarrow> \<alpha> \<le>p (f w)" 
+  using bin_lcp_pref''[of bin0, unfolded binsimp]. 
+
+lemma bin_lcp_mismatch_pref_all_set: assumes "1-a \<in> set w"
+  shows  "\<alpha> \<cdot> [\<cc> a] \<le>p f [a] \<cdot> f w"
+proof-
+  have "\<^bold>|f[1-a]\<^bold>| \<le> \<^bold>|f w\<^bold>|" 
+    using fac_len' morph split_list'[OF assms] by metis 
+  hence "\<^bold>|\<alpha> \<cdot> [\<cc> a]\<^bold>| \<le> \<^bold>|f [a] \<cdot> f w\<^bold>|" 
+    using bin_lcp_short unfolding lenmorph sing_len
+    by (cases rule: finite_2.exhaust[of a]) fastforce+
+  from bin_lcp_mismatch_pref_all[unfolded lassoc, THEN pref_prod_le, OF this]
+  show ?thesis.
+qed
+
+lemma bin_lcp_comp_hd: "\<alpha> \<bowtie> f (\<zero> \<cdot> w0) \<and>\<^sub>p  f (\<one> \<cdot> w1)"
+  using  ruler[OF bin_lcp_pref_all[of "\<zero> \<cdot> w0"]
+      pref_trans[OF lcp_pref[of "f (\<zero> \<cdot> w0)" "f (\<one> \<cdot> w1)"], of "f (\<zero> \<cdot> w0) \<cdot> \<alpha>", OF triv_pref]] 
+  unfolding prefix_comparable_def. 
+
+lemma sing_mismatch: assumes "f \<zero> \<in> [a]*" shows "c\<^sub>0 = a"
+proof- 
+  have "\<alpha> \<in> [a]*"
+    using per_one[OF per_root_trans[OF bin_lcp_root assms]].
+  hence "f \<zero> \<cdot> \<alpha> \<in> [a]*"
+    using \<open>f \<zero> \<in> [a]*\<close> add_roots by blast 
+  from sing_pow_fac'[OF _ this, of "c\<^sub>0"]
+  show "c\<^sub>0 = a"  
+    using facI'[OF lq_pref[OF bin_fst_mismatch, unfolded rassoc]] by blast
+qed
+
+lemma sing_mismatch': assumes "f \<one> \<in> [a]*" shows "c\<^sub>1 = a" 
+proof- 
+  have "\<alpha> \<in> [a]*"
+    using per_one[OF per_root_trans[OF bin_lcp_root assms]].
+  hence "f \<one> \<cdot> \<alpha> \<in> [a]*"
+    using \<open>f \<one> \<in> [a]*\<close> add_roots by blast 
+  from sing_pow_fac'[OF _ this, of "c\<^sub>1"]
+  show ?thesis
+    using facI'[OF lq_pref[OF bin_snd_mismatch, unfolded rassoc]] by blast 
+qed
+
+lemma bin_lcp_comp_all: "\<alpha> \<bowtie> (f w)"
+  unfolding prefix_comparable_def using ruler[OF bin_lcp_pref_all triv_pref].
+
+lemma not_comp_bin_swap: "\<not> f [a] \<cdot> \<alpha> \<bowtie> f [1-a] \<cdot> \<alpha>" 
+  by (rule bin_exhaust[of a ?thesis], use not_comp_bin_fst_snd in simp_all)
+
+lemma mismatch_pref: 
+  assumes "\<alpha> \<le>p f ([a] \<cdot> w0)" and "\<alpha> \<le>p f ([1-a] \<cdot> w1)" 
+  shows "\<alpha> = f ([a] \<cdot> w0) \<and>\<^sub>p f ([1-a] \<cdot> w1)" 
+proof-
+  have "f ([a] \<cdot> w0) \<cdot> \<alpha> \<and>\<^sub>p f ([1-a] \<cdot> w1) \<cdot> \<alpha> = \<alpha>"
+    unfolding morph using bin_mismatch_swap_all[unfolded lassoc]. 
+  hence "f ([a] \<cdot> w0) \<and>\<^sub>p f ([1-a] \<cdot> w1) \<le>p \<alpha>"
+    using lcp_pref_monotone[OF triv_pref[of "f ([a] \<cdot> w0)" \<alpha>] triv_pref[of "f ([1-a] \<cdot> w1)" \<alpha>]]
+    by presburger 
+  moreover have "\<alpha> \<le>p f ([a] \<cdot> w0) \<and>\<^sub>p f ([1-a] \<cdot> w1)"
+    using assms pref_pref_lcp by blast
+  ultimately show ?thesis
+    using pref_antisym by blast 
+qed   
+
+lemma  bin_set_UNIV_length: assumes "set w = UNIV" shows "\<^bold>|f [a]\<^bold>| + \<^bold>|f [1-a]\<^bold>| \<le> \<^bold>|f w\<^bold>|"
+proof-
+  have "w \<noteq> \<epsilon>"
+    using \<open>set w = UNIV\<close> by force
+  from set_ConsD[of "1- hd w" "hd w" "tl w", unfolded list.collapse[OF this] assms[folded swap_UNIV[of "hd w"]]]
+  have "1 - (hd w) \<in> set (tl w)"
+    using bin_swap_neq[of "hd w"] by blast
+  from in_set_morph_len[OF this]
+  have "\<^bold>|f [1-hd w]\<^bold>| \<le> \<^bold>|f (tl w)\<^bold>|".
+  with lenarg[OF arg_cong[of _ _ f, OF hd_tl[OF \<open>w \<noteq> \<epsilon>\<close>]]]
+  have "\<^bold>|f [hd w]\<^bold>| + \<^bold>|f [1-hd w]\<^bold>| \<le> \<^bold>|f w\<^bold>|"
+    unfolding morph lenmorph by linarith
+  thus ?thesis
+    using bin_swap_exhaust[of a "hd w" ?thesis] by force
+qed    
+
+lemma set_UNIV_bin_lcp_pref: assumes "set w = UNIV" shows "\<alpha> \<cdot> [\<cc> (hd w)] \<le>p f w" 
+  using bin_long_mismatch[OF less_le_trans[OF bin_morph_lcp_short bin_set_UNIV_length[OF assms]]].
+
+lemmas not_comp_bin_lcp_pref =  bin_not_comp_set_UNIV[THEN set_UNIV_bin_lcp_pref]
+
+lemma marked_lcp_conv: "marked_morphism f \<longleftrightarrow> \<alpha> = \<epsilon>"
+proof
+  assume "marked_morphism f"
+  then interpret marked_morphism f by blast
+  from marked_core[unfolded core_def] core_nemp[unfolded core_def]
+  have "hd (f \<zero> \<cdot> f \<one>) \<noteq> hd (f \<one> \<cdot> f \<zero>)"
+    using hd_append finite_2.distinct by auto
+  thus "\<alpha> = \<epsilon>"
+    unfolding bin_lcp_def using lcp_distinct_hd by blast 
+next
+  assume "\<alpha> = \<epsilon>"
+  have "hd (f \<zero>) \<noteq> hd (f \<one>)" 
+    by (rule nemp_lcp_distinct_hd[OF sing_to_nemp sing_to_nemp])
+    (use  lcp_append_monotone[of "f \<zero>" "f \<one>" "f \<one>" "f \<zero>", unfolded \<open>\<alpha> = \<epsilon>\<close>[unfolded bin_lcp_def]]
+    in simp)
+  show "marked_morphism f"
+  proof 
+    fix a b :: binA assume "hd (f\<^sup>\<C> a) = hd (f\<^sup>\<C> b)" 
+    thus "a = b" 
+      unfolding core_def using \<open>hd (f \<zero>) \<noteq> hd (f \<one>)\<close> 
+      by (induction a) (rule bin_exhaust[of b], simp_all, rule bin_exhaust[of b], simp_all)
+  qed
+qed
+
+lemma im_comm_lcp: "f w \<cdot> \<alpha> = \<alpha> \<cdot> f w \<Longrightarrow> (\<forall> a. a \<in> set w \<longrightarrow> f [a] \<cdot> \<alpha> = \<alpha> \<cdot> f [a])"
+proof (induct w, simp)
+  case (Cons a w)
+  then show ?case
+  proof (cases "w = \<epsilon>")
+    assume "w = \<epsilon>"
+    show ?thesis
+      using Cons.prems(1) unfolding \<open>w = \<epsilon>\<close> by force
+  next
+    assume "w \<noteq> \<epsilon>"
+    have eq: "f [a] \<cdot> f w \<cdot> \<alpha> = \<alpha> \<cdot> f [a] \<cdot> f w"
+      unfolding morph[symmetric] 
+      unfolding lassoc morph[symmetric] hd_tl[OF \<open>w \<noteq> \<epsilon>\<close>]
+      using \<open>f (a # w) \<cdot> \<alpha> = \<alpha> \<cdot> f (a # w)\<close> by force
+    have "f [a] \<cdot> \<alpha> \<le>p f [a] \<cdot> f w \<cdot> \<alpha>" 
+      unfolding pref_cancel_conv using bin_lcp_pref_all.
+    hence "f [a] \<cdot> \<alpha> = \<alpha> \<cdot> f [a]" 
+      using eqd_eq[of "\<alpha> \<cdot> f [a]", OF _swap_len] unfolding pref_def eq rassoc by metis
+    from eq[unfolded lassoc, folded this, unfolded rassoc cancel]
+    have "f w \<cdot> \<alpha> = \<alpha> \<cdot> f w".
+    from Cons.hyps[OF this] \<open>f [a] \<cdot> \<alpha> = \<alpha> \<cdot> f [a]\<close>
+    show ?thesis by fastforce
+  qed
+qed
+
+lemma im_comm_lcp_nemp: assumes "f w \<cdot> \<alpha> = \<alpha> \<cdot> f w" and "w \<noteq> \<epsilon>" and "\<alpha> \<noteq> \<epsilon>"
+  obtains k where "w = [hd w]\<^sup>@Suc k"
+proof-
+  have "set w = {hd w}" 
+  proof-
+    have "hd w \<in> set w" using \<open>w \<noteq> \<epsilon>\<close> by force
+    have "a = hd w" if "a \<in> set w" for a
+    proof-
+      have "f [a] \<cdot> \<alpha> = \<alpha> \<cdot> f [a]" and "f [hd w] \<cdot> \<alpha> = \<alpha> \<cdot> f [hd w]"
+      using that im_comm_lcp[OF \<open>f w \<cdot> \<alpha> = \<alpha> \<cdot> f w\<close>] \<open>hd w \<in> set w\<close> by presburger+
+    from comm_trans[OF this \<open>\<alpha> \<noteq> \<epsilon>\<close>]
+    show "a = hd w"
+      using swap_non_comm_morph by blast
+    qed
+    thus "set w = {hd w}" 
+      using \<open>hd w \<in> set w\<close> by blast
+  qed
+  from unique_letter_wordE[OF this]
+  show thesis
+    using that by blast
+qed  
+
+end
+
+subsection \<open>More translations\<close>
+
+lemma bin_code_code_morph: "binary_code x y \<Longrightarrow> code_morphism (bin_morph_of x y)"
+  using bin_code_morphismI[of _ bin0, unfolded binsimp, OF bin_morph_of_morph, unfolded bin_morph_ofD, OF binary_code.non_comm]. 
+
+lemma bin_code_morph_iff': "binary_code_morphism f \<longleftrightarrow> morphism f \<and> f [a] \<cdot> f [1-a] \<noteq> f [1-a] \<cdot> f [a]"
+proof
+  assume "binary_code_morphism f"
+  hence "morphism f"
+    by (simp add: binary_code_morphism_def code_morphism_def) 
+  have "f [a] \<cdot> f [1-a] \<noteq> f [1-a] \<cdot> f [a]"
+    using \<open>binary_code_morphism f\<close> binary_code_morphism.non_comm_morph by auto
+  thus "morphism f \<and> f [a] \<cdot> f [1-a] \<noteq> f [1-a] \<cdot> f [a]"
+    using \<open>morphism f\<close> by blast
+next
+  assume "morphism f \<and> f [a] \<cdot> f [1-a] \<noteq> f [1-a] \<cdot> f [a]"
+  hence "morphism f" and "f [a] \<cdot> f [1-a] \<noteq> f [1-a] \<cdot> f [a]" by force+
+  interpret morphism f
+    using \<open>morphism f\<close>.
+  interpret binary_code "f [a]" "f [1-a]"
+    using binary_code.intro[OF \<open>f [a] \<cdot> f [1-a] \<noteq> f [1-a] \<cdot> f [a]\<close>]. 
+  show "binary_code_morphism f"
+    using \<open>morphism f \<and> f [a] \<cdot> f [1 - a] \<noteq> f [1 - a] \<cdot> f [a]\<close> bin_code_morphismI binary_code_morphism.intro by blast 
+  qed
+
+lemma bin_code_morph_iff: "binary_code_morphism (bin_morph_of x y) \<longleftrightarrow> x \<cdot> y \<noteq> y \<cdot> x"
+  unfolding bin_code_morph_iff'[of "bin_morph_of x y" bin0, unfolded binsimp bin_morph_ofD] 
+  using bin_morph_of_morph by blast
+
+lemma bin_noner_morph_iff: "nonerasing_morphism (bin_morph_of x y) \<longleftrightarrow> x \<noteq> \<epsilon> \<and> y \<noteq> \<epsilon>"
+proof
+  show "x \<noteq> \<epsilon> \<and> y \<noteq> \<epsilon> \<Longrightarrow> nonerasing_morphism (bin_morph_of x y)"
+    by (rule morphism.nonerI[OF bin_morph_of_morph, of x y], unfold core_def  bin_morph_of_def)
+    (simp split: finite_2.split)
+  show "nonerasing_morphism (bin_morph_of x y) \<Longrightarrow> x \<noteq> \<epsilon> \<and> y \<noteq> \<epsilon>"
+    using nonerasing_morphism.nemp_to_nemp[of "bin_morph_of x y", of "[bin0]"]
+          nonerasing_morphism.nemp_to_nemp[of "bin_morph_of x y", of "[bin1]"]
+    unfolding bin_morph_of_def by simp_all
+qed
+
+thm bin_neq_inj_core
+    bin_core_range
+
+
+lemma morph_bin_morph_of: "morphism f \<longleftrightarrow> bin_morph_of (f \<zero>) (f \<one>) = f" 
+proof 
+  show "morphism f \<Longrightarrow> bin_morph_of (f \<zero>) (f \<one>) = f"  
+  using  morphism.morph_concat_map'[of f] 
+  unfolding bin_morph_of_def case_finiteD[symmetric, of f] case_finite_2_if_else  by  blast 
+qed (use bin_morph_of_morph in metis)
+
+subsection \<open>Example of a simple symmetry: swap\<close>
+
+context binary_code_morphism
+
+begin
+
+definition f_swap where "f_swap \<equiv> f \<circ> bin_swap_morph"
+
+lemma f_swap_sing [simp]: "f_swap [a] = f [1-a]"
+  unfolding f_swap_def bin_swap_morph_def bin_swap_def by force
+
+sublocale swap_morph: morphism f_swap 
+  unfolding f_swap_def bin_swap_morph_def
+  using morph_compose morph_map morphism_axioms by blast 
+
+
+lemma inj_bin_swap: "inj bin_swap"
+  unfolding inj_def bin_swap_def by force
+
+lemma inj_bin_swap_morph: "inj bin_swap_morph"
+  unfolding bin_swap_morph_def using inj_bin_swap  by force
+
+lemma swap_bin_code_morph: "binary_code_morphism f_swap" 
+  by (standard, unfold f_swap_def)
+   (use code_morph inj_bin_swap_morph in force)
+
+(* interpretation swap1: binary_code_morphism f_swap *) 
+  (* using swap_bin_code_morph. *)
+
+(* lemma dual_bin_lcp: "swap.bin_code_lcp = \<alpha>" *)
+  (* unfolding bin_lcp_def bin_lcp_def *)
+  (* unfolding f_swap_sing binsimp using lcp_sym by blast *)
+
+(* lemma dual_mismatch_fst: "swap.bin_code_mismatch_fst = c\<^sub>1" *)
+  (* unfolding bin_mismatch_def dual_bin_lcp *)
+  (* unfolding f_swap_sing binsimp bin_lcp_sym[of "f \<zero>"] by simp *)
+
+(* lemma dual_mismatch_snd: "swap.bin_code_mismatch_snd = c\<^sub>0" *)
+  (* unfolding bin_mismatch_def dual_bin_lcp *)
+  (* unfolding f_swap_sing binsimp bin_lcp_sym[of "f \<zero>"] by simp *)
+
+(* lemmas swap_morph = swap_morph.morph *)
+
+(* lemmas bin_lcp_pref_all_swap = bin_lcp_pref_all[unfolded dual_bin_lcp] *)
+
+end
+
+section "Marked binary morphism"
+
+lemma marked_binary_morphI: assumes "morphism f" and "f [a :: binA] \<noteq> \<epsilon>" and "f [1-a] \<noteq> \<epsilon>" and "hd (f [a]) \<noteq> hd (f [1-a])"
+  shows "marked_morphism f"
+proof (standard, simp add: \<open>morphism f\<close> morphism.morph)
+  have "f [b] \<noteq> \<epsilon>" for b   
+    by (rule bin_swap_exhaust[of b a]) (use assms in force)+
+  thus "w = \<epsilon>" if "f w  = \<epsilon>" for w
+    using morphism.noner_sings_conv[OF \<open>morphism f\<close>] that by blast 
+  show "c = b" if "hd (f\<^sup>\<C> c) = hd (f\<^sup>\<C> b)" for c b
+  proof (rule ccontr)
+    assume "c \<noteq> b"
+    have "hd (f [c]) \<noteq> hd (f [b])" 
+      by (rule binA_neq_cases_swap[OF \<open>c \<noteq> b\<close>, of a])
+         (use \<open>hd (f [a]) \<noteq> hd (f [1-a])\<close> in fastforce)+
+    thus False
+      using that[unfolded core_def] by contradiction
+  qed
+qed
+
+locale marked_binary_morphism = marked_morphism "f :: binA list \<Rightarrow> 'a list"  for f 
+
+begin
+
+lemma bin_marked: "hd (f \<zero>) \<noteq> hd (f \<one>)"
+  using marked_morph[of bin0 bin1] by blast
+
+lemma bin_marked_sing: "hd (f [a]) \<noteq> hd (f [1-a])"
+  by (cases rule: finite_2.exhaust[of a]) (simp_all add: bin_marked bin_marked[symmetric]) 
+
+
+sublocale binary_code_morphism
+  using binary_code_morphism_def code_morphism_axioms by blast
+
+lemma marked_lcp_emp: "\<alpha> = \<epsilon>" 
+  unfolding bin_lcp_def
+proof (rule lcp_distinct_hd)
+  show "hd (f \<zero> \<cdot> f \<one>) \<noteq> hd (f \<one> \<cdot> f \<zero>)"
+  unfolding hd_append if_not_P[OF sing_to_nemp]
+  using bin_marked.
+qed
+
+lemma bin_marked': "(f \<zero>)!0 \<noteq> (f \<one>)!0"
+  using bin_marked unfolding hd_conv_nth[OF bin_snd_nemp] hd_conv_nth[OF bin_fst_nemp]. 
+
+lemma marked_bin_morph_pref_code: assumes "f r \<le>p f s" shows "r \<le>p s"
+  using code_morph_code[OF assms[folded lcp_pref_conv, folded  marked_morph_lcp[of r s]], unfolded lcp_pref_conv[of r s]].
+
+lemma marked_bin_morph_pref_code': "r \<bowtie> s \<or> f (r \<cdot> z1) \<and>\<^sub>p f (s \<cdot> z2) = f (r \<and>\<^sub>p s)"
+ using lcp_ext_right marked_morph_lcp[of "r \<cdot> z1" "s \<cdot> z2"] by metis
+
+lemma swap_marked: "hd(f_swap [a]) \<noteq> hd (f_swap [1-a])"
+  using bin_marked_sing f_swap_sing by presburger 
+
+lemma swap_marked': "hd (f_swap [a]) = hd (f_swap [b]) \<Longrightarrow> a = b"
+  using swap_marked bin_neq_swap by auto
+
+lemma swap_nonerasing: "f_swap w = \<epsilon> \<Longrightarrow> w = \<epsilon>"
+  unfolding f_swap_def bin_swap_morph_def using nonerasing by auto
+
+lemma swap_interpret_marked_binary_morph: "marked_morphism f_swap" 
+  by (standard, unfold core_def) (use swap_nonerasing swap_marked' in blast)+
+
+lemma period_comp:
+  assumes "r \<le>p f w\<^sup>\<omega>"
+  shows "r \<bowtie> f w \<cdot> \<alpha>"
+proof-
+  obtain n where "r \<le>p f w\<^sup>@Suc n" 
+    using assms[unfolded per_pref] pref_pow_ext[of r "f w"] by blast
+  from ruler[OF _ pref_ext[OF this, of \<alpha>], of "f w \<cdot> \<alpha>", unfolded pow_Suc rassoc pref_cancel_conv] 
+  show ?thesis 
+    unfolding prefix_comparable_def using bin_lcp_pref_all[of "w\<^sup>@n", unfolded pow_morph] by blast
+qed 
+
+end
+
+lemma bin_marked_preimg_hd:
+  assumes "marked_binary_morphism (f :: binA list \<Rightarrow> binA list)"
+  obtains c where "hd (f [c]) = a"
+proof-
+  interpret marked_binary_morphism f
+    using assms.
+  from that alphabet_or_neq[OF bin_marked]
+  show thesis
+    by blast
+qed    
+
+section "Marked version"
+
+context binary_code_morphism
+
+begin
+
+definition  marked_version ("f\<^sub>m") where "f\<^sub>m = (\<lambda> w. \<alpha>\<inverse>\<^sup>>(f w \<cdot> \<alpha>))"
+
+lemma marked_version_conjugates: "\<alpha> \<cdot> f\<^sub>m w = f w \<cdot> \<alpha>"
+  unfolding marked_version_def using lq_pref[OF bin_lcp_pref_all, of w].  
+
+lemma marked_eq_conv: "f w = f w' \<longleftrightarrow> f\<^sub>m w = f\<^sub>m w'" 
+ using cancel[of \<alpha> "f\<^sub>m w" "f\<^sub>m w'"] unfolding marked_version_conjugates cancel_right.
+
+thm marked_lcp_conv
+
+lemma marked_marked: assumes "marked_morphism f" shows "f\<^sub>m = f"
+  using marked_version_conjugates[unfolded clean_emp \<open>marked_morphism f\<close>[unfolded marked_lcp_conv]]
+  by blast
+
+lemma  marked_version_all_nemp: "w \<noteq> \<epsilon> \<Longrightarrow> f\<^sub>m w \<noteq> \<epsilon>"
+  unfolding marked_version_def  using bin_lcp_pref_all nonerasing conjug_emp_emp marked_version_def by blast
+
+lemma marked_version_interpret_binary_code_morph: "binary_code_morphism f\<^sub>m"
+  unfolding bin_code_morph_iff' morphism_def
+proof (standard+)
+  have "f (u\<cdot>v) \<cdot> \<alpha> = (f u \<cdot> \<alpha>) \<cdot> \<alpha>\<inverse>\<^sup>>(f v \<cdot> \<alpha>)" for u v
+    unfolding rassoc morph cancel lq_pref[OF bin_lcp_pref_all[of v]]..
+  thus "\<And>u v. f\<^sub>m (u \<cdot> v) = f\<^sub>m u \<cdot> f\<^sub>m v"  
+    unfolding marked_version_def  lq_reassoc[OF bin_lcp_pref_all] by presburger  
+  from code_morph
+  show "inj f\<^sub>m"
+    unfolding inj_def marked_eq_conv.
+qed
+
+(* TODO marked? *)
+interpretation mv_bcm: binary_code_morphism f\<^sub>m
+  using marked_version_interpret_binary_code_morph .
+
+lemma marked_lcs: "bin_lcs (f\<^sub>m \<zero>) (f\<^sub>m \<one>) = \<beta> \<cdot> \<alpha>"
+  unfolding bin_lcs_def morph[symmetric] lcs_ext_right[symmetric] marked_version_conjugates[symmetric] mv_bcm.morph[symmetric] 
+  by (rule lcs_ext_left[of "f\<^sub>m (\<zero> \<cdot> \<one>)" "f\<^sub>m (\<one> \<cdot> \<zero>)" "f\<^sub>m (\<zero> \<cdot> \<one>) \<and>\<^sub>s f\<^sub>m (\<one> \<cdot> \<zero>)  = \<alpha> \<cdot> f\<^sub>m (\<zero> \<cdot> \<one>) \<and>\<^sub>s \<alpha> \<cdot> f\<^sub>m (\<one> \<cdot> \<zero>)" \<alpha> \<alpha>], unfold mv_bcm.morph)
+  (use mv_bcm.bin_not_comp_suf in argo, simp)   
+
+lemma bin_lcp_shift: assumes "\<^bold>|\<alpha>\<^bold>| < \<^bold>|f w\<^bold>|" shows "(f w)!\<^bold>|\<alpha>\<^bold>| = hd (f\<^sub>m w)"
+proof-
+  have "w \<noteq> \<epsilon>" 
+    using assms emp_to_emp  by fastforce 
+  hence "f\<^sub>m w \<noteq> \<epsilon>"
+    using marked_version_all_nemp by blast
+  show ?thesis
+    using pref_index[of "f w" "\<alpha>\<cdot> f\<^sub>m w" "\<^bold>|\<alpha>\<^bold>|", OF prefI[of "f w" \<alpha> " \<alpha> \<cdot> f\<^sub>m w", OF marked_version_conjugates[of w, symmetric]], OF assms]
+    unfolding nth_append_length_plus[of \<alpha> "f\<^sub>m w" 0, unfolded add_0_right] hd_conv_nth[of "f\<^sub>m w", symmetric, OF \<open>f\<^sub>m w \<noteq> \<epsilon>\<close>]. 
+qed
+
+lemma mismatch_fst: "hd (f\<^sub>m \<zero>) = c\<^sub>0"
+proof-
+  have "(f [bin0,bin1])!\<^bold>|\<alpha>\<^bold>| = hd (f\<^sub>m [bin0,bin1])" 
+    using bin_lcp_shift[of "[bin0,bin1]", unfolded pop_hd[of bin0 \<one>]  lenmorph, OF bin_lcp_short]
+    unfolding pop_hd[of bin0 \<one>].
+  from this[unfolded  mv_bcm.pop_hd[of bin0 \<one>, unfolded not_Cons_self2[of bin0 \<epsilon>]] hd_append2[OF mv_bcm.bin_fst_nemp, of "f\<^sub>m \<one>"], symmetric]
+  show ?thesis 
+    unfolding bin_mismatch_def hd_word[of bin0 \<one>] morph.
+qed
+
+lemma mismatch_snd: "hd (f\<^sub>m \<one>) = c\<^sub>1"
+proof-
+  have "(f [bin1,bin0])!\<^bold>|\<alpha>\<^bold>| = hd (f\<^sub>m [bin1,bin0])" 
+    using bin_lcp_shift[of "[bin1,bin0]", unfolded pop_hd[of bin1 \<zero>]  lenmorph, OF bin_lcp_short[unfolded add.commute[of "\<^bold>|f \<zero>\<^bold>|"  "\<^bold>|f \<one>\<^bold>|"]]]
+    unfolding pop_hd[of bin1 \<zero>].
+  from this[unfolded  mv_bcm.pop_hd[of bin1 \<zero>, unfolded not_Cons_self2[of bin1 \<epsilon>]] hd_append2[OF mv_bcm.bin_snd_nemp, of "f\<^sub>m \<zero>"],symmetric]
+  show ?thesis 
+    unfolding bin_mismatch_def hd_word[of bin1 \<zero>] morph bin_lcp_sym[of "f \<zero>"].
+qed
+
+lemma marked_hd_neq: "hd (f\<^sub>m [a]) \<noteq> hd (f\<^sub>m [1-a])" (is "?P (a :: binA)")
+    by (rule bin_induct[of ?P, unfolded binsimp])
+    (use mismatch_fst mismatch_snd bin_mismatch_neq in presburger)+
+
+lemma marked_version_marked_morph: "marked_morphism f\<^sub>m"
+  by (standard, unfold core_def)
+  (use  not_swap_eq[of "\<lambda> a b. hd (f\<^sub>m [a]) = hd (f\<^sub>m [b])", OF _ marked_hd_neq] in force)
+
+interpretation mv_mbm: marked_binary_morphism f\<^sub>m
+  using  marked_version_marked_morph
+  by (simp add: marked_binary_morphism_def)
+
+lemma mismatch_pref0: "[c\<^sub>0] \<le>p f\<^sub>m \<zero>"
+  using  mv_bcm.sing_to_nemp[THEN hd_pref, of bin0] unfolding mismatch_fst.
+
+lemma mismatch_pref1: "[c\<^sub>1] \<le>p f\<^sub>m \<one>"
+  using mv_bcm.bin_snd_nemp[THEN hd_pref] unfolding mismatch_snd.
+
+lemma marked_version_len: "\<^bold>|f\<^sub>m w\<^bold>| = \<^bold>|f w\<^bold>|"
+  using   add_left_imp_eq[OF  
+      lenmorph[of \<alpha> "f\<^sub>m w", unfolded lenmorph[of "f w" \<alpha>, folded marked_version_conjugates[of w]],symmetric,
+        unfolded  add.commute[of "\<^bold>|f w\<^bold>|" "\<^bold>|\<alpha>\<^bold>|"]]]. 
+
+lemma bin_code_lcp: "(f r \<cdot> \<alpha>) \<and>\<^sub>p (f s \<cdot> \<alpha>) = f (r \<and>\<^sub>p s) \<cdot> \<alpha>"
+  by (metis lcp_ext_left marked_version_conjugates mv_mbm.marked_morph_lcp) 
+
+lemma  not_comp_lcp: assumes "\<not> r \<bowtie> s"
+  shows "f (r \<and>\<^sub>p s) \<cdot> \<alpha> = f r \<cdot> f (r \<cdot> s) \<and>\<^sub>p f s \<cdot> f (r \<cdot> s)"
+proof-
+  let ?r' = "(r \<and>\<^sub>p s)\<inverse>\<^sup>>r"
+  let ?s' = "(r \<and>\<^sub>p s)\<inverse>\<^sup>>s"
+  from lcp_mismatch_lq[OF \<open>\<not> r \<bowtie>  s\<close>] 
+  have "?r' \<noteq> \<epsilon>" and "?s' \<noteq> \<epsilon>" and "hd ?r' \<noteq> hd ?s'".
+  have "\<not> f ((r \<and>\<^sub>p s) \<cdot> [hd ?r'] \<cdot> tl ?r') \<cdot> \<alpha> \<bowtie> f ((r \<and>\<^sub>p s) \<cdot> [hd ?s'] \<cdot> tl ?s') \<cdot> \<alpha>"
+    using  bin_mismatch_swap_not_comp
+    unfolding morph prefix_comparable_def rassoc pref_cancel_conv
+             \<open>hd ?r' \<noteq> hd ?s'\<close>[symmetric, unfolded bin_neq_iff'].
+  hence "\<not> f r \<cdot> \<alpha> \<bowtie> f s \<cdot> \<alpha>"
+    unfolding hd_tl[OF \<open>?r' \<noteq> \<epsilon>\<close>] hd_tl[OF \<open>?s' \<noteq> \<epsilon>\<close>] lcp_lq.
+  have pref: "f w \<cdot> \<alpha> \<le>p  f w \<cdot> f (r \<cdot> s)" for w
+    unfolding pref_cancel_conv 
+    using append_prefixD[OF not_comp_bin_lcp_pref, OF \<open>\<not> r \<bowtie> s\<close>]  by blast
+  from prefE[OF pref[of r], unfolded rassoc]
+  obtain gr' where gr': "f r \<cdot> f (r \<cdot> s) = f r \<cdot> \<alpha> \<cdot> gr'".  
+  from prefE[OF pref[of s], unfolded rassoc]
+  obtain gs' where gs': "f s \<cdot> f (r \<cdot> s) = f s \<cdot> \<alpha> \<cdot> gs'".  
+  thus "f (r \<and>\<^sub>p s) \<cdot> \<alpha> = f r \<cdot> f (r \<cdot> s) \<and>\<^sub>p f s \<cdot> f (r \<cdot> s)"
+    unfolding bin_code_lcp[symmetric, of r s] pref_def using \<open>\<not> f r \<cdot> \<alpha> \<bowtie> f s \<cdot> \<alpha>\<close> 
+     lcp_ext_right[of "f r \<cdot> \<alpha>" "f s \<cdot> \<alpha>" _  gr' gs', unfolded rassoc, folded gr' gs'] by argo   
+qed
+
+lemma bin_morph_pref_conv: "f u \<cdot> \<alpha> \<le>p f v \<cdot> \<alpha> \<longleftrightarrow> u \<le>p v"
+proof 
+  assume "u \<le>p v"
+  from this[unfolded prefix_def] 
+  obtain z where "v = u \<cdot> z" by blast 
+  show "f u \<cdot> \<alpha> \<le>p f v \<cdot> \<alpha>"
+    unfolding arg_cong[OF \<open>v = u \<cdot> z\<close>, of f, unfolded morph] rassoc pref_cancel_conv using bin_lcp_pref_all.
+next
+  assume "f u \<cdot> \<alpha> \<le>p f v \<cdot> \<alpha>"
+  then show "u \<le>p v"
+  unfolding marked_version_conjugates[symmetric] prefix_comparable_def pref_cancel_conv
+  using mv_mbm.marked_bin_morph_pref_code by meson
+qed
+
+lemma bin_morph_compare_conv: "f u \<cdot> \<alpha> \<bowtie> f v \<cdot> \<alpha> \<longleftrightarrow> u \<bowtie> v"
+  using bin_morph_pref_conv unfolding prefix_comparable_def by auto
+
+lemma code_lcp': "\<not> r \<bowtie> s \<Longrightarrow> \<alpha> \<le>p f z \<Longrightarrow> \<alpha> \<le>p f z' \<Longrightarrow> f (r \<cdot> z) \<and>\<^sub>p f (s \<cdot> z') = f (r \<and>\<^sub>p s) \<cdot> \<alpha>"
+proof-
+  assume "\<alpha> \<le>p f z" "\<alpha> \<le>p f z'" "\<not> r \<bowtie> s"
+  hence eqs: "f (r \<cdot> z) = (f r \<cdot> \<alpha>) \<cdot> (\<alpha>\<inverse>\<^sup>>f z)"  "f (s \<cdot> z') = (f s \<cdot> \<alpha>) \<cdot> (\<alpha>\<inverse>\<^sup>>f z')"
+    unfolding rassoc by (metis lq_pref morph)+
+  show ?thesis
+    using bin_morph_compare_conv  \<open>\<not> r \<bowtie> s\<close> bin_code_lcp lcp_ext_right unfolding eqs 
+    by metis
+qed
+
+lemma pref_im_pref: "r \<le>p s \<Longrightarrow> f r \<cdot> \<alpha> \<le>p f s \<cdot> \<alpha>"
+  using marked_version_conjugates
+  by (metis bin_code_lcp lcp_pref_conv)
+
+lemma per_comp:
+  assumes "r \<le>p (f w)\<^sup>\<omega>"
+  shows "r \<bowtie> f w \<cdot> \<alpha>"
+proof-
+  obtain n where "r \<le>p f w\<^sup>@Suc n \<cdot> \<alpha>" 
+    using per_pref_ex[OF assms] pref_trans prefix_def
+      pref_pow_ext by metis    
+  from ruler[OF this, folded pow_morph, OF pref_im_pref]
+  show ?thesis
+    unfolding prefix_comparable_def pow_Suc by simp
+qed 
+
+end
+
+section \<open>Two binary morphisms\<close>
+
+locale two_binary_morphisms = two_morphisms g h
+  for g h :: "binA list \<Rightarrow> 'a list"
+begin
+
+lemma rev_morphs: "two_binary_morphisms (rev_map g) (rev_map h)"
+  using rev_maps by (intro two_binary_morphisms.intro)
+
+lemma solution_UNIV:
+  assumes "s \<noteq> \<epsilon>" and "g s = h s" and "\<And>a. g [a] \<noteq> h [a]"
+  shows "set s = UNIV"
+proof (rule ccontr, elim not_UNIV_E unique_letter_wordE'')
+  fix a k assume *: "s = [a] \<^sup>@ k"
+  then have "k \<noteq> 0" using \<open>s \<noteq> \<epsilon>\<close> by (intro notI) simp
+  have "g [a] = h [a]" using \<open>g s = h s\<close> unfolding * g.pow_morph h.pow_morph
+    by (fact pow_eq_eq[OF _ \<open>k \<noteq> 0\<close>])
+  then show False using \<open>g [a] \<noteq> h [a]\<close> by contradiction
+qed
+
+lemma solution_len_im_sing_less:
+  assumes sol: "g s = h s" and set: "a \<in> set s" and less: "\<^bold>|g [a]\<^bold>| < \<^bold>|h [a]\<^bold>|"
+  shows "\<^bold>|h [1-a]\<^bold>| < \<^bold>|g [1-a]\<^bold>|"
+proof (intro not_le_imp_less notI)
+  assume "\<^bold>|g [1-a]\<^bold>| \<le> \<^bold>|h [1-a]\<^bold>|"
+  with less_imp_le[OF less] have "\<^bold>|g [b]\<^bold>| \<le> \<^bold>|h [b]\<^bold>|" for b
+    by (fact bin_swap_induct)
+  from this set less
+  have "\<^bold>|g s\<^bold>| < \<^bold>|h s\<^bold>|" by (rule len_im_less[of s])
+  then show False using lenarg[OF sol] by simp
+qed
+
+lemma solution_len_im_sing_le:
+  assumes sol: "g s = h s" and set: "set s = UNIV" and less: "\<^bold>|g [a]\<^bold>| \<le> \<^bold>|h [a]\<^bold>|"
+  shows "\<^bold>|h [1-a]\<^bold>| \<le> \<^bold>|g [1-a]\<^bold>|"
+proof (intro leI notI)
+  assume "\<^bold>|g [1-a]\<^bold>| < \<^bold>|h [1-a]\<^bold>|"
+  from solution_len_im_sing_less[OF sol _ this]
+  have "\<^bold>|h [a]\<^bold>| < \<^bold>|g [a]\<^bold>|" unfolding set binsimp by blast
+  then show False using \<open>\<^bold>|g [a]\<^bold>| \<le> \<^bold>|h [a]\<^bold>|\<close> by simp
+qed
+
+lemma solution_sing_len_cases: 
+  assumes set: "set s = UNIV" and sol: "g s = h s" and "g \<noteq> h"
+  obtains a where "\<^bold>|g [a]\<^bold>| < \<^bold>|h [a]\<^bold>|" and "\<^bold>|h [1-a]\<^bold>| < \<^bold>|g [1-a]\<^bold>|"
+proof (cases rule: linorder_cases)
+  show "\<^bold>|g [hd s]\<^bold>| < \<^bold>|h [hd s]\<^bold>| \<Longrightarrow> thesis"
+    using solution_len_im_sing_less[OF sol] that unfolding set by blast
+  interpret swap: two_binary_morphisms h g by unfold_locales
+  show "\<^bold>|h [hd s]\<^bold>| < \<^bold>|g [hd s]\<^bold>| \<Longrightarrow> thesis"
+    using swap.solution_len_im_sing_less[OF sol[symmetric]]
+      solution_len_im_sing_less[OF sol] that unfolding set by blast
+  have "s \<noteq> \<epsilon>" using set by auto
+  assume *: "\<^bold>|g [hd s]\<^bold>| = \<^bold>|h [hd s]\<^bold>|"
+  moreover have "\<^bold>|g [1 - (hd s)]\<^bold>| = \<^bold>|h [1 - (hd s)]\<^bold>|"
+  proof (rule ccontr, elim linorder_neqE)
+    show "\<^bold>|g [1 - (hd s)]\<^bold>| < \<^bold>|h [1 - (hd s)]\<^bold>| \<Longrightarrow> False"
+    using solution_len_im_sing_less[OF sol, of "1 - (hd s)"]
+    unfolding set binsimp * by blast
+  next
+    show "\<^bold>|h [1-(hd s)]\<^bold>| < \<^bold>|g [1-(hd s)]\<^bold>| \<Longrightarrow> False"
+    using swap.solution_len_im_sing_less[OF sol[symmetric], of "1 - (hd s)"]
+    unfolding set binsimp * by blast
+  qed
+  ultimately have "\<^bold>|g [a]\<^bold>| = \<^bold>|h [a]\<^bold>|" for a by (fact bin_swap_induct)
+  from def_on_sings[OF solution_eq_len_eq[OF sol this]]
+  show thesis unfolding set using \<open>g \<noteq> h\<close> by blast
+qed
+
+lemma len_ims_sing_neq:
+  assumes  "g s = h s" "g \<noteq> h" "set s = binUNIV"
+  shows  "\<^bold>|g [c]\<^bold>| \<noteq> \<^bold>|h [c]\<^bold>|"
+proof(rule solution_sing_len_cases[OF \<open>set s = binUNIV\<close> \<open>g s  = h s\<close> \<open>g \<noteq> h\<close>])
+  fix a  assume less: "\<^bold>|g [a]\<^bold>| < \<^bold>|h [a]\<^bold>|" "\<^bold>|h [1 - a]\<^bold>| < \<^bold>|g [1 - a]\<^bold>|"
+  show "\<^bold>|g [c]\<^bold>| \<noteq> \<^bold>|h [c]\<^bold>|" 
+    by (rule bin_swap_exhaust[of c a]) (use less in force)+
+qed
+
+end
+
+lemma two_bin_code_morphs_nonerasing_morphs: "binary_code_morphism g \<Longrightarrow> binary_code_morphism h \<Longrightarrow> two_nonerasing_morphisms g h"
+  by (simp add: binary_code_morphism.nonerasing binary_code_morphism_def code_morphism.axioms(1) nonerasing_morphism.intro nonerasing_morphism_axioms.intro two_morphisms_def two_nonerasing_morphisms.intro)
+
+section "Two binary code morphisms"
+
+locale  two_binary_code_morphisms = two_binary_morphisms +
+  g: binary_code_morphism g + 
+  h: binary_code_morphism h 
+
+begin
+
+notation  h.bin_code_lcp ("\<alpha>\<^sub>h")
+notation  g.bin_code_lcp ("\<alpha>\<^sub>g")
+notation "g.marked_version" ("g\<^sub>m") 
+notation "h.marked_version" ("h\<^sub>m") 
+
+sublocale marked: two_marked_morphisms g\<^sub>m h\<^sub>m
+proof-
+  interpret gm: marked_morphism g\<^sub>m
+    by (simp add: g.marked_version_marked_morph)
+  interpret hm: marked_morphism h\<^sub>m
+    by (simp add: h.marked_version_marked_morph)
+  show "two_marked_morphisms g\<^sub>m h\<^sub>m"
+    by unfold_locales
+qed
+
+sublocale code: two_code_morphisms g h
+  by unfold_locales
+
+lemma marked_two_binary_code_morphisms: "two_binary_code_morphisms g\<^sub>m h\<^sub>m" 
+      using g.marked_version_interpret_binary_code_morph h.marked_version_interpret_binary_code_morph
+    by unfold_locales
+
+lemma revs_two_binary_code_morphisms: "two_binary_code_morphisms (rev_map g) (rev_map h)"
+  using code.revs_two_code_morphisms rev_morphs 
+  by (simp add: g.bin_code_morph_rev_map h.bin_code_morph_rev_map rev_morphs two_binary_code_morphisms_def)
+
+lemma swap_two_binary_code_morphisms: "two_binary_code_morphisms h g"
+    by unfold_locales
+
+text\<open>Each successful overflow has a unique minimal successful continuation\<close>
+lemma  min_completionE:
+  assumes "z \<cdot> g\<^sub>m r = z' \<cdot> h\<^sub>m s"
+  obtains p q where "z \<cdot> g\<^sub>m p = z' \<cdot> h\<^sub>m q" and 
+    "\<And> r s. z \<cdot> g\<^sub>m r = z' \<cdot> h\<^sub>m s  \<Longrightarrow> p \<le>p r \<and> q \<le>p s"
+proof-
+  interpret swap: two_binary_code_morphisms h g
+    by unfold_locales
+  define P where "P = (\<lambda> m. \<exists> p q. z \<cdot> g\<^sub>m p = z' \<cdot> h\<^sub>m q \<and> \<^bold>|p\<^bold>| = m)"
+  have "P \<^bold>|r\<^bold>|" using assms P_def
+    by blast     
+  obtain n where ndef: "n = (LEAST m. P m)"
+    by simp 
+  then obtain p q where "z \<cdot> g\<^sub>m p = z' \<cdot> h\<^sub>m q" "\<^bold>|p\<^bold>| = n" using \<open>P \<^bold>|r\<^bold>|\<close>
+    using LeastI P_def by metis
+  have "p \<le>p r' \<and> q \<le>p s'" if "z \<cdot> g\<^sub>m r' = z' \<cdot> h\<^sub>m s'" for r' s' 
+  proof    
+    have "z \<cdot> g\<^sub>m (p \<and>\<^sub>p r') = z' \<cdot> h\<^sub>m (q \<and>\<^sub>p s')" 
+      using \<open>z \<cdot> g\<^sub>m p = z' \<cdot> h\<^sub>m q\<close> \<open>z \<cdot> g\<^sub>m r' = z' \<cdot> h\<^sub>m s'\<close>
+        marked.unique_continuation by blast
+    thus "p \<le>p r'"
+      using  P_def le_antisym \<open>\<^bold>|p\<^bold>| = n\<close> lcp_len' ndef not_less_Least 
+      by metis
+    from this[folded lcp_pref_conv]
+    have "h\<^sub>m q =  h\<^sub>m (q \<and>\<^sub>p s')"
+      using \<open>z \<cdot> g\<^sub>m (p \<and>\<^sub>p r') = z' \<cdot> h\<^sub>m (q \<and>\<^sub>p s')\<close> \<open>z \<cdot> g\<^sub>m p = z' \<cdot> h\<^sub>m q\<close> 
+      by force 
+    thus "q \<le>p s'" 
+      using marked.h.code_morph_code lcp_pref_conv by metis
+  qed
+  thus thesis
+    using \<open>z \<cdot> g\<^sub>m p = z' \<cdot> h\<^sub>m q\<close> that by blast 
+qed
+
+lemma two_equals:
+  assumes "g r = h r" and "g s = h s" and "\<not> r \<bowtie> s"
+  shows  "g (r \<and>\<^sub>p s) \<cdot> \<alpha>\<^sub>g = h (r \<and>\<^sub>p s) \<cdot> \<alpha>\<^sub>h"
+  unfolding g.not_comp_lcp[OF \<open>\<not> r \<bowtie> s\<close>] h.not_comp_lcp[OF \<open>\<not> r \<bowtie> s\<close>] g.morph h.morph assms.. 
+
+lemma solution_sing_len_diff: assumes "g \<noteq> h" and "g s = h s" and "set s = binUNIV"
+  shows "\<^bold>|g [c]\<^bold>| \<noteq> \<^bold>|h [c]\<^bold>|"
+proof (rule solution_sing_len_cases[OF \<open>set s = binUNIV\<close> \<open>g s = h s\<close> \<open>g \<noteq> h\<close>])
+  fix a  assume less: "\<^bold>|g [a]\<^bold>| < \<^bold>|h [a]\<^bold>|" "\<^bold>|h [1 - a]\<^bold>| < \<^bold>|g [1 - a]\<^bold>|"
+  show "\<^bold>|g [c]\<^bold>| \<noteq> \<^bold>|h [c]\<^bold>|" 
+    by (rule bin_swap_exhaust[of c a]) (use less in force)+
+qed
+
+lemma  alphas_pref: assumes "\<^bold>|\<alpha>\<^sub>h\<^bold>| \<le> \<^bold>|\<alpha>\<^sub>g\<^bold>|" and "g r =\<^sub>m h s" shows "\<alpha>\<^sub>h \<le>p \<alpha>\<^sub>g"
+proof-
+  have "h s \<noteq> \<epsilon>"
+    using  h.nemp_to_nemp min_coinD'[OF \<open>g r =\<^sub>m h s\<close>] by force 
+  from
+    root_ruler[OF h.bin_lcp_pref_all[of s] g.bin_lcp_pref_all[of r, folded min_coinD[OF \<open>g r =\<^sub>m h s\<close>, symmetric]] this]
+  show "\<alpha>\<^sub>h \<le>p \<alpha>\<^sub>g"
+    unfolding prefix_comparable_def using ruler_le[OF self_pref _ assms(1)] by blast
+qed
+
+
+end
+
+section \<open>Two marked binary morphisms with blocks\<close>
+
+locale two_binary_marked_morphisms = two_marked_morphisms g h
+  for g h :: "binA list \<Rightarrow> 'a list"
+begin
+
+sublocale g: marked_binary_morphism g
+  by (simp add: g.marked_morphism_axioms marked_binary_morphism_def)
+
+sublocale h: marked_binary_morphism h
+  by (simp add: h.marked_morphism_axioms marked_binary_morphism_def)
+
+sublocale two_binary_code_morphisms g h
+  by unfold_locales
+
+sublocale revs: two_binary_code_morphisms "rev_map g"  "rev_map h"
+  using revs_two_binary_code_morphisms. 
+
+end
+
+locale two_binary_marked_blocks = two_binary_marked_morphisms +
+  assumes both_blocks: "\<And> a. blockP a"
+
+begin
+ 
+sublocale sucs: two_binary_marked_morphisms suc_fst suc_snd 
+  using  sucs_marked_morphs[OF both_blocks, folded two_binary_marked_morphisms_def].
+
+lemma bin_blocks_swap: "two_binary_marked_blocks h g"
+proof (unfold_locales)
+  fix a
+  obtain c where "hd (suc_snd [c]) = a"  
+    using bin_marked_preimg_hd[of suc_snd]
+      marked_binary_morphism_def sucs.h.marked_morphism_axioms by blast 
+  show "two_marked_morphisms.blockP h g a" 
+  proof (rule two_marked_morphisms.blockI, unfold_locales)
+    show "hd (suc_snd [c]) = a" by fact
+    show "h (suc_snd [c]) =\<^sub>m g (suc_fst [c])"
+      using min_coin_sym[OF blockP_D[OF both_blocks]].
+  qed
+qed
+
+lemma blocks_all_letters_fst: "[b] \<le>f suc_fst ([a] \<cdot> [1-a])"
+proof-
+  have *: "suc_fst ([a] \<cdot> [1 - a]) = [a] \<cdot> tl (suc_fst [a]) \<cdot> [1-a] \<cdot> tl (suc_fst [1 - a])"
+    unfolding sucs.g.morph lassoc hd_tl[OF sucs.g.sing_to_nemp, unfolded blockP_D_hd[OF both_blocks]]..
+  show ?thesis
+    by (cases rule: neq_exhaust[OF bin_swap_neq, of b a], unfold *)
+      (blast+) 
+qed     
+
+lemma blocks_all_letters_snd: "[b] \<le>f suc_snd ([a] \<cdot> [1-a])"
+proof-
+  have *: "suc_snd ([a] \<cdot> [1 - a]) = [hd (suc_snd [a])] \<cdot> tl (suc_snd [a]) \<cdot> [hd (suc_snd [1-a])] \<cdot> tl (suc_snd [1-a])"
+    unfolding sucs.h.morph rassoc hd_tl[OF sucs.h.sing_to_nemp, unfolded blockP_D_hd[OF both_blocks]]  
+    unfolding  lassoc hd_tl[OF sucs.h.sing_to_nemp, unfolded blockP_D_hd[OF both_blocks]]..  
+  show ?thesis
+    by (cases rule: neq_exhaust[OF sucs.h.bin_marked_sing, of b a], unfold *) 
+      (blast+)
+qed      
+
+lemma lcs_suf_blocks_fst: "g.bin_code_lcs \<le>s g (suc_fst ([a] \<cdot> [1-a]))"
+  using revs.g.bin_lcp_pref''[reversed] g.bin_lcp_pref'' blocks_all_letters_fst by simp
+
+lemma lcs_suf_blocks_snd: "h.bin_code_lcs \<le>s h (suc_snd ([a] \<cdot> [1-a]))"
+  using revs.h.bin_lcp_pref''[reversed] h.bin_lcp_pref'' blocks_all_letters_snd by simp
+
+lemma lcs_fst_suf_snd: "g.bin_code_lcs \<le>s h.bin_code_lcs \<cdot> h  sucs.h.bin_code_lcs" 
+proof-
+  have "g.bin_code_lcs \<le>s g (suc_fst [a] \<cdot> suc_fst [1-a])" for a
+    using lcs_suf_blocks_fst[of a]
+    unfolding binsimp sucs.g.morph.
+  have "g.bin_code_lcs \<le>s g (suc_fst \<zero> \<cdot> suc_fst \<one>)" and "g.bin_code_lcs \<le>s g (suc_fst \<one> \<cdot> suc_fst \<zero>)" 
+    using lcs_suf_blocks_fst[of bin0] lcs_suf_blocks_fst[of bin1]
+    unfolding binsimp sucs.g.morph. 
+  hence "g.bin_code_lcs \<le>s h (suc_snd \<zero> \<cdot> suc_snd \<one>)" and "g.bin_code_lcs \<le>s h (suc_snd \<one> \<cdot> suc_snd \<zero>)"
+    unfolding g.morph h.morph  block_eq[OF both_blocks].
+  from suf_ext[OF this(1)] suf_ext[OF this(2)]
+  have "g.bin_code_lcs \<le>s h.bin_code_lcs \<cdot> h (suc_snd \<zero> \<cdot> suc_snd \<one>)" and "g.bin_code_lcs \<le>s h.bin_code_lcs \<cdot> h (suc_snd \<one> \<cdot> suc_snd \<zero>)".
+  hence "g.bin_code_lcs \<le>s h.bin_code_lcs \<cdot> h (suc_snd \<zero> \<cdot> suc_snd \<one>) \<and>\<^sub>s h.bin_code_lcs \<cdot> h (suc_snd \<one> \<cdot> suc_snd \<zero>)"
+    using suf_lcs_iff by blast 
+  thus "g.bin_code_lcs \<le>s h.bin_code_lcs \<cdot> h sucs.h.bin_code_lcs"
+    unfolding  revs.h.bin_code_lcp[reversed] bin_lcs_def[symmetric].
+qed
+
+lemma suf_comp_lcs: "g.bin_code_lcs \<bowtie>\<^sub>s h.bin_code_lcs"
+  using lcs_suf_blocks_fst lcs_suf_blocks_snd
+  unfolding  g.morph h.morph sucs.g.morph sucs.h.morph  block_eq[OF both_blocks] suf_comp_or using ruler[reversed] by blast 
+
+end
+
+end
diff --git a/thys/Combinatorics_Words/Border_Array.thy b/thys/Combinatorics_Words/Border_Array.thy
new file mode 100644
--- /dev/null
+++ b/thys/Combinatorics_Words/Border_Array.thy
@@ -0,0 +1,567 @@
+(*  Title:      Border Array
+    File:       CoW.Border_Array
+    Author:     Štěpán Holub, Charles University
+
+Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/
+*)
+
+theory Border_Array
+
+imports
+ CoWBasic
+
+begin
+
+
+subsection \<open>Auxiliary lemmas on suffix and border extension\<close>
+
+lemma border_ConsD: assumes "b#x \<le>b a#w" 
+  shows "a = b" and 
+        "x \<noteq> \<epsilon> \<Longrightarrow> x \<le>b w" and 
+        border_ConsD_neq: "x \<noteq> w" and
+        border_ConsD_pref: "x \<le>p w" and
+        border_ConsD_suf: "x \<le>s w"
+proof-
+  show "a = b"
+    using borderD_pref[OF assms] by force
+  show "x \<noteq> w" and "x \<le>p w" and "x \<le>s w"
+    using borderD_neq[OF assms, unfolded \<open>a = b\<close>]
+      borderD_pref[OF assms, unfolded Cons_prefix_Cons]
+      suffix_ConsD2[OF borderD_suf[OF assms]] by force+
+  thus "x \<noteq> \<epsilon> \<Longrightarrow> x \<le>b w"
+    unfolding border_def  by blast
+qed
+
+lemma ext_suf_Cons:
+  "Suc i + \<^bold>|u\<^bold>| = \<^bold>|w\<^bold>| \<Longrightarrow> u \<le>s w \<Longrightarrow> (w!i)#u \<le>s (w!i)#w"
+proof-
+  assume "Suc i + \<^bold>|u\<^bold>| = \<^bold>|w\<^bold>|" and "u \<le>s w"
+  hence "u = drop (Suc i) w"
+    unfolding suf_def using \<open>Suc i + \<^bold>|u\<^bold>| = \<^bold>|w\<^bold>|\<close> by auto 
+  have "i < \<^bold>|w\<^bold>|"
+    using \<open>Suc i + \<^bold>|u\<^bold>| = \<^bold>|w\<^bold>|\<close> by auto
+  from id_take_nth_drop[OF this, folded \<open>u = drop (Suc i) w\<close>]
+  show "w ! i # u \<le>s w ! i # w"
+    using suffix_ConsI triv_suf by metis
+qed
+
+
+lemma ext_suf_Cons_take_drop: assumes "take k (drop (Suc i) w) \<le>s drop (Suc i) w" and "w ! i = w ! (\<^bold>|w\<^bold>| - Suc k)"
+  shows "take (Suc k) (drop i w) \<le>s drop i w"
+proof (cases "(Suc k) + i < \<^bold>|w\<^bold>|", simp_all)
+  assume "Suc (k + i) < \<^bold>|w\<^bold>|"
+
+  hence "i < \<^bold>|w\<^bold>|"
+    by simp
+
+  have "Suc (\<^bold>|w\<^bold>| - Suc i - Suc k) = \<^bold>|w\<^bold>| - Suc(i+k)"
+    using Suc_diff_Suc \<open>Suc (k + i) < \<^bold>|w\<^bold>|\<close>
+    by (simp add: Suc_diff_Suc)
+
+  have "\<^bold>|take k (drop (Suc i) w)\<^bold>| = k"
+    using \<open>Suc (k + i) < \<^bold>|w\<^bold>|\<close> by fastforce
+
+  have "Suc (\<^bold>|w\<^bold>| - Suc i - Suc k) + \<^bold>|take k (drop (Suc i) w)\<^bold>| = \<^bold>|drop (Suc i) w\<^bold>|"
+    unfolding \<open>\<^bold>|take k (drop (Suc i) w)\<^bold>| = k\<close> \<open>Suc (\<^bold>|w\<^bold>| - Suc i - Suc k) = \<^bold>|w\<^bold>| - Suc(i+k)\<close>
+    using  \<open>Suc (k + i) < \<^bold>|w\<^bold>|\<close> by simp
+
+  hence "\<^bold>|drop (Suc (\<^bold>|w\<^bold>| - Suc i - k)) (drop i w)\<^bold>| = k"
+    using  \<open>i < \<^bold>|w\<^bold>|\<close> by fastforce
+  have "\<^bold>|w\<^bold>| - Suc i - k < \<^bold>|drop i w\<^bold>|"
+    by (metis Suc_diff_Suc \<open>i < \<^bold>|w\<^bold>|\<close> diff_less_Suc length_drop)
+
+  have "(drop i w)!(\<^bold>|w\<^bold>| - Suc i - k) = w ! i"
+    using \<open>Suc (k + i) < \<^bold>|w\<^bold>|\<close> \<open>w ! i = w ! (\<^bold>|w\<^bold>| - Suc k)\<close> by auto
+
+  have "take (Suc k) (drop i w) = w!i#take k (drop (Suc i) w)"
+    using Cons_nth_drop_Suc[OF \<open>i < \<^bold>|w\<^bold>|\<close>] take_Suc_Cons[of k "w!i" "drop (Suc i) w"] by argo
+
+  have "drop (Suc (\<^bold>|w\<^bold>| - Suc i - k)) (drop i w) = drop (\<^bold>|w\<^bold>| - Suc i - k) (drop (Suc i) w)"
+    by auto
+  hence "drop (Suc (\<^bold>|w\<^bold>| - Suc i - k)) (drop i w) = take k (drop (Suc i) w)"
+    using \<open>\<^bold>|take k (drop (Suc i) w)\<^bold>| = k\<close>
+      \<open>take k (drop (Suc i) w) \<le>s drop (Suc i) w\<close> suf_drop_conv length_drop by metis
+
+  with
+    id_take_nth_drop[OF \<open>\<^bold>|w\<^bold>| - Suc i - k < \<^bold>|drop i w\<^bold>|\<close>]
+  show ?thesis
+    unfolding \<open>(drop i w)!(\<^bold>|w\<^bold>| - Suc i - k) = w ! i\<close>
+      \<open>take (Suc k) (drop i w) = w!i#take k (drop (Suc i) w)\<close>
+    unfolding suf_def by auto
+qed
+
+lemma ext_border_Cons:
+  "Suc i + \<^bold>|u\<^bold>| = \<^bold>|w\<^bold>| \<Longrightarrow> u \<le>b w \<Longrightarrow> (w!i)#u \<le>b (w!i)#w"
+  unfolding border_def using ext_suf_Cons Cons_prefix_Cons list.discI list.inject by metis
+
+lemma border_add_Cons_len: assumes "max_borderP u w" and "v \<le>b (a#w)" shows "\<^bold>|v\<^bold>| \<le> Suc \<^bold>|u\<^bold>|"
+proof-
+  have "v \<noteq> \<epsilon>"
+    using \<open>v \<le>b (a#w)\<close> by simp
+  then obtain v' where "v = a#v'"
+    using  borderD_pref[OF \<open>v \<le>b (a#w)\<close>, unfolded prefix_Cons] by blast
+  show "\<^bold>|v\<^bold>| \<le> Suc \<^bold>|u\<^bold>|"
+  proof (cases "v' = \<epsilon>", simp add: \<open>v = a#v'\<close>)
+    assume "v' \<noteq> \<epsilon>"
+    have "w \<noteq> \<epsilon>"
+      using  borderedI[OF \<open>v \<le>b (a#w)\<close>] sing_not_bordered[of a] by blast
+    have "v' \<le>b w"
+      using border_ConsD(2)[OF \<open>v \<le>b (a#w)\<close>[unfolded \<open>v = a # v'\<close>] \<open>v' \<noteq> \<epsilon>\<close>].
+    thus "\<^bold>|v\<^bold>| \<le> Suc \<^bold>|u\<^bold>|"
+      unfolding \<open>v = a # v'\<close> length_Cons Suc_le_mono
+      using \<open>max_borderP u w\<close>[unfolded max_borderP_def]
+        prefix_length_le by blast
+  qed
+qed
+
+section \<open>Computing the Border Array\<close>
+
+text\<open>The computation is a special case of the Knuth-Morris-Pratt algorithm.\<close>
+
+text\<open>
+\<^item> KMP w arr bord pos
+\<^item> w: processed word does not change; it is processed starting from the last letter
+\<^item> pos: actually examined pos-th letter; that is, it is w!(pos-1)
+\<^item> arr: already calculated suffix-border-array of w;
+       that is, the length of array is (|w| - pos) 
+       and arr!(|w| - pos - bord) is the max border length of the suffix of w of length bord
+\<^item> bord: length of the current max border length candidate
+       to see whether it can be extended we compare: w!(pos-1) ?= w!(|w| - (Suc bord));
+       (Suc bord) is the length of the max border if the comparison is succesful
+\<^item>      if the comparison fails we move to the max border of the suffix of length bord; 
+       its max border length is stored in arr!(|w| - pos - bord)
+\<^item>      if bord was 0 and the comparison failed, the word is unbordered  
+\<close>
+
+fun   KMP_arr :: "'a list \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat list"
+  and KMP_bord :: "'a list \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"  
+  and KMP_pos :: "'a list \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat"  
+  where
+    "KMP_arr _ arr _ 0 = arr" |
+    "KMP_bord _ _ bord 0 = bord" |
+    "KMP_pos _ _ _ 0 = 0" |
+    "KMP_arr w arr bord (Suc i) = 
+          (if w!i = w!(\<^bold>|w\<^bold>| - (Suc bord)) 
+          then  (Suc bord) # arr 
+          else (if bord = 0
+                then  0#arr
+                else (if (arr!(\<^bold>|w\<^bold>| - (Suc i) - bord)) < bord
+                      then arr 
+                      else  undefined#arr \<comment> \<open>else: dummy termination condition\<close>
+                      )  
+                ) 
+          )" |
+    "KMP_bord w arr bord (Suc i) = 
+          (if w!i = w!(\<^bold>|w\<^bold>| - (Suc bord)) 
+          then Suc bord
+          else (if bord = 0
+                 then  0
+                 else (if (arr!(\<^bold>|w\<^bold>| - (Suc i) - bord)) < bord
+                       then arr!(\<^bold>|w\<^bold>| - (Suc i) - bord) 
+                       else  0 \<comment> \<open>else: dummy termination condition\<close>
+                      )  
+                 ) 
+          )" |
+    "KMP_pos w arr bord (Suc i) = 
+          (if w!i = w!(\<^bold>|w\<^bold>| - (Suc bord)) 
+          then i
+          else (if bord = 0
+                 then  i
+                 else (if (arr!(\<^bold>|w\<^bold>| - (Suc i) - bord)) < bord
+                       then Suc i 
+                       else  i \<comment> \<open>else: dummy termination condition\<close>
+                      )  
+                 ) 
+          )" 
+
+function KMP :: "'a list \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat list" where
+  "KMP w arr bord 0 = arr"  |
+  "KMP w arr bord (Suc i) = KMP w (KMP_arr w arr bord (Suc i)) (KMP_bord w arr bord (Suc i)) (KMP_pos w arr bord (Suc i))" 
+  using not0_implies_Suc by (force+)
+termination 
+  by (relation "measures [\<lambda>(_, _ , compar, pos). pos,\<lambda>(_, _ , compar, pos). compar]", simp_all)
+
+lemma KMP_len: "\<^bold>|KMP w arr bord pos\<^bold>| = \<^bold>|arr\<^bold>| + pos"
+proof (induct rule: KMP.induct[of "\<lambda> w arr bord pos. \<^bold>|KMP w arr bord pos\<^bold>| = \<^bold>|arr\<^bold>| + pos"], simp)
+  case (2 w arr bord i)
+  then show ?case using KMP.simps(2)[of w arr bord i] by force
+qed
+
+value[nbe] "KMP [a] [0] 0 0"
+
+value "KMP [ 0::nat] [0] 0 0"
+value "KMP [5,4::nat,5,3,5,5] [0] 0 5"
+value "KMP [5,4::nat,5,3,5,5] [1,0] 1 4"
+value "KMP [0,1,1,0::nat,0,0,1,1,1] [0] 0 8"
+value "KMP [0::nat,1] [0] 0 1"
+
+subsection \<open>Verification of the computation\<close>
+
+definition KMP_valid :: "'a list \<Rightarrow> nat list \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> bool"
+  where "KMP_valid w arr bord pos = (\<^bold>|arr\<^bold>| + pos = \<^bold>|w\<^bold>|  \<and>
+                                    \<comment> \<open>bord is the length of a border of (drop pos w), or 0\<close>    
+                                    pos + bord < \<^bold>|w\<^bold>| \<and> 
+                                    take bord (drop pos w) \<le>p (drop pos w) \<and>
+                                    take bord (drop pos w) \<le>s (drop pos w) \<and>  
+                                    \<comment> \<open>... and no longer border can be extended\<close>
+                                    (\<forall> v. v \<le>b w!(pos - 1)#(drop pos w) \<longrightarrow> \<^bold>|v\<^bold>| \<le> Suc bord) \<and>  
+                                    \<comment> \<open>the array gives maximal border lengths of corresponding suffixes\<close>   
+                                    (\<forall> k < \<^bold>|arr\<^bold>|. max_borderP (take (arr!k) (drop (pos + k) w)) (drop (pos + k) w))
+                                    )"
+
+lemma " KMP_valid w arr bord pos  \<Longrightarrow> w \<noteq> \<epsilon>"
+  unfolding KMP_valid_def
+  using le_antisym less_imp_le_nat less_not_refl2 take_Nil take_all_iff by metis
+
+lemma KMP_valid_base: assumes "w \<noteq> \<epsilon>" shows "KMP_valid w [0] 0 (\<^bold>|w\<^bold>|-1)"
+proof (unfold KMP_valid_def, intro conjI) 
+  show "\<^bold>|[0]\<^bold>| + (\<^bold>|w\<^bold>| - 1) = \<^bold>|w\<^bold>|"
+    by (simp add: assms)
+  show "\<^bold>|w\<^bold>| - 1 + 0 < \<^bold>|w\<^bold>|"
+    using \<open>w \<noteq> \<epsilon>\<close>  by simp
+  show "take 0 (drop (\<^bold>|w\<^bold>| - 1) w) \<le>p drop (\<^bold>|w\<^bold>| - 1) w"
+    by simp
+  show "take 0 (drop (\<^bold>|w\<^bold>| - 1) w) \<le>s drop (\<^bold>|w\<^bold>| - 1) w"
+    by simp
+  show "\<forall>v. v \<le>b w ! (\<^bold>|w\<^bold>| - 1 - 1) # drop (\<^bold>|w\<^bold>| - 1) w \<longrightarrow> \<^bold>|v\<^bold>| \<le> Suc 0"
+  proof (rule allI, rule impI)
+     fix v assume b: "v \<le>b w ! (\<^bold>|w\<^bold>| - 1 - 1) # drop (\<^bold>|w\<^bold>| - 1) w"
+    have "\<^bold>|w ! (\<^bold>|w\<^bold>| - 1 - 1) # drop (\<^bold>|w\<^bold>| - 1) w\<^bold>| = Suc (Suc 0)"
+      using \<open>\<^bold>|[0]\<^bold>| + (\<^bold>|w\<^bold>| - 1) = \<^bold>|w\<^bold>|\<close> by auto
+    from border_len(3)[OF b, unfolded this]
+    show "\<^bold>|v\<^bold>| \<le> Suc 0"
+      using border_len(3)[OF b] by simp
+  qed
+  have  "\<^bold>|w\<^bold>| - Suc 0 = \<^bold>|butlast w\<^bold>|"
+    by simp
+  have "butlast w \<cdot> [last w] = w"
+    by (simp add: assms)
+  hence last:  "drop (\<^bold>|w\<^bold>| - Suc 0) w = [last w]"
+    unfolding \<open>\<^bold>|w\<^bold>| - Suc 0 = \<^bold>|butlast w\<^bold>|\<close> using drop_pref by metis  
+  show "\<forall>k<\<^bold>|[0]\<^bold>|. max_borderP (take ([0] ! k) (drop (\<^bold>|w\<^bold>| - 1 + k) w)) (drop (\<^bold>|w\<^bold>| - 1 + k) w)"
+  proof (simp add: last, unfold max_borderP_def)
+    have "\<forall>v. v \<le>b [last w] \<longrightarrow> v \<le>p \<epsilon>"
+      by (meson borderedI sing_not_bordered)
+    thus "\<epsilon> \<le>p [last w] \<and> \<epsilon> \<le>s [last w] \<and> (\<epsilon> = [last w] \<longrightarrow> [last w] = \<epsilon>) \<and> (\<forall>v. v \<le>b [last w] \<longrightarrow> v \<le>p \<epsilon>)"
+      by simp
+  qed
+qed
+
+lemma KMP_valid_step: assumes "KMP_valid w arr bord (Suc i)" 
+  shows "KMP_valid  w (KMP_arr w arr bord (Suc i)) (KMP_bord w arr bord (Suc i)) (KMP_pos w arr bord (Suc i))"
+proof-
+  \<comment> \<open>Consequences of the assumption\<close>
+  have all_k: "\<forall>k<\<^bold>|arr\<^bold>|. max_borderP (take (arr ! k) (drop (Suc i + k) w)) (drop (Suc i + k) w)"
+    using assms[unfolded KMP_valid_def] by blast
+  have "\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|" and
+    "Suc i + bord < \<^bold>|w\<^bold>|" and
+    bord_pref: "take bord (drop (Suc i) w) \<le>p drop (Suc i) w" and
+    bord_suf: "take bord (drop (Suc i) w) \<le>s drop (Suc i) w" and
+    up_bord: "\<And> v. v \<le>b w!i#(drop (Suc i) w) \<Longrightarrow> \<^bold>|v\<^bold>| \<le> Suc bord" and
+    all_k_neq0: "\<And> k. k < \<^bold>|arr\<^bold>| \<Longrightarrow> take (arr ! k) (drop (Suc i + k) w) = drop (Suc i + k) w \<longrightarrow> drop (Suc i + k) w = \<epsilon>" and
+    all_k_pref: "\<And> k. k < \<^bold>|arr\<^bold>| \<Longrightarrow> take (arr ! k) (drop (Suc i + k) w) \<le>p drop (Suc i + k) w" and
+    all_k_suf: "\<And> k. k < \<^bold>|arr\<^bold>| \<Longrightarrow> take (arr ! k) (drop (Suc i + k) w) \<le>s drop (Suc i + k) w" and
+    all_k_v: "\<And> k v. k < \<^bold>|arr\<^bold>| \<Longrightarrow> v \<le>b drop (Suc i + k) w \<Longrightarrow> v \<le>p take (arr ! k) (drop (Suc i + k) w)"
+    using assms[unfolded KMP_valid_def max_borderP_def diff_Suc_1] by blast+ 
+  have all_k_neq: "\<And> k. k < \<^bold>|arr\<^bold>| \<Longrightarrow> take (arr ! k) (drop (Suc i + k) w) \<noteq> drop (Suc i + k) w"
+    using \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close> \<open>\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|\<close> all_k_neq0
+    add.commute add_le_imp_le_left drop_all_iff le_antisym less_imp_le_nat less_not_refl2 by metis 
+
+  have "w \<noteq> \<epsilon>" 
+    using \<open>\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|\<close> by auto
+  have "Suc i < \<^bold>|w\<^bold>|"
+    using \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close>  by simp
+  have pop_i: "drop i w = (w!i)# (drop (Suc i) w)"
+    by (simp add: Cons_nth_drop_Suc Suc_lessD \<open>Suc i < \<^bold>|w\<^bold>|\<close>)
+  have "drop (Suc i) w \<noteq> \<epsilon>"
+    using \<open>Suc i < \<^bold>|w\<^bold>|\<close> by fastforce  
+  have "Suc i + (\<^bold>|w\<^bold>| - Suc i - bord) = \<^bold>|w\<^bold>| - bord"
+    unfolding diff_right_commute[of _ _ bord] using \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close>  by linarith
+
+  show "KMP_valid  w (KMP_arr w arr bord (Suc i)) (KMP_bord w arr bord (Suc i)) (KMP_pos w arr bord (Suc i))"
+  proof (cases "w ! i = w ! (\<^bold>|w\<^bold>| - Suc bord)") 
+    assume match: "w ! i = w ! (\<^bold>|w\<^bold>| - Suc bord)" \<comment> \<open>The current candidate is extendable\<close>
+    show ?thesis
+    proof (unfold KMP_valid_def KMP_arr.simps KMP_bord.simps KMP_pos.simps if_P[OF match], intro conjI)
+      show "\<^bold>|Suc bord # arr\<^bold>| + i = \<^bold>|w\<^bold>|"
+        using \<open>\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|\<close> by auto
+      show "i + Suc bord < \<^bold>|w\<^bold>|"
+        using \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close> by auto
+      show "take (Suc bord) (drop i w) \<le>p drop i w"
+        using take_is_prefix by auto
+      show "take (Suc bord) (drop i w) \<le>s drop i w"
+        using \<open>take bord (drop (Suc i) w) \<le>s drop (Suc i) w\<close> ext_suf_Cons_take_drop match by blast
+          \<comment> \<open>The new border array is correct\<close>
+      show all_k_new: "\<forall>k<\<^bold>|Suc bord # arr\<^bold>|. max_borderP (take ((Suc bord # arr) ! k) (drop (i + k) w)) (drop (i + k) w)"
+      proof (rule allI, rule impI)       
+        fix k assume "k < \<^bold>|Suc bord # arr\<^bold>|"
+        show "max_borderP (take ((Suc bord # arr) ! k) (drop (i + k) w)) (drop (i + k) w)"
+        proof (cases "0 < k")
+          assume "0 < k" \<comment> \<open>old entries are valid:\<close>
+          thus ?thesis using all_k
+            by (metis Suc_less_eq \<open>k < \<^bold>|Suc bord # arr\<^bold>|\<close> add.right_neutral add_Suc_shift gr0_implies_Suc list.size(4) nth_Cons_Suc)
+        next 
+          assume "\<not> 0 < k" hence "k = 0" by simp 
+          show ?thesis \<comment> \<open>the extended border is maximal:\<close>
+          proof (simp add: \<open>k = 0\<close>, unfold max_borderP_def, intro conjI)
+            show "take (Suc bord) (drop i w) = drop i w \<longrightarrow> drop i w = \<epsilon>"
+              using \<open>i + Suc bord < \<^bold>|w\<^bold>|\<close> by fastforce
+            show "take (Suc bord) (drop i w) \<le>p drop i w"
+              using \<open>take (Suc bord) (drop i w) \<le>p drop i w\<close> by blast
+            show "take (Suc bord) (drop i w) \<le>s drop i w" by fact
+            show "\<forall>v. v \<le>b drop i w \<longrightarrow> v \<le>p take (Suc bord) (drop i w)"
+            proof (rule allI, rule impI)
+              fix v assume "v \<le>b drop i w"
+              from borderD_pref[OF this] up_bord[OF this[unfolded pop_i]]
+              (* have "v \<le>p drop i w". *)
+              show "v \<le>p take (Suc bord) (drop i w)"
+                 unfolding prefix_def by force
+            qed
+          qed
+        qed
+      qed
+        \<comment> \<open>the extended border is the longest candidate:\<close>
+      have "max_borderP (take (Suc bord) (drop i w)) (drop i w)"
+        using  all_k_new[rule_format, of 0, unfolded length_Cons nth_Cons_0 add_0_right, OF zero_less_Suc].
+      from border_add_Cons_len[OF this] max_borderP_D_max[OF this] max_borderP_D_neq[OF _ this]
+      show "\<forall>v. v \<le>b w ! (i - 1) # drop i w \<longrightarrow> \<^bold>|v\<^bold>| \<le> Suc (Suc bord)"
+        using nat_le_linear take_all take_len list.discI pop_i by metis 
+    qed
+  next 
+    assume mismatch: "w ! i \<noteq> w ! (\<^bold>|w\<^bold>| - Suc bord)" \<comment> \<open>The current candidate is not extendable\<close>
+    show ?thesis
+    proof (cases "bord = 0")
+      assume  "bord \<noteq> 0" \<comment> \<open>Recursion: try the maximal border of the current candidate...\<close>
+        let ?k  =  "\<^bold>|w\<^bold>| - Suc i - bord" and
+            ?w' = "drop (Suc i) w"
+        have "?k < \<^bold>|arr\<^bold>|"
+        using \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close> \<open>\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|\<close> \<open>bord \<noteq> 0\<close> by linarith 
+      from all_k_neq[OF this] 
+      have "arr ! ?k < bord" \<comment> \<open>... which is stored in the array, and is shorter\<close>
+        by (simp add: \<open>take (arr ! ?k) (drop (Suc i + ?k) w) \<noteq> drop (Suc i + ?k) w\<close> \<open>Suc i + ?k = \<^bold>|w\<^bold>| - bord\<close> \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close> add_diff_inverse_nat diff_add_inverse2 gr0I less_diff_conv nat_diff_split_asm )
+        let ?old_pref = "take bord ?w'" and
+            ?old_suf =  "drop (\<^bold>|w\<^bold>| - bord) w" and
+            ?new_pref = "take (arr ! ?k) ?w'"
+      show ?thesis
+      proof (unfold KMP_valid_def KMP_arr.simps KMP_bord.simps KMP_pos.simps if_not_P[OF mismatch] if_not_P[OF \<open>bord \<noteq> 0\<close>] if_P[OF \<open>arr ! ?k < bord\<close>] diff_Suc_1, intro conjI)
+        show "\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|"
+          using \<open>\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|\<close> by auto
+        show "Suc i + arr ! ?k < \<^bold>|w\<^bold>|"
+          using \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close> \<open>arr ! ?k < bord\<close> by linarith
+        show "take (arr ! ?k) (drop (Suc i) w) \<le>p drop (Suc i) w"    
+          using take_is_prefix by blast
+
+        \<comment> \<open>Next goal: the new border is a suffix\<close>
+
+        have "?old_suf \<le>s ?w'"
+          by (meson \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close> le_suf_drop less_diff_conv nat_less_le)
+        have "\<^bold>|?old_pref\<^bold>| = bord"
+          using \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close> take_len len_after_drop nat_less_le by blast 
+        also have "... = \<^bold>|?old_suf\<^bold>|"
+          using \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close>  by simp 
+        ultimately have eq1: "?old_pref = ?old_suf" \<comment> \<open>bord defines a border\<close>
+          using \<open>take bord (drop (Suc i) w) \<le>s drop (Suc i) w\<close> \<open>drop (\<^bold>|w\<^bold>| - bord) w \<le>s drop (Suc i) w\<close> suf_ruler_eq_len by metis 
+
+
+        have "\<^bold>|?new_pref\<^bold>| = arr!?k"
+          using take_len \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close> \<open>arr ! ?k < bord\<close> diff_diff_left by force
+        have "take (arr ! ?k) ?old_suf \<le>p ?old_pref"
+          using take_is_prefix \<open>?old_pref = ?old_suf\<close> by metis
+        from pref_take[OF pref_trans[OF this take_is_prefix], unfolded \<open>\<^bold>|?new_pref\<^bold>| = arr!?k\<close>, symmetric]
+        have "take (arr ! ?k) ?old_suf = take (arr ! ?k) ?w'" 
+          using take_len \<open>arr ! ?k < bord\<close> \<open>bord = \<^bold>|drop (\<^bold>|w\<^bold>| - bord) w\<^bold>|\<close> less_imp_le_nat by metis
+        from all_k_suf[OF \<open>?k < \<^bold>|arr\<^bold>|\<close>, unfolded \<open>Suc i + ?k = \<^bold>|w\<^bold>| - bord\<close>] this
+        have "take (arr ! ?k) ?w' \<le>s ?old_suf" by simp \<comment> \<open>The new prefix is a suffix of the old suffix\<close>
+
+        with \<open>?old_pref \<le>s ?w'\<close>[unfolded \<open>?old_pref = ?old_suf\<close>] 
+        show "take (arr ! ?k) ?w' \<le>s ?w'"
+          using suf_trans by blast
+
+        \<comment> \<open>Key facts about borders of the w'\<close>
+            have "?old_pref \<noteq> \<epsilon>"
+              using \<open>bord \<noteq> 0\<close> \<open>\<^bold>|?old_pref\<^bold>| = bord\<close> by force
+            moreover have "?old_pref \<noteq> ?w'"
+              using \<open>Suc i + bord < \<^bold>|w\<^bold>|\<close>
+              by (intro lenarg_not, unfold length_drop \<open>\<^bold>|take bord ?w'\<^bold>| = bord\<close>, linarith)  
+            ultimately have "?old_pref \<le>b ?w'" \<comment> \<open>bord is the length of a border\<close>
+              by (intro borderI[OF bord_pref bord_suf]) 
+ 
+        \<comment> \<open>We want to prove that the new border is the longest candidate\<close>
+           show "\<forall>v. v \<le>b w !i # ?w' \<longrightarrow> \<^bold>|v\<^bold>| \<le> Suc (arr ! ?k)"
+             proof (rule allI,rule impI)
+               have extendable: "w ! i # v' \<le>b w ! i # ?w' \<Longrightarrow> v' \<noteq> \<epsilon> \<Longrightarrow> \<^bold>|v'\<^bold>| \<le> arr ! ?k" for v' \<comment> \<open>First consider a border of w', which is extendable\<close>
+               proof-  
+                 assume "w!i # v' \<le>b w!i # ?w'" and "v' \<noteq> \<epsilon>"   
+                 from suf_trans[OF borderD_suf[OF \<open>w!i # v' \<le>b w ! i # ?w'\<close>, folded pop_i] suffix_drop]
+                 have "w!i # v' \<le>s w".
+                 from this[unfolded suf_drop_conv, THEN nth_via_drop] mismatch
+                 have "\<^bold>|w!i # v'\<^bold>| \<noteq> Suc bord"
+                   by force
+                 with up_bord[OF \<open>w!i # v' \<le>b w ! i # ?w'\<close>]
+                 have "\<^bold>|v'\<^bold>| < bord"  \<comment> \<open>It is shorter than the old candidate border\<close>
+                   by simp
+                 from border_ConsD(2)[OF \<open>w!i # v' \<le>b w ! i # ?w'\<close> \<open>v' \<noteq> \<epsilon>\<close>] 
+                 have "v' \<le>b ?w'".
+                 from borders_compare[OF \<open>?old_pref \<le>b ?w'\<close> this, unfolded  \<open>\<^bold>|?old_pref\<^bold>| = bord\<close>, unfolded \<open>?old_pref = ?old_suf\<close>, OF \<open>\<^bold>|v'\<^bold>| < bord\<close>]
+                 have "v' \<le>b ?old_suf". \<comment> \<open>... and therefore its border\<close>
+                 from prefix_length_le[OF max_borderP_D_max[OF all_k[rule_format, OF \<open>?k < \<^bold>|arr\<^bold>|\<close>], unfolded \<open>Suc i + ?k = \<^bold>|w\<^bold>| - bord\<close>, OF this]]
+                 show "\<^bold>|v'\<^bold>| \<le> arr!?k" \<comment> \<open>... and hence short\<close>
+                   using len_take1[of "arr!?k", of w] by simp 
+               qed
+            fix v assume "v \<le>b w!i # ?w'"  \<comment> \<open>Now consider a border of the extended word\<close> 
+            show "\<^bold>|v\<^bold>| \<le> Suc (arr ! ?k)"
+            proof (cases "\<^bold>|v\<^bold>| \<le> Suc 0", simp, drule not_le_imp_less)   
+              assume "Suc 0 < \<^bold>|v\<^bold>|"
+              from hd_tl_longE[OF this] 
+              obtain a v' where "v = a#v'" and "v' \<noteq> \<epsilon>"
+                by blast
+              with borderD_pref[OF \<open>v \<le>b w!i # ?w'\<close>, unfolded prefix_Cons]
+              have "v = w!i#v'" 
+                by simp
+              from extendable[OF \<open>v \<le>b w!i # ?w'\<close>[unfolded \<open>v = w!i#v'\<close>] \<open>v' \<noteq> \<epsilon>\<close>]
+              show ?thesis
+                by (simp add: \<open>v = a # v'\<close>) 
+          qed
+        qed
+        show " \<forall>k<\<^bold>|arr\<^bold>|. max_borderP (take (arr ! k) (drop (Suc i + k) w)) (drop (Suc i + k) w)"
+          using all_k by blast
+      qed
+    next
+      assume "bord = 0" \<comment> \<open>End of recursion.\<close>
+      show ?thesis 
+      proof (unfold KMP_valid_def KMP_arr.simps KMP_bord.simps KMP_pos.simps if_not_P[OF mismatch] if_P[OF \<open>bord = 0\<close>], intro conjI)
+        show "\<^bold>|0 # arr\<^bold>| + i = \<^bold>|w\<^bold>|"
+          using \<open>\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|\<close> by auto 
+        show "i + 0 < \<^bold>|w\<^bold>|"
+          by (simp add: Suc_lessD \<open>Suc i < \<^bold>|w\<^bold>|\<close>)
+        show "take 0 (drop i w) \<le>p drop i w"
+          by simp
+        show "take 0 (drop i w) \<le>s drop i w"
+          using ext_suf_Cons_take_drop by simp 
+            \<comment> \<open>The extension is unbordered\<close>
+        have "max_borderP \<epsilon> (drop i w)"
+        proof(rule ccontr)
+          assume "\<not> max_borderP \<epsilon> (drop i w)"
+          then obtain a t where "max_borderP (a#t) (drop i w)"
+            unfolding pop_i  using max_border_ex[of "w ! i # drop (Suc i) w"] neq_Nil_conv by metis
+          from up_bord[OF max_borderP_border[OF this list.simps(3), unfolded pop_i], unfolded \<open>bord = 0\<close>]
+          have "t = \<epsilon>" by simp
+          from max_borderP_border[OF \<open>max_borderP (a#t) (drop i w)\<close>[unfolded this] list.simps(3)]
+          have "[a] \<le>b drop i w".
+          from borderD_pref[OF this]
+          have "w!i = a"
+            by (simp add: pop_i)        
+          moreover have "w!(\<^bold>|w\<^bold>| - 1) = a"
+            using  borderD_suf[OF \<open>[a] \<le>b drop i w\<close>] nth_via_drop sing_len suf_drop_conv suf_share_take suffix_drop suffix_length_le by metis 
+          ultimately show False 
+            using mismatch[unfolded \<open>bord = 0\<close>] by simp
+        qed
+        thus "\<forall>v. v \<le>b w ! (i - 1) # drop i w \<longrightarrow> \<^bold>|v\<^bold>| \<le> Suc 0"
+          by (metis border_add_Cons_len list.size(3))
+            \<comment> \<open>The array is valid: old values from assumption, the first 0 since the extension is unbordered\<close>
+        show "\<forall>k<\<^bold>|0 # arr\<^bold>|. max_borderP (take ((0 # arr) ! k) (drop (i + k) w)) (drop (i + k) w)"
+        proof (rule allI, rule impI)
+          fix k assume "k < \<^bold>|0 # arr\<^bold>|"
+          show "max_borderP (take ((0 # arr) ! k) (drop (i + k) w)) (drop (i + k) w)"
+          proof (cases "0 < k")
+            assume "0 < k"
+            thus ?thesis using all_k
+              by (metis Suc_less_eq \<open>k < \<^bold>|0 # arr\<^bold>|\<close> add.right_neutral add_Suc_shift gr0_implies_Suc list.size(4) nth_Cons_Suc)
+          next 
+            assume "\<not> 0 < k" hence "k = 0" by simp
+            thus ?thesis
+              using \<open>max_borderP \<epsilon> (drop i w)\<close> by auto 
+          qed
+        qed
+      qed
+    qed
+  qed
+qed
+
+lemma KMP_valid_max:  "\<forall> k. KMP_valid w arr bord pos \<longrightarrow> k < \<^bold>|w\<^bold>| \<longrightarrow> max_borderP (take ((KMP w arr bord pos)!k) (drop k w)) (drop k w)"
+proof (induct
+    rule: KMP.induct[of "\<lambda> w arr bord pos. 
+(\<forall> k. KMP_valid w arr bord pos \<longrightarrow> k < \<^bold>|w\<^bold>| \<longrightarrow> max_borderP (take ((KMP w arr bord pos)!k) (drop k w)) (drop k w))"]
+      )
+  case (1 w arr bord)
+  then show ?case  
+    unfolding KMP.simps KMP_valid_def by simp
+next
+  case (2 w arr bord i)
+  then show ?case 
+    unfolding KMP.simps using KMP_valid_step by blast
+qed
+
+section \<open>Border array\<close>
+
+fun border_array :: "'a list \<Rightarrow> nat list" where
+  "border_array \<epsilon> = \<epsilon>" 
+| "border_array (a#w) = rev (KMP (rev (a#w)) [0] 0 (\<^bold>|a#w\<^bold>|-1))"
+
+lemma border_array_len: "\<^bold>|border_array w\<^bold>| = \<^bold>|w\<^bold>|"
+  by (induct w, simp_all add: KMP_len)
+
+theorem bord_array: assumes "Suc k \<le> \<^bold>|w\<^bold>|" shows "(border_array w)!k = \<^bold>|max_border (take (Suc k) w)\<^bold>|"
+proof-
+  define m where "m = \<^bold>|w\<^bold>| - Suc k"
+  hence "m < \<^bold>|rev w\<^bold>|"
+    by (simp add: Suc_diff_Suc assms less_eq_Suc_le)
+  have "rev w \<noteq> \<epsilon>" and "k < \<^bold>|rev w\<^bold>|"
+    using \<open>Suc k \<le> \<^bold>|w\<^bold>|\<close> by auto
+  hence "w = hd w#tl w"
+    by simp 
+  from arg_cong[OF border_array.simps(2)[of "hd w" "tl w", folded this], of rev, unfolded rev_rev_ident]
+  have "rev (border_array w) =  (KMP (rev w) [0] 0 (\<^bold>|w\<^bold>|-1))". 
+  hence "max_borderP (take (rev (border_array w)!m) (drop m (rev w))) (drop m (rev w))"
+    using KMP_valid_max[rule_format, OF KMP_valid_base[OF \<open>rev w \<noteq> \<epsilon>\<close>] \<open>m < \<^bold>|rev w\<^bold>|\<close>] by simp
+  hence  "max_border (drop m (rev w)) = take (rev (border_array w)!m) (drop m (rev w))"
+    using max_borderP_max_border by blast
+  hence  "\<^bold>|max_border (drop m (rev w))\<^bold>| =  rev (border_array w)!m"
+    by (metis \<open>m < \<^bold>|rev w\<^bold>|\<close> drop_all_iff leD max_border_nemp_neq nat_le_linear take_all take_len)
+  thus ?thesis 
+    using m_def
+    by (metis Suc_diff_Suc \<open>k < \<^bold>|rev w\<^bold>|\<close> \<open>m < \<^bold>|rev w\<^bold>|\<close> border_array_len diff_diff_cancel drop_rev length_rev less_imp_le_nat max_border_len_rev rev_nth)
+qed
+
+lemma max_border_comp [code]: "max_border w = take ((border_array w)!(\<^bold>|w\<^bold>|-1)) w"
+proof (cases "w = \<epsilon>")
+  assume "w = \<epsilon>"
+  thus "max_border w = take ((border_array w)!(\<^bold>|w\<^bold>|-1)) w"
+    using max_bord_take take_Nil by metis
+next
+  assume "w \<noteq> \<epsilon>"
+  hence "Suc (\<^bold>|w\<^bold>| - 1) \<le> \<^bold>|w\<^bold>|" by simp   
+  from bord_array[OF this]
+  have "(border_array w)!(\<^bold>|w\<^bold>|-1) = \<^bold>|max_border w\<^bold>|"
+    by (simp add: \<open>w \<noteq> \<epsilon>\<close>)
+  thus "max_border w = take ((border_array w)!(\<^bold>|w\<^bold>|-1)) w"
+    using max_bord_take by auto
+qed
+
+value[nbe] "primitive [a,b,a]"
+
+value "primitive [0::nat,1,0]"
+
+value "border_array [5,4::nat,5,3,5,5,5,4,5]"
+
+value "primitive [5,4::nat,5,3,5,5,5,4,5]"
+
+value "primitive [5,4::nat,5,3,5,5,5,4,5]"
+
+value[nbe] "bordered []"
+
+value "border_array [0::nat,1,1,0,0,0,1,1,1,1,1,0,0,0,1,1,1,0,1,1,0,0,0,1,1,1,1,1,1,0,0,0,1,1,1,0,1,1,0,0,0,1,1,1,0,1,1,0,0,0,1,1,1,0,0,1,0]"
+
+value[nbe] "border_array \<epsilon>"
+
+value "border_array [1,0::nat,1,0,1,1,0,0]"
+
+value "max_border [1,0::nat,1,0,1,1,0,0,1,0,1,1,0::nat,1,0,1,1,0,0,1,0,1,1,0::nat,1,0,1,1,0,0,1,0,1,0,0,1]"
+
+value "bordered [1,0::nat,1,0,1,1,0,1]"
+
+value "\<^bold>|\<pi> [1::nat,0,1,0,1,1,0,1]\<^bold>|"
+
+
+
+end
diff --git a/thys/Combinatorics_Words/CoWAll.thy b/thys/Combinatorics_Words/CoWAll.thy
--- a/thys/Combinatorics_Words/CoWAll.thy
+++ b/thys/Combinatorics_Words/CoWAll.thy
@@ -1,9 +1,13 @@
-theory CoWAll
-  imports
-    CoWBasic
-    Submonoids
-    Periodicity_Lemma           
-    Lyndon_Schutzenberger
+theory CoWAll (*Isabelle 2021-1*)
+  imports 
+          CoWBasic
+          Submonoids
+          Periodicity_Lemma
+          Morphisms
+          Border_Array
+          Equations_Basic
+          Lyndon_Schutzenberger
+          Binary_Code_Morphisms
 begin  
 
 end
diff --git a/thys/Combinatorics_Words/CoWBasic.thy b/thys/Combinatorics_Words/CoWBasic.thy
--- a/thys/Combinatorics_Words/CoWBasic.thy
+++ b/thys/Combinatorics_Words/CoWBasic.thy
@@ -1,3509 +1,6271 @@
 (*  Title:      CoW/CoWBasic.thy
     Author:     Štěpán Holub, Charles University
     Author:     Martin Raška, Charles University
     Author:     Štěpán Starosta, CTU in Prague
+
+Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/
 *)
 
 theory CoWBasic
-  imports "HOL-Library.Sublist" Arithmetical_Hints Reverse_Symmetry
+  imports "HOL-Library.Sublist" Arithmetical_Hints Reverse_Symmetry "HOL-Eisbach.Eisbach_Tools"
 begin
 
 chapter "Basics of Combinatorics on Words"
 
 text\<open>Combinatorics on Words, as the name suggests, studies words, finite or infinite sequences of elements from a, usually finite, alphabet.
 The essential operation on finite words is the concatenation of two words, which is associative and noncommutative.
 This operation yields many simply formulated problems, often in terms of \emph{equations on words}, that are mathematically challenging.
 
 See for instance @{cite ChoKa97} for an introduction to Combinatorics on Words, and \cite{Lo,Lo2,Lo3} as another reference for Combinatorics on Words.
 This theory deals exclusively with finite words and  provides basic facts of the field which can be considered as folklore.
 
 The most natural way to represent finite words is by the type @{typ "'a list"}.
  From an algebraic viewpoint, lists are free monoids. On the other hand, any free monoid is isomoporphic to a monoid of lists of its generators.
 The algebraic point of view and the combinatorial point of view therefore overlap significantly in Combinatorics on Words.
 \<close>
 
 section "Definitions and notations"
 
 text\<open>First, we introduce elementary definitions and notations.\<close>
 
 text\<open>The concatenation @{term append} of two finite lists/words is the very basic operation in Combinatorics on Words, its notation is usually omitted.
 In this field, a common notation for this operation is $\cdot$, which we use and add here.\<close>
 
-
 notation append (infixr "\<cdot>" 65)
 
 lemmas rassoc = append_assoc
 lemmas lassoc = append_assoc[symmetric]
 
 text\<open>We add a common notation for the length of a given word $|w|$.\<close>
 
 
 notation
   length  ("\<^bold>|_\<^bold>|") \<comment> \<open>note that it's bold |\<close>
 notation (latex output)
   length  ("\<^latex>\<open>\\ensuremath{\\left| \<close>_\<^latex>\<open>\\right|}\<close>")
+notation longest_common_prefix  ("_ \<and>\<^sub>p _" [61,62] 64) \<comment> \<open>provided by 
+
+Sublist.thy\<close>
 
 subsection \<open>Empty and nonempty word\<close>
 
 text\<open>As the word of length zero @{term Nil} or @{term "[]"} will be used often, we adopt its frequent notation $\varepsilon $ in this formalization.\<close>
 
 notation Nil ("\<epsilon>")
 
 abbreviation drop_emp :: "'a list set \<Rightarrow> 'a list set" ( "_\<^sub>+" [1000] ) where
   "drop_emp S \<equiv> S - {\<epsilon>}"
 
+lemmas clean_emp = append_Nil2 append_Nil list.map(1)
+
 subsection \<open>Prefix\<close>
 
 text\<open>The property of being a prefix shall be frequently used, and we give it yet another frequent shorthand notation.
 Analogously, we introduce shorthand notations for non-empty prefix and strict prefix, and continue with suffixes and factors.
 \<close>
 
 
 notation prefix (infixl "\<le>p" 50)
 notation (latex output) prefix  ("\<le>\<^sub>p")
-lemmas [simp] = prefix_def
+(* lemmas [simp] = prefix_def *)
 
 lemmas prefI'[intro] = prefixI
 
 lemma prefI[intro]: "p \<cdot> s = w \<Longrightarrow> p \<le>p w"
   by auto
 
 lemma prefD: "u \<le>p v \<Longrightarrow> \<exists> z. v = u \<cdot> z"
   unfolding prefix_def.
 
 definition prefix_comparable :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" (infixl "\<bowtie>" 50)
-  where prefix_comparable_def[simp]: "(prefix_comparable u v) \<equiv> u \<le>p v \<or> v \<le>p u"
-
-lemma pref_compIff[iff]: "u \<bowtie> v \<longleftrightarrow> u \<le>p v \<or> v \<le>p u"
+  where [simp]: "(prefix_comparable u v) \<equiv> u \<le>p v \<or> v \<le>p u"
+
+lemma pref_compI1: "u \<le>p v  \<Longrightarrow> u \<bowtie> v"
+  unfolding prefix_comparable_def..
+
+lemma pref_compI2: "v \<le>p u \<Longrightarrow> u \<bowtie> v"
+  unfolding prefix_comparable_def..
+
+lemma pref_compE [elim]: assumes "u \<bowtie> v" obtains "u \<le>p v" | "v \<le>p u"
+  using assms unfolding prefix_comparable_def..
+
+lemma pref_compI[intro]: "u \<le>p v \<or> v \<le>p u \<Longrightarrow> u \<bowtie> v"
   by simp
 
+lemma prefs_comp_comp: "p1 \<le>p v1 \<Longrightarrow> p2 \<le>p v2 \<Longrightarrow> v1 \<bowtie> v2 \<Longrightarrow> p1 \<bowtie> p2"
+  unfolding prefix_comparable_def  using  prefix_order.trans prefix_same_cases by metis
+
 definition nonempty_prefix (infixl "\<le>np" 50) where nonempty_prefix_def[simp]:  "u \<le>np v \<equiv> u \<noteq> \<epsilon> \<and> u \<le>p v"
 notation (latex output) nonempty_prefix  ("\<le>\<^bsub>np\<^esub>" 50)
 
 lemma npI[intro]: "u \<noteq> \<epsilon> \<Longrightarrow> u \<le>p v \<Longrightarrow> u \<le>np v"
   by auto
 
 lemma npI'[intro]: "u \<noteq> \<epsilon> \<Longrightarrow> (\<exists> z. u \<cdot> z = v) \<Longrightarrow> u \<le>np v"
   by auto
 
 lemma npD: "u \<le>np v \<Longrightarrow> u \<le>p v"
   by simp
 
 lemma npD': "u \<le>np v \<Longrightarrow> u \<noteq> \<epsilon>"
   by simp
 
 notation strict_prefix (infixl "<p" 50)
 notation (latex output) strict_prefix  ("<\<^sub>p")
 lemmas [simp] = strict_prefix_def
 
 lemma sprefI1[intro]: "v = u \<cdot> z \<Longrightarrow> z \<noteq> \<epsilon> \<Longrightarrow> u <p v"
   by simp
 
 lemma sprefI1'[intro]: "u \<cdot> z = v \<Longrightarrow> z \<noteq> \<epsilon> \<Longrightarrow> u <p v"
-   by blast
+  by blast
 
 lemma sprefI2[intro]: "u \<le>p v \<Longrightarrow> length u < length v \<Longrightarrow> u <p v"
   unfolding strict_prefix_def
   by blast
 
 lemma sprefD[elim]: "u <p v \<Longrightarrow> u \<le>p v \<and> u \<noteq> v"
   by auto
 
 lemmas sprefD1[elim] = prefix_order.strict_implies_order and
   sprefD2[elim] = prefix_order.less_imp_neq
 
 lemma sprefE [elim]: assumes "u <p v" obtains z where "u \<cdot> z = v" and "z \<noteq> \<epsilon>"
-  using assms  by auto
+   using assms unfolding strict_prefix_def prefix_def by blast
 
 subsection \<open>Suffix\<close>
 
-notation suffix (infixl "\<le>s" 60)
+notation suffix (infixl "\<le>s" 50)
 notation (latex output) suffix ("\<le>\<^sub>s")
-lemmas [simp] = suffix_def
+lemmas suf_def = suffix_def and
+       pref_def = prefix_def
 
 lemma sufI[intro]: "p \<cdot> s = w \<Longrightarrow> s \<le>s w"
-  by auto
+  by (auto simp add: suf_def)
 
 lemma sufD[elim]: "u \<le>s v \<Longrightarrow> \<exists> z. z \<cdot> u = v"
-  by auto
+  by (auto simp add: suf_def)
+
 
 notation strict_suffix (infixl "<s" 50)
 notation (latex output) strict_suffix  ("<\<^sub>s")
 lemmas [simp] = strict_suffix_def
 
 lemmas [intro] = suffix_order.le_neq_trans
 
 lemma ssufI1[intro]: "u \<cdot> v = w \<Longrightarrow> u \<noteq> \<epsilon> \<Longrightarrow> v <s w"
   by blast
 
 lemma ssufI2[intro]: "u \<le>s v \<Longrightarrow> length u < length v \<Longrightarrow> u <s v"
   by blast
 
+lemma ssufE: "u <s v \<Longrightarrow> (u \<le>s v \<Longrightarrow> u \<noteq> v \<Longrightarrow> thesis) \<Longrightarrow> thesis"
+  by auto
+
+lemma ssufI3[intro]: "u \<cdot> v = w \<Longrightarrow> u \<le>np w \<Longrightarrow> v <s w"
+  unfolding nonempty_prefix_def by blast
+
 lemma ssufD[elim]: "u <s v \<Longrightarrow> u \<le>s v \<and> u \<noteq> v"
   by auto
 
 lemmas ssufD1[elim] = suffix_order.strict_implies_order and
   ssufD2[elim] = suffix_order.less_imp_neq
 
 definition suffix_comparable :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" (infixl "\<bowtie>\<^sub>s" 50)
-  where suffix_comparable_def[simp]: "(suffix_comparable u v) \<equiv> (rev u) \<bowtie> (rev v)"
+  where "(suffix_comparable u v) \<longleftrightarrow> (rev u) \<bowtie> (rev v)"
 
 definition nonempty_suffix (infixl "\<le>ns" 60) where nonempty_suffix_def[simp]:  "u \<le>ns v \<equiv> u \<noteq> \<epsilon> \<and> u \<le>s v"
 notation (latex output) nonempty_suffix  ("\<le>\<^bsub>ns\<^esub>" 50)
 
 lemma nsI[intro]: "u \<noteq> \<epsilon> \<Longrightarrow> u \<le>s v \<Longrightarrow> u \<le>ns v"
   by auto
 
 lemma nsI'[intro]: "u \<noteq> \<epsilon> \<Longrightarrow> (\<exists> z. z \<cdot> u = v) \<Longrightarrow> u \<le>ns v"
   by blast
 
 lemma nsD: "u \<le>ns v \<Longrightarrow> u \<le>s v"
   by simp
 
 lemma nsD': "u \<le>ns v \<Longrightarrow> u \<noteq> \<epsilon>"
   by simp
 
 subsection \<open>Factor\<close>
 
 text\<open>A @{term sublist} of some word is in Combinatorics of Words called a factor.
 We adopt a common shorthand notation for the property of being a factor, strict factor and nonempty factor (the latter we also define).\<close>
 
 
-notation sublist (infixl "\<le>f" 60)
+notation sublist (infixl "\<le>f" 50)
 notation (latex output) sublist ("\<le>\<^sub>f")
-lemmas factor_def[simp] = sublist_def
-
-
-notation strict_sublist (infixl "<f" 60)
+lemmas fac_def = sublist_def
+
+
+notation strict_sublist (infixl "<f" 50)
 notation (latex output) strict_sublist ("<\<^bsub>f\<^esub>")
 lemmas strict_factor_def[simp] = strict_sublist_def
 
 definition nonempty_factor (infixl "\<le>nf" 60) where nonempty_factor_def[simp]:  "u \<le>nf v \<equiv> u \<noteq> \<epsilon> \<and> (\<exists> p s. p\<cdot>u\<cdot>s = v)"
 notation (latex output) nonempty_factor ("\<le>\<^bsub>nf\<^esub>")
 
-lemma facI: "u \<le>f p\<cdot>u\<cdot>s"
-  using sublist_appendI.
+lemmas facI = sublist_appendI
 
 lemma facI': "a \<cdot> u \<cdot> b = w \<Longrightarrow> u \<le>f w"
   by auto
 
 lemma facE[elim]: assumes "u \<le>f v"
   obtains p s where "v = p \<cdot> u \<cdot> s"
-  using assms unfolding factor_def
+  using assms unfolding fac_def
   by blast
 
 lemma facE'[elim]: assumes "u \<le>f v"
   obtains p s where "p \<cdot> u \<cdot> s = v"
-  using assms unfolding factor_def
+  using assms unfolding fac_def
   by blast
 
 section "Various elementary lemmas"
 
-lemmas concat_morph = sym[OF concat_append]
+lemmas drop_all_iff = drop_eq_Nil \<comment> \<open>backward compatibility with Isabelle 2021\<close>
+
+lemma exE2: "\<exists> x y. P x y \<Longrightarrow> (\<And> x y. P x y \<Longrightarrow> thesis) \<Longrightarrow> thesis"
+  by auto
+
+lemmas concat_morph = concat_append
 
 lemmas cancel = same_append_eq and
-    cancel_right = append_same_eq
+  cancel_right = append_same_eq
+
+lemmas disjI = verit_and_neg(3)
+
+lemma rev_in_conv: "rev u \<in> A \<longleftrightarrow> u \<in> rev ` A"
+  by force
+
+lemmas map_rev_involution = list.map_comp[of rev rev, unfolded rev_involution' list.map_id]
+
+lemma map_rev_lists_rev:  "map rev ` (lists (rev ` A)) = lists A"
+  unfolding lists_image[of rev] image_comp
+  by (simp add: rev_involution')
+
+lemma inj_on_map_lists: assumes "inj_on f A" 
+  shows "inj_on (map f) (lists A)"  
+proof
+  fix xs ys 
+  assume "xs \<in> lists A" and "ys \<in> lists A" and "map f xs = map f ys"
+  have "x = y" if "x \<in> set xs" and "y \<in> set ys" and  "f x =  f y"  for x y
+    using in_listsD[OF \<open>xs \<in> lists A\<close>, rule_format, OF \<open>x \<in> set xs\<close>]
+          in_listsD[OF \<open>ys \<in> lists A\<close>, rule_format, OF \<open>y \<in> set ys\<close>]
+         \<open>inj_on f A\<close>[unfolded inj_on_def, rule_format, OF _ _ \<open>f x =  f y\<close>] by blast
+  from list.inj_map_strong[OF this  \<open>map f xs = map f ys\<close>]
+  show "xs = ys".
+qed
 
 lemma bij_lists: "bij_betw f X Y \<Longrightarrow> bij_betw (map f) (lists X) (lists Y)"
-proof-
-  assume "bij_betw f X Y"
-  hence "inj_on f X"
-    by (simp add: bij_betw_def)
-  have "\<And> x y. x \<in> lists X \<Longrightarrow> y \<in> lists X \<Longrightarrow> (set x \<union> set y) \<subseteq> X"
-    by blast
-  hence "\<And> x y. x \<in> lists X \<Longrightarrow> y \<in> lists X \<Longrightarrow> inj_on f (set x \<union> set y)"
-    using subset_inj_on[OF \<open>inj_on f X\<close>] by meson
-  hence "\<And> x y. x \<in> lists X \<Longrightarrow> y \<in> lists X \<Longrightarrow> map f x = map f y \<longleftrightarrow> x  = y"
-    by (simp add: inj_on_map_eq_map)
-  hence "inj_on (map f) (lists X)"
-    by (simp add: inj_on_def)
-  thus ?thesis using  \<open>bij_betw f X Y\<close> bij_betw_def lists_image
-    by metis
-qed
+  unfolding bij_betw_def using inj_on_map_lists lists_image by metis 
 
 lemma concat_sing': "concat [r] = r"
   by simp
 
-lemma concat_sing:  "s = [hd s] \<Longrightarrow> concat s = hd s"
-  using concat_sing'[of "hd s"] by auto
+lemma concat_sing: assumes "s = [a]" shows "concat s = a"
+  using concat_sing' unfolding \<open>s = [a]\<close>.
 
 lemma rev_sing: "rev [x] = [x]"
   by simp
 
 lemma hd_word: "a#ws = [a] \<cdot> ws"
   by simp
 
-lemma hd_word': "w \<noteq> \<epsilon> \<Longrightarrow> [hd w] \<cdot> tl w = w"
+lemma map_hd:  "map f (a#v) = [f a] \<cdot> (map f v)"
   by simp
 
+lemma hd_tl: "w \<noteq> \<epsilon> \<Longrightarrow> [hd w] \<cdot> tl w = w"
+  by simp
+
+lemma hd_tlE: assumes "w \<noteq> \<epsilon>"
+  obtains a w' where "w = a#w'"
+  using exE2[OF assms[unfolded neq_Nil_conv]].
+
+lemma hd_tl_lenE: assumes "0 < \<^bold>|w\<^bold>|"
+  obtains a w' where "w = a#w'"
+  using exE2[OF assms[unfolded length_greater_0_conv neq_Nil_conv]].
+
+lemma hd_tl_longE: assumes "Suc 0 < \<^bold>|w\<^bold>|"
+  obtains a w' where "w = a#w'" and "w' \<noteq> \<epsilon>" and "hd w = a" and "tl w = w'"
+proof-
+  obtain a w' where "w = a#w'"
+    using  hd_tl_lenE[OF Suc_lessD[OF  assms]].
+  hence "w' \<noteq> \<epsilon>" and  "hd w = a" and "tl w = w'" using assms by auto
+  from that[OF \<open>w = a#w'\<close> this] show thesis.
+qed
+
 lemma hd_pref: "w \<noteq> \<epsilon> \<Longrightarrow> [hd w] \<le>p w"
-  using hd_word'
+  using hd_tl
   by blast
 
 lemma add_nth: assumes "n < \<^bold>|w\<^bold>|" shows "(take n w) \<cdot> [w!n] \<le>p w"
   using take_is_prefix[of "Suc n" w, unfolded take_Suc_conv_app_nth[OF assms]].
 
-lemma hd_pref': "w \<noteq> \<epsilon> \<Longrightarrow> [w!0] \<le>p w"
-  using add_nth by fastforce
+lemma hd_pref': assumes "w \<noteq> \<epsilon>" shows "[w!0] \<le>p w"
+  using hd_pref[OF \<open>w \<noteq> \<epsilon>\<close>, folded hd_conv_nth[OF \<open>w \<noteq> \<epsilon>\<close>, symmetric]]. 
 
 lemma sub_lists_mono: "A \<subseteq> B \<Longrightarrow> x \<in> lists A \<Longrightarrow> x \<in> lists B"
   by auto
 
-lemma lists_hd: "us \<noteq> \<epsilon> \<Longrightarrow> us \<in> lists Q \<Longrightarrow> hd us \<in> Q"
+lemma lists_hd_in_set[simp]: "us \<noteq> \<epsilon> \<Longrightarrow> us \<in> lists Q \<Longrightarrow> hd us \<in> Q"
   by fastforce
 
 lemma replicate_in_lists: "replicate k z \<in> lists {z}"
   by (induction k) auto
 
-lemma tl_lists: assumes "us \<in> lists A" shows "tl us \<in> lists A"
+lemma tl_in_lists: assumes "us \<in> lists A" shows "tl us \<in> lists A"
   using suffix_lists[OF suffix_tl assms].
 
+lemmas lists_butlast = tl_in_lists[reversed]
+
 lemma long_list_tl: assumes "1 < \<^bold>|us\<^bold>|" shows "tl us \<noteq> \<epsilon>"
 proof
   assume "tl us = \<epsilon>"
   from assms
   have "us \<noteq> \<epsilon>" and "\<^bold>|us\<^bold>| = Suc \<^bold>|tl us\<^bold>|" and "\<^bold>|us\<^bold>| \<noteq> Suc 0"
     by auto
   thus False
     using \<open>tl us = \<epsilon>\<close> by simp
 qed
 
 lemma tl_set: "x \<in> set (tl a) \<Longrightarrow> x \<in> set a"
   using list.sel(2) list.set_sel(2) by metis
 
 lemma drop_take_inv: "n \<le> \<^bold>|u\<^bold>| \<Longrightarrow> drop n (take n u \<cdot> w) = w"
   by simp
 
 lemma split_list_long: assumes "1 < \<^bold>|us\<^bold>|" and "u \<in> set us"
   obtains xs ys where "us = xs \<cdot> [u] \<cdot> ys" and "xs\<cdot>ys\<noteq>\<epsilon>"
 proof-
   obtain xs ys where "us = xs \<cdot> [u] \<cdot> ys"
     using split_list_first[OF \<open>u \<in> set us\<close>] by auto
   hence "xs\<cdot>ys\<noteq>\<epsilon>"
     using \<open>1 < \<^bold>|us\<^bold>|\<close> by auto
   from that[OF \<open>us = xs \<cdot> [u] \<cdot> ys\<close> this]
   show thesis.
 qed
 
 lemma flatten_lists: "G \<subseteq> lists B \<Longrightarrow> xs \<in> lists G \<Longrightarrow> concat xs \<in> lists B"
-proof (induct xs, simp)
-  case (Cons a xs)
-  hence "concat xs \<in> lists B" and "a \<in> lists B"
-    by auto
-  thus ?case
-    by simp
-qed
+ by (induct xs, simp_all add: subset_iff)
 
 lemma concat_map_sing_ident: "concat (map (\<lambda> x. [x]) xs) = xs"
   by auto
 
 lemma hd_concat_tl: assumes "ws \<noteq> \<epsilon>" shows "hd ws \<cdot> concat (tl ws) = concat ws"
   using concat.simps(2)[of "hd ws" "tl ws", unfolded list.collapse[OF \<open>ws \<noteq> \<epsilon>\<close>], symmetric].
 
 lemma concat_butlast_last: assumes "ws \<noteq> \<epsilon>" shows "concat (butlast ws) \<cdot> last ws = concat ws"
-  using  concat_morph[of "butlast ws" "[last ws]", unfolded concat_sing' append_butlast_last_id[OF \<open>ws \<noteq> \<epsilon>\<close>]].
+  using  concat_morph[of "butlast ws" "[last ws]", unfolded concat_sing' append_butlast_last_id[OF \<open>ws \<noteq> \<epsilon>\<close>], symmetric].
+
+lemma spref_butlast_pref: assumes "u \<le>p v" and "u \<noteq> v" shows "u \<le>p butlast v"
+  using butlast_append prefixE[OF \<open>u \<le>p v\<close>] \<open>u \<noteq> v\<close> append_Nil2 prefixI by metis   
+
+lemma last_concat: "xs \<noteq> \<epsilon> \<Longrightarrow> last xs \<noteq> \<epsilon> \<Longrightarrow> last (concat xs) = last (last xs)"
+  using concat_butlast_last last_appendR by metis
 
 lemma concat_last_suf: "ws \<noteq> \<epsilon> \<Longrightarrow> last ws \<le>s concat ws"
   using concat_butlast_last by blast
 
 lemma concat_hd_pref: "ws \<noteq> \<epsilon> \<Longrightarrow> hd ws \<le>p concat ws"
   using hd_concat_tl by blast
 
 lemma set_nemp_concat_nemp: assumes "ws \<noteq> \<epsilon>" and "\<epsilon> \<notin> set ws" shows "concat ws \<noteq> \<epsilon>"
   using \<open>\<epsilon> \<notin> set ws\<close> last_in_set[OF \<open>ws \<noteq> \<epsilon>\<close>] concat_butlast_last[OF \<open>ws \<noteq> \<epsilon>\<close>] by fastforce
 
 lemmas takedrop = append_take_drop_id
 
+lemma suf_drop_conv: "u \<le>s w \<longleftrightarrow> drop (\<^bold>|w\<^bold>| - \<^bold>|u\<^bold>|) w = u"
+  using suffix_take append_take_drop_id same_append_eq suffix_drop by metis
+
 lemma comm_rev_iff: "rev u \<cdot> rev v = rev v \<cdot> rev u \<longleftrightarrow> u \<cdot> v = v \<cdot> u"
   unfolding rev_append[symmetric] rev_is_rev_conv eq_ac(1)[of "u \<cdot> v"] by blast
 
 lemma rev_induct2:
   "\<lbrakk> P [] [];
   \<And>x xs. P (xs\<cdot>[x]) [];
   \<And>y ys. P [] (ys\<cdot>[y]);
   \<And>x xs y ys. P xs ys  \<Longrightarrow> P (xs\<cdot>[x]) (ys\<cdot>[y]) \<rbrakk>
  \<Longrightarrow> P xs ys"
 proof (induct xs arbitrary: ys rule: rev_induct)
   case Nil
   then show ?case
     using rev_induct[of "P \<epsilon>"]
     by presburger
 next
   case (snoc x xs)
   hence "P xs ys'" for ys'
     by simp
   then show ?case
     by (simp add: rev_induct snoc.prems(2) snoc.prems(4))
 qed
 
+lemma fin_bin: "finite {x,y}" 
+  by simp
+
+lemma rev_rev_image_eq: "rev ` rev ` X = X"
+  by (simp add: image_comp)
+
+lemma last_take_conv_nth: assumes "n < length xs" shows "last (take (Suc n) xs) = xs!n" 
+  unfolding take_Suc_conv_app_nth[OF assms] by simp
+
+lemma inj_map_inv: "inj_on f A \<Longrightarrow> u \<in> lists A \<Longrightarrow> u = map (the_inv_into A f) (map f u)"
+  by (induct u,  simp, simp add: the_inv_into_f_f)
+
+lemma last_sing[simp]: "last [c] = c"
+   by simp
+
+lemma hd_hdE: "(u = \<epsilon> \<Longrightarrow> thesis) \<Longrightarrow> (u = [hd u] \<Longrightarrow> thesis) \<Longrightarrow> (u = [hd u, hd (tl u)] \<cdot> tl (tl u) \<Longrightarrow> thesis) \<Longrightarrow> thesis"
+  using Cons_eq_appendI[of "hd u" "[hd (tl u)]" _ "tl u" "tl (tl u)"] hd_tl[of u] hd_tl[of "tl u"] hd_word
+   by fastforce
+
+subsection \<open>General facts\<close>
+
+lemma two_elem_sub: "x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> {x,y} \<subseteq> A"
+  by simp 
+
+thm fun.inj_map[THEN injD]
+
+lemma inj_comp: assumes "inj (f :: 'a list \<Rightarrow> 'b list)" shows "(g  w = h w \<longleftrightarrow> (f \<circ> g) w = (f \<circ> h) w)"
+  by (rule, simp) (use injD[OF assms] in fastforce) 
+  
+lemma inj_comp_eq: assumes "inj (f :: 'a list \<Rightarrow> 'b list)" shows "(g = h \<longleftrightarrow> f \<circ> g = f \<circ> h)"
+  by (rule, fast)  (use fun.inj_map[OF assms, unfolded inj_on_def] in fast)
+
+lemma two_elem_cases[elim!]: assumes "u \<in> {x, y}" obtains (fst) "u = x" | (snd) "u = y"
+  using assms by blast
+
+lemma two_elem_cases2[elim]: assumes "u \<in> {x, y}" "v \<in> {x,y}" "u \<noteq> v"
+  shows "(u = x \<Longrightarrow> v = y \<Longrightarrow> thesis) \<Longrightarrow> (u = y \<Longrightarrow> v = x \<Longrightarrow> thesis) \<Longrightarrow> thesis"
+  using assms by blast 
+
+lemma two_elemP: "u \<in> {x, y} \<Longrightarrow> P x \<Longrightarrow> P y \<Longrightarrow> P u"
+  by blast
+
+lemma pairs_extensional: "(\<And> r s. P r s \<longleftrightarrow> (\<exists> a b. Q a b \<and> r = fa a \<and> s = fb b)) \<Longrightarrow>  {(r,s). P r s} = {(fa a, fb b) | a b. Q a b}"
+  by auto
+
+lemma pairs_extensional': "(\<And> r s. P r s \<longleftrightarrow> (\<exists> t. Q t \<and> r = fa t \<and> s = fb t)) \<Longrightarrow>  {(r,s). P r s} = {(fa t, fb t) | t. Q t}"
+  by auto
+
+lemma doubleton_subset_cases: assumes "A \<subseteq> {x,y}"
+  obtains  "A = {}" | "A = {x}" | "A = {y}" | "A = {x,y}"
+  using assms by blast
+
+subsection \<open>Map injective function\<close>
+
+lemma map_pref_conv [reversal_rule]: assumes "inj f" shows "map f u \<le>p map f v \<longleftrightarrow> u \<le>p v"
+  using map_mono_prefix[of "map f u" "map f v" "inv f"] map_mono_prefix
+  unfolding map_map inv_o_cancel[OF \<open>inj f\<close>] list.map_id..
+
+lemma map_suf_conv [reversal_rule]: assumes "inj f" shows "map f u \<le>s map f v \<longleftrightarrow> u \<le>s v"
+  using map_mono_suffix[of "map f u" "map f v" "inv f"] map_mono_suffix
+  unfolding map_map inv_o_cancel[OF \<open>inj f\<close>] list.map_id..
+
+lemma map_fac_conv [reversal_rule]: assumes "inj f" shows "map f u \<le>f map f v \<longleftrightarrow> u \<le>f v"
+  using map_mono_sublist[of "map f u" "map f v" "inv f"] map_mono_sublist
+  unfolding map_map inv_o_cancel[OF \<open>inj f\<close>] list.map_id..
+
+lemma map_lcp_conv: assumes "inj f" shows "(map f xs) \<and>\<^sub>p (map f ys) = map f (xs \<and>\<^sub>p ys)"
+proof (induct xs ys rule: list_induct2', simp, simp, simp)
+  case (4 x xs y ys)
+  then show ?case
+  proof (cases "x = y")
+    assume "x = y" 
+    thus ?case  
+      using "4.hyps" by simp
+  next
+    assume "x \<noteq> y"
+    hence "f x \<noteq> f y" 
+      using inj_eq[OF \<open>inj f\<close>] by simp
+    thus ?case using \<open>x \<noteq> y\<close> by simp 
+  qed
+qed
+
 subsection \<open>Orderings on lists: prefix, suffix, factor\<close>
 
-lemmas self_pref = prefix_order.refl
-lemmas pref_antisym = prefix_order.antisym
-lemmas pref_trans = prefix_order.trans
-lemmas suf_trans = suffix_order.trans
-
+lemmas self_pref = prefix_order.refl and
+       pref_antisym = prefix_order.antisym and
+       pref_trans = prefix_order.trans and
+       suf_trans = suffix_order.trans and
+       fac_trans[intro] = sublist_order.order.trans
 
 subsection "On the empty word"
 
 lemma nemp_elem_setI[intro]: "u \<in> S \<Longrightarrow> u \<noteq> \<epsilon> \<Longrightarrow> u \<in> S\<^sub>+"
   by simp
 
 lemma nel_drop_emp: "u \<noteq> \<epsilon> \<Longrightarrow> u \<in> S \<Longrightarrow> u \<in> S\<^sub>+"
   by simp
 
 lemma drop_emp_nel: assumes "u \<in> S\<^sub>+" shows "u \<noteq> \<epsilon>" and "u \<in> S"
   using assms by simp+
 
 lemma emp_concat_emp: "us \<in> lists S\<^sub>+ \<Longrightarrow> concat us = \<epsilon> \<Longrightarrow> us = \<epsilon>"
   using DiffD2 by auto
 
 lemma take_nemp: "w \<noteq> \<epsilon> \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> take n w \<noteq> \<epsilon>"
   by simp
 
 lemma pref_nemp [intro]: "u \<noteq> \<epsilon> \<Longrightarrow> u \<cdot> v \<noteq> \<epsilon>"
   unfolding append_is_Nil_conv by simp
 
 lemma suf_nemp [intro]: "v \<noteq> \<epsilon> \<Longrightarrow> u \<cdot> v \<noteq> \<epsilon>"
   unfolding append_is_Nil_conv by simp
 
+lemma pref_of_emp: "u \<cdot> v = \<epsilon> \<Longrightarrow> u = \<epsilon>"
+  using append_is_Nil_conv by simp
+
+lemma suf_of_emp: "u \<cdot> v = \<epsilon> \<Longrightarrow> v = \<epsilon>"
+  using append_is_Nil_conv by simp
+
+lemma nemp_comm [intro]: "(u \<noteq> \<epsilon> \<Longrightarrow> v \<noteq> \<epsilon> \<Longrightarrow> u \<cdot> v = v \<cdot> u) \<Longrightarrow> u \<cdot> v = v \<cdot> u"
+  by force
+
+lemma split_list': "a \<in> set ws \<Longrightarrow> \<exists>p s. ws = p \<cdot> [a] \<cdot> s"
+  using split_list by fastforce
+
+lemma split_listE: assumes "a \<in> set w"
+  obtains p s where "w = p \<cdot> [a] \<cdot> s"
+  using exE2[OF split_list'[OF assms]].
+
+subsection \<open>Counting letters\<close> 
+
+lemma count_list_append: "count_list (x\<cdot>y) a = count_list x a + count_list y a"
+  by (induct x, auto)
+
+lemma count_list_rev_conv [reversal_rule]: "count_list (rev w) a = count_list w a"
+  by (induction w) (simp_all add: count_list_append)
+
+lemma count_list_map_conv [reversal_rule]:
+  assumes "inj f" shows "count_list (map f ws) (f a) = count_list ws a"
+  by (induction ws) (simp_all add: inj_eq[OF assms])
+
+subsection "Set inspection method"
+
+text\<open>This section defines a simple method that splits a goal into subgoals by enumerating
+  all possibilites for @{term "x"} in a premise such as @{term "x \<in> {a,b,c}"}. 
+  See the demonstrations below.\<close>
+
+method set_inspection = (
+    (unfold insert_iff),   
+    (elim disjE emptyE),
+    (simp_all only: singleton_iff refl True_implies_equals)
+    )
+
+lemma "u \<in> {x,y} \<Longrightarrow> P u"
+  apply(set_inspection)
+  oops
+
+lemma "\<And>u. u \<in> {x,y} \<Longrightarrow> u = x \<or> u = y"
+  by(set_inspection, simp_all)
+
+
 section "Length and its properties"
 
-lemma lenarg: "u = v \<Longrightarrow> \<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|"
-  by simp
+lemmas lenarg = arg_cong[of _ _ length] and
+       lenmorph = length_append
+
+lemma lenarg_not: "\<^bold>|u\<^bold>| \<noteq> \<^bold>|v\<^bold>| \<Longrightarrow> u \<noteq> v"
+  using size_neq_size_imp_neq.
+
+lemma len_less_neq: "\<^bold>|u\<^bold>| < \<^bold>|v\<^bold>| \<Longrightarrow> u \<noteq> v"
+  by blast
+
+lemmas len_nemp_conv = length_greater_0_conv
 
 lemma npos_len: "\<^bold>|u\<^bold>| \<le> 0 \<Longrightarrow> u = \<epsilon>"
   by simp
 
-lemma nemp_pos_len: "r \<noteq> \<epsilon> \<Longrightarrow> 1 \<le> \<^bold>|r\<^bold>|"
+lemma nemp_pos_len: "w \<noteq> \<epsilon> \<Longrightarrow> 0 < \<^bold>|w\<^bold>|" 
+  by blast
+
+lemma nemp_le_len: "r \<noteq> \<epsilon> \<Longrightarrow> 1 \<le> \<^bold>|r\<^bold>|"
   by (simp add: leI)
 
 lemma swap_len: "\<^bold>|u \<cdot> v\<^bold>| = \<^bold>|v \<cdot> u\<^bold>|"
   by simp
 
 lemma len_after_drop: "p + q \<le> \<^bold>|w\<^bold>| \<Longrightarrow>  q \<le> \<^bold>|drop p w\<^bold>|"
   by simp
 
 lemma short_take_append: "n \<le> \<^bold>|u\<^bold>|\<Longrightarrow> take n (u \<cdot> v) = take n u"
   by simp
 
 lemma sing_word: "\<^bold>|us\<^bold>| = 1 \<Longrightarrow> [hd us] = us"
   by (cases us) simp+
 
 lemma sing_word_concat: assumes "\<^bold>|us\<^bold>| = 1" shows "[concat us] = us"
-  by (simp add: assms concat_sing sing_word)
+  unfolding concat_sing[OF sing_word[OF \<open>\<^bold>|us\<^bold>| = 1\<close>, symmetric]] using sing_word[OF \<open>\<^bold>|us\<^bold>| = 1\<close>].
+
+lemma len_one_concat_in: "ws \<in> lists A \<Longrightarrow> \<^bold>|ws\<^bold>| = 1 \<Longrightarrow> concat ws \<in> A"
+  using Cons_in_lists_iff sing_word_concat by metis
 
 lemma nonsing_concat_len: "\<^bold>|us\<^bold>| \<noteq> 1 \<Longrightarrow> concat us \<noteq> \<epsilon> \<Longrightarrow> 1 < \<^bold>|us\<^bold>|"
   using nat_neq_iff by fastforce
 
 lemma sing_len: "\<^bold>|[a]\<^bold>| = 1"
   by simp
 
+lemmas pref_len = prefix_length_le and
+       suf_len = suffix_length_le
+
 lemma pref_len': "\<^bold>|u\<^bold>| \<le> \<^bold>|u \<cdot> z\<^bold>|"
   by auto
 
 lemma suf_len': "\<^bold>|u\<^bold>| \<le> \<^bold>|z \<cdot> u\<^bold>|"
   by auto
 
 lemma fac_len: "u \<le>f v \<Longrightarrow> \<^bold>|u\<^bold>| \<le> \<^bold>|v\<^bold>|"
   by auto
 
 lemma fac_len': "\<^bold>|w\<^bold>| \<le> \<^bold>|u \<cdot> w \<cdot> v\<^bold>|"
   by simp
 
 lemma fac_len_eq: "u \<le>f v \<Longrightarrow> \<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \<Longrightarrow> u = v"
-  unfolding factor_def using length_append npos_len by fastforce
+  unfolding fac_def using lenmorph npos_len by fastforce
+
+thm length_take
+
+lemma len_take1: "\<^bold>|take p w\<^bold>| \<le> p"
+  by simp
+
+lemma len_take2: "\<^bold>|take p w\<^bold>| \<le> \<^bold>|w\<^bold>|"
+  by simp
 
 lemma drop_len: "\<^bold>|u \<cdot> w\<^bold>| \<le> \<^bold>|u \<cdot> v \<cdot> w\<^bold>|"
   by simp
 
 lemma drop_pref: "drop \<^bold>|u\<^bold>| (u \<cdot> w) = w"
   by simp
 
 lemma take_len: "p \<le> \<^bold>|w\<^bold>| \<Longrightarrow> \<^bold>|take p w\<^bold>| = p"
-  using trans[OF length_take min_absorb2].
+  using  min_absorb2[of p "\<^bold>|w\<^bold>|", folded length_take[of p w]]. 
 
 lemma conj_len: "p \<cdot> x = x \<cdot> s \<Longrightarrow> \<^bold>|p\<^bold>| = \<^bold>|s\<^bold>|"
-  using length_append[of p x] length_append[of x s] add.commute add_left_imp_eq
+  using lenmorph[of p x] lenmorph[of x s] add.commute add_left_imp_eq
   by auto
 
 lemma take_nemp_len: "u \<noteq> \<epsilon> \<Longrightarrow> r \<noteq> \<epsilon> \<Longrightarrow> take \<^bold>|r\<^bold>| u \<noteq> \<epsilon>"
   by simp
 
 lemma nemp_len: "u \<noteq> \<epsilon> \<Longrightarrow> \<^bold>|u\<^bold>| \<noteq> 0"
   by simp
 
+lemma emp_len: "w = \<epsilon> \<Longrightarrow> \<^bold>|w\<^bold>| = 0" 
+  by simp
+
 lemma take_self: "take \<^bold>|w\<^bold>| w = w"
   using take_all[of w "\<^bold>|w\<^bold>|", OF order.refl].
 
 lemma len_le_concat: "\<epsilon> \<notin>  set ws \<Longrightarrow> \<^bold>|ws\<^bold>| \<le> \<^bold>|concat ws\<^bold>|"
 proof (induct ws, simp)
   case (Cons a ws)
   hence "1 \<le> \<^bold>|a\<^bold>|"
-    using list.set_intros(1)[of a ws] nemp_pos_len[of a] by blast
+    using list.set_intros(1)[of a ws] nemp_le_len[of a] by blast
   then show ?case
-    unfolding   concat.simps(2)  unfolding  length_append hd_word[of a ws] sing_len
+    unfolding   concat.simps(2)  unfolding  lenmorph hd_word[of a ws] sing_len
     using Cons.hyps Cons.prems by simp
 qed
 
 lemma eq_len_iff: assumes eq: "x \<cdot> y = u \<cdot> v" shows "\<^bold>|x\<^bold>| \<le> \<^bold>|u\<^bold>| \<longleftrightarrow> \<^bold>|v\<^bold>| \<le> \<^bold>|y\<^bold>|"
-  using lenarg[OF eq] unfolding length_append by auto
+  using lenarg[OF eq] unfolding lenmorph by auto
 
 lemma eq_len_iff_less: assumes eq: "x \<cdot> y = u \<cdot> v" shows "\<^bold>|x\<^bold>| < \<^bold>|u\<^bold>| \<longleftrightarrow> \<^bold>|v\<^bold>| < \<^bold>|y\<^bold>|"
-  using lenarg[OF eq] unfolding length_append by auto
+  using lenarg[OF eq] unfolding lenmorph by auto
+
+lemma Suc_len_nemp: "\<^bold>|w\<^bold>| = Suc n \<Longrightarrow> w \<noteq> \<epsilon>" 
+  by force
+
+lemma same_sufix_nil: assumes "z \<cdot> u \<le>p u" shows "z = \<epsilon>"
+  using prefix_length_le[OF assms] unfolding lenmorph by simp 
+
+lemma count_list_gr_0_iff: "0 < count_list u a \<longleftrightarrow> a \<in> set u"
+  by (intro iffI, use count_notin[folded not_gr0, of a u] in blast) (induction u, auto)
+
+section "List inspection method"
+
+text\<open>In this section we define a proof method, named list\_inspection, which splits the goal into subgoals which enumerate possibilities 
+  on lists with fixed length and given alphabet.
+  More specifically, it looks for a premise of the form  such as @{term "\<^bold>|w\<^bold>| = 2 \<and> w \<in> lists {x,y,z}"} or @{term "\<^bold>|w\<^bold>| \<le> 2 \<and> w \<in> lists {x,y,z}"}
+  and substitutes the goal by the goals listing all possibilities for the word @{term w}, see demonstrations
+  after the method definition.\<close>
+
+context
+begin
+
+text\<open>First, we define an elementary lemma used for unfolding the premise.
+Since it is very specific, we keep it private.\<close>
+
+private lemma hd_tl_len_list_iff:  "\<^bold>|w\<^bold>| = Suc n \<and> w \<in> lists A \<longleftrightarrow> hd w \<in> A \<and>  w = hd w # tl w \<and> \<^bold>|tl w\<^bold>| = n \<and> tl w \<in> lists A" (is "?L = ?R")
+proof
+  show "?L \<Longrightarrow> ?R"
+  proof (elim conjE)
+    assume "\<^bold>|w\<^bold>| = Suc n" and "w \<in> lists A"
+    note Suc_len_nemp[OF \<open>\<^bold>|w\<^bold>| = Suc n\<close>]  
+    from lists_hd_in_set[OF \<open>w \<noteq> \<epsilon>\<close> \<open>w \<in> lists A\<close>] list.collapse[OF \<open>w \<noteq> \<epsilon>\<close>] tl_in_lists[OF \<open>w \<in> lists A\<close>]
+    show "hd w \<in> A \<and> w = hd w # tl w \<and> \<^bold>|tl w\<^bold>| = n \<and> tl w \<in> lists A"
+      using \<open>\<^bold>|w\<^bold>| = Suc n\<close> by simp
+  qed
+next 
+  show "?R \<Longrightarrow> ?L"
+    using Cons_in_lists_iff[of "hd w" "tl w"] length_Cons[of "hd w" "tl w"] by presburger
+qed
+
+text\<open>We define a list of lemmas used for the main unfolding step.\<close>
+
+private lemmas len_list_word_dec =
+    numeral_nat hd_tl_len_list_iff
+    insert_iff empty_iff simp_thms length_0_conv
+
+text\<open>The method itself accepts an argument called `add`, which is supplied to the method
+ simp\_all to solve some simple cases, and thus lower the number of produced goals on the fly.\<close>
+
+method list_inspection = (
+    ((match premises in len[thin]: "\<^bold>|w\<^bold>| \<le> k" and list[thin]: "w \<in> lists A"  for w k A \<Rightarrow>
+        \<open>insert conjI[OF len list]\<close>)+)?,
+    (unfold numeral_nat le_Suc_eq le_0_eq), \<comment> \<open>unfold numeral and e.g. @{term "k \<le> 2"}\<close>    
+    (unfold conj_ac(1)[of "w \<in> lists A" "\<^bold>|w\<^bold>| \<le> k" for w A k]
+          conj_disj_distribR[where ?R = "w \<in> lists A" for w A])?,   
+    ((match premises in len[thin]: "\<^bold>|w\<^bold>| = k" and list[thin]: "w \<in> lists A"  for w k A \<Rightarrow>
+        \<open>insert conjI[OF len list]\<close>)+)?,
+        \<comment> \<open>transform into the conjuction such as @{term "length w = 2 \<and> w \<in> lists {x,y,z}"}\<close>
+    (unfold conj_ac(1)[of "w \<in> lists A" "\<^bold>|w\<^bold>| = k" for w A k] len_list_word_dec), \<comment> \<open>unfold w\<close>
+    (elim disjE conjE), \<comment> \<open>split into all cases\<close>
+    (simp_all only: singleton_iff lists.Nil list.sel refl True_implies_equals)?, \<comment> \<open>replace w everywhere\<close>
+    (simp_all only: empty_iff lists.Nil bool_simps)? \<comment> \<open>solve simple cases\<close>
+)
+
+subsubsection "List inspection demonstrations"
+
+text\<open>The required premise in the form of conjuction.
+First, inequality bound on the length, second, equality bound.\<close>
+
+lemma "\<^bold>|w\<^bold>| \<le> 2 \<Longrightarrow> w \<in> lists {x,y,z} \<Longrightarrow> P w"
+  apply(list_inspection)
+  oops
+
+lemma "\<^bold>|w\<^bold>| = 2 \<and> w \<in> lists {x,y,z} \<Longrightarrow> P w"
+  apply(list_inspection)
+  oops
+
+text\<open>The required premise in of 2 separate assumptions.\<close>
+
+lemma "w \<le>p w \<Longrightarrow> \<^bold>|w\<^bold>| \<le> 2 \<Longrightarrow> w \<in> lists {a,b} \<Longrightarrow> hd w = a \<Longrightarrow> w \<noteq> \<epsilon> \<Longrightarrow>  w = [a, b] \<or> w = [a, a] \<or> w = [a]" 
+  by list_inspection
+
+lemma "w \<le>p w \<Longrightarrow> \<^bold>|w\<^bold>| = 2 \<Longrightarrow> w \<in> lists {a,b} \<Longrightarrow> hd w = a \<Longrightarrow>  w = [a, b] \<or> w = [a, a]" 
+  by list_inspection
+
+lemma "w \<le>p w \<Longrightarrow> \<^bold>|w\<^bold>| = 2 \<and> w \<in> lists {a,b} \<Longrightarrow> hd w = a \<Longrightarrow>  w = [a, b] \<or> w = [a, a]" 
+  by list_inspection
+
+lemma "w \<le>p w \<Longrightarrow> w \<in> lists {a,b} \<and> \<^bold>|w\<^bold>| = 2 \<Longrightarrow> hd w = a \<Longrightarrow>  w = [a, b] \<or> w = [a, a]" 
+  by list_inspection
+
+end (* end list inspection unnamed context *)
 
 section "Prefix and prefix comparability properties"
 
 lemmas pref_emp = prefix_bot.extremum_uniqueI
 
 lemma triv_pref: "r \<le>p r \<cdot> s"
   using prefI[OF refl].
 
 lemma triv_spref: "s \<noteq> \<epsilon> \<Longrightarrow> r <p r \<cdot> s"
   by simp
 
 lemma pref_cancel: "z \<cdot> u \<le>p z \<cdot> v \<Longrightarrow> u \<le>p v"
   by simp
 
 lemma pref_cancel': "u \<le>p v \<Longrightarrow> z \<cdot> u \<le>p z \<cdot> v"
   by simp
 
-lemmas pref_cancel_conv = same_prefix_prefix
+lemmas pref_cancel_conv = same_prefix_prefix and
+       suf_cancel_conv = same_suffix_suffix \<comment> \<open>provided by Sublist.thy\<close>
+
+lemma pref_cancel_hd_conv: "a # u \<le>p a # v \<longleftrightarrow> u \<le>p v"
+  by simp
+
+lemma spref_cancel_conv: "z \<cdot> x <p z \<cdot> y \<longleftrightarrow> x <p y"
+  by auto
+
+lemma spref_snoc_iff [simp]: "u <p v \<cdot> [a] \<longleftrightarrow> u \<le>p v"
+  by (auto simp only: strict_prefix_def prefix_snoc) simp
 
 lemmas pref_ext = prefix_prefix \<comment> \<open>provided by Sublist.thy\<close>
 
+lemmas pref_extD = append_prefixD
+
+lemma spref_extD: "x \<cdot> y <p z \<Longrightarrow> x <p z"
+  using prefix_order.le_less_trans[OF triv_pref].
+
 lemma spref_ext: "r <p u \<Longrightarrow> r <p u \<cdot> v"
   by force
 
 lemma pref_ext_nemp: "r \<le>p u \<Longrightarrow> v \<noteq> \<epsilon> \<Longrightarrow> r <p u \<cdot> v"
   by auto
 
 lemma pref_take: "p \<le>p w \<Longrightarrow> take \<^bold>|p\<^bold>| w = p"
-  by auto
+  unfolding prefix_def  by force
 
 lemma pref_take_conv: "take (\<^bold>|r\<^bold>|) w = r \<longleftrightarrow> r \<le>p w"
   using pref_take[of r w] take_is_prefix[of "\<^bold>|r\<^bold>|" w] by argo
 
 lemma le_suf_drop: assumes "i \<le> j" shows "drop j w \<le>s drop i w"
   using suffix_drop[of "j - i" "drop i w", unfolded drop_drop le_add_diff_inverse2[OF \<open>i \<le> j\<close>]].
 
 lemma spref_take: "p <p w \<Longrightarrow> take \<^bold>|p\<^bold>| w = p"
-  by auto
-
-lemma pref_same_len: "u \<le>p v \<Longrightarrow> \<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \<Longrightarrow> u = v"
-  by auto
+   by fastforce
+
+lemma pref_same_len: "u \<le>p v \<Longrightarrow> \<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \<Longrightarrow> u = v" 
+  by (fastforce simp add: prefix_def)
+
+lemma pref_comp_eq: "u \<bowtie> v \<Longrightarrow> \<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \<Longrightarrow> u = v"
+  using pref_same_len by fastforce
+
+lemma ruler_eq_len: "u \<le>p w \<Longrightarrow> v \<le>p w \<Longrightarrow> \<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \<Longrightarrow> u = v"
+  by (fastforce simp add: prefix_def)
+
+lemma pref_prod_eq: "u \<le>p v \<cdot> z \<Longrightarrow> \<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \<Longrightarrow> u = v"
+  by (fastforce simp add: prefix_def)
+
+lemmas  pref_comm_eq = pref_same_len[OF _ swap_len] and
+        pref_comm_eq' = pref_prod_eq[OF _ swap_len, unfolded rassoc]
+
+lemma pref_comm_eq_conv: "u \<cdot> v \<le>p v \<cdot> u \<longleftrightarrow> u \<cdot> v = v \<cdot> u"
+  using pref_comm_eq self_pref by metis 
 
 lemma add_nth_pref: assumes "u <p w" shows "u \<cdot> [w!\<^bold>|u\<^bold>|] \<le>p w"
   using add_nth[OF prefix_length_less[OF \<open>u <p w\<close>], unfolded spref_take[OF \<open>u <p w\<close>]].
 
 lemma index_pref: "\<^bold>|u\<^bold>| \<le> \<^bold>|w\<^bold>| \<Longrightarrow> (\<forall> i < \<^bold>|u\<^bold>|.  u!i = w!i) \<Longrightarrow> u \<le>p w"
   using trans[OF sym[OF take_all[OF order_refl]] nth_take_lemma[OF order_refl], of u w]
     take_is_prefix[of "\<^bold>|u\<^bold>|" w] by auto
 
 lemma pref_index: assumes "u \<le>p w" "i < \<^bold>|u\<^bold>|" shows "u!i = w!i"
   using nth_take[OF \<open>i < \<^bold>|u\<^bold>|\<close>, of w, unfolded pref_take[OF \<open>u \<le>p w\<close>]].
 
+
 lemma pref_drop: "u \<le>p v \<Longrightarrow> drop p u \<le>p drop p v"
-  using prefI[OF sym[OF drop_append]] by auto
+  using prefI[OF sym[OF drop_append]] unfolding prefix_def by blast
 
 subsection "Prefix comparability"
 
 lemma pref_comp_sym[sym]: "u \<bowtie> v \<Longrightarrow> v \<bowtie> u"
   by blast
 
 lemmas ruler_le = prefix_length_prefix and
-       ruler = prefix_same_cases and
-       ruler' = prefix_same_cases[folded prefix_comparable_def]
-
-lemma ruler_equal: "u \<le>p w \<Longrightarrow> v \<le>p w \<Longrightarrow> \<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \<Longrightarrow> u = v"
-  by auto
+  ruler = prefix_same_cases and
+  ruler' = prefix_same_cases[folded prefix_comparable_def]
+
+lemma ruler_eq: "u \<cdot> x = v \<cdot> y \<Longrightarrow> u \<le>p v \<or> v \<le>p u"
+  by (metis prefI prefix_same_cases)
+
+lemma ruler_eq': "u \<cdot> x = v \<cdot> y \<Longrightarrow> u \<le>p v \<or> v <p u"
+  using ruler_eq prefix_order.le_less by blast 
+
+lemmas ruler_eqE = ruler_eq[THEN disjE] and
+       ruler_eqE' = ruler_eq'[THEN disjE] and
+       ruler_pref = ruler[OF append_prefixD triv_pref] and
+       ruler'[THEN pref_comp_eq] 
+lemmas ruler_prefE = ruler_pref[THEN disjE]
 
 lemma ruler_comp: "u \<le>p v \<Longrightarrow> u' \<le>p v' \<Longrightarrow> v \<bowtie> v' \<Longrightarrow> u \<bowtie> u'"
   unfolding prefix_comparable_def
   using disjE[OF _ ruler[OF pref_trans] ruler[OF _ pref_trans]].
 
-lemma ruler_pref: "w \<le>p v\<cdot>z \<Longrightarrow> w \<bowtie> v"
-  unfolding prefix_comparable_def
+lemma ruler_pref': "w \<le>p v\<cdot>z \<Longrightarrow> w \<le>p v \<or> v \<le>p w"
   using ruler by blast
 
+lemma ruler_pref'': "w \<le>p v\<cdot>z \<Longrightarrow> w \<bowtie> v"
+  unfolding prefix_comparable_def using ruler_pref'.
+
+lemma pref_cancel_right: assumes "u \<cdot> z \<le>p v \<cdot> z" shows "u \<le>p v"
+proof-
+  have "\<^bold>|u\<^bold>| \<le> \<^bold>|v\<^bold>|"
+    using prefix_length_le[OF assms] by force
+  from ruler_le[of u "v \<cdot> z" v, OF pref_extD[OF assms] triv_pref this] 
+  show "u \<le>p v".
+qed
+
 lemma pref_prod_pref_short: "u \<le>p z \<cdot> w \<Longrightarrow> v \<le>p w \<Longrightarrow> \<^bold>|u\<^bold>| \<le> \<^bold>|z \<cdot> v\<^bold>| \<Longrightarrow> u \<le>p z \<cdot> v"
   using ruler_le[OF _ pref_cancel'].
 
 lemma pref_prod_pref: "u \<le>p z \<cdot> w \<Longrightarrow> u \<le>p w \<Longrightarrow>  u \<le>p z \<cdot> u"
   using pref_prod_pref_short[OF _ _ suf_len'].
 
 lemma pref_prod_pref': assumes "u \<le>p z\<cdot>u\<cdot>w" shows "u \<le>p z\<cdot>u"
   using pref_prod_pref[of  u z "u \<cdot> w", OF \<open>u \<le>p z\<cdot>u\<cdot>w\<close> triv_pref].
 
 lemma pref_prod_long: "u \<le>p v \<cdot> w \<Longrightarrow> \<^bold>|v\<^bold>| \<le> \<^bold>|u\<^bold>| \<Longrightarrow> v \<le>p u"
   using ruler_le[OF triv_pref].
 
+lemmas pref_prod_long_ext = pref_prod_long[OF append_prefixD]
+
+lemma pref_prod_long_less: assumes "u \<le>p v \<cdot> w" and  "\<^bold>|v\<^bold>| < \<^bold>|u\<^bold>|" shows  "v <p u"
+  using sprefI2[OF  pref_prod_long[OF \<open>u \<le>p v \<cdot> w\<close> less_imp_le[OF \<open>\<^bold>|v\<^bold>| < \<^bold>|u\<^bold>|\<close>]] \<open>\<^bold>|v\<^bold>| < \<^bold>|u\<^bold>|\<close>].
+
 lemma pref_keeps_root: "u \<le>p r \<cdot> u \<Longrightarrow> v \<le>p u \<Longrightarrow> v \<le>p r \<cdot> v"
   using pref_prod_pref[of v r u] pref_trans[of v u "r\<cdot>u"] by blast
 
 lemma pref_prolong:  "w \<le>p z \<cdot> r \<Longrightarrow> r \<le>p s \<Longrightarrow> w \<le>p z \<cdot> s"
   using pref_trans[OF _ pref_cancel'].
 
-lemma pref_prolong': assumes "u \<le>p w \<cdot> z" "v \<cdot> u \<le>p z" shows "u \<le>p w \<cdot> v \<cdot> u"
-  using prefix_length_prefix[OF \<open>u \<le>p w \<cdot> z\<close> pref_cancel'[OF \<open>v \<cdot> u \<le>p z\<close>, of w] suf_len'[of u "w\<cdot>v", unfolded rassoc]].
-
+lemmas pref_shorten = pref_trans[OF pref_cancel']
+
+lemma pref_prolong': "u \<le>p w \<cdot> z \<Longrightarrow> v \<cdot> u \<le>p z \<Longrightarrow> u \<le>p w \<cdot> v \<cdot> u"
+  using ruler_le[OF _ pref_cancel' le_trans[OF suf_len' suf_len']].
+
+lemma pref_prolong_per_root: "u \<le>p r \<cdot> s \<Longrightarrow> s \<le>p r \<cdot> s \<Longrightarrow> u \<le>p r \<cdot> u"
+  using pref_prolong[of u r s "r \<cdot> s", THEN pref_prod_pref]. 
+
+thm pref_compE
 lemma pref_prolong_comp: "u \<le>p w \<cdot> z \<Longrightarrow> v \<cdot> u \<bowtie> z \<Longrightarrow> u \<le>p w \<cdot> v \<cdot> u"
-  using pref_prolong[of u w z "v \<cdot> u"] pref_prolong'[of u w z v] by blast
-
-lemma pref_prod_short: "u \<le>p v \<cdot> w \<Longrightarrow> \<^bold>|u\<^bold>| \<le> \<^bold>|v\<^bold>| \<Longrightarrow> u \<le>p v"
-  using  prefI prefix_length_prefix[of u "v\<cdot>w" v]
-  by blast
-
-lemma pref_prod_short': assumes "u \<le>p v \<cdot> w" and "\<^bold>|u\<^bold>| < \<^bold>|v\<^bold>|" shows "u <p v"
-  using pref_prod_short[OF \<open>u \<le>p v \<cdot> w\<close> less_imp_le[OF \<open>\<^bold>|u\<^bold>| < \<^bold>|v\<^bold>|\<close>]]  \<open>\<^bold>|u\<^bold>| < \<^bold>|v\<^bold>|\<close> by blast
+  using pref_prolong' pref_prolong by (elim pref_compE)
+
+lemma pref_prod_le[intro]: "u \<le>p v \<cdot> w \<Longrightarrow> \<^bold>|u\<^bold>| \<le> \<^bold>|v\<^bold>| \<Longrightarrow> u \<le>p v"
+  using ruler_le[OF _ triv_pref].
+
+lemma pref_prod_less: "u \<le>p v \<cdot> w \<Longrightarrow> \<^bold>|u\<^bold>| < \<^bold>|v\<^bold>| \<Longrightarrow> u <p v"
+  using pref_prod_le[OF _ less_imp_le, THEN sprefI2].
+
+lemma eq_le_pref: "x \<cdot> y = u \<cdot> v \<Longrightarrow> \<^bold>|x\<^bold>| \<le> \<^bold>|u\<^bold>| \<Longrightarrow> x \<le>p u"
+  using pref_prod_le[OF prefI].
+
+lemma eq_less_pref: "x \<cdot> y = u \<cdot> v \<Longrightarrow> \<^bold>|x\<^bold>| < \<^bold>|u\<^bold>| \<Longrightarrow> x <p u"
+  using pref_prod_less[OF prefI].
+
+lemma eq_le_suf: assumes "x \<cdot> y = u \<cdot> v" shows "\<^bold>|x\<^bold>| \<le> \<^bold>|u\<^bold>| \<Longrightarrow> v \<le>s y"
+  using eq_le_pref[reversed, folded suffix_to_prefix, OF \<open>x \<cdot> y = u \<cdot> v\<close>[symmetric]]
+  unfolding eq_len_iff[OF \<open>x \<cdot> y = u \<cdot> v\<close>].
+
+lemma eq_less_suf: assumes "x \<cdot> y = u \<cdot> v" shows "\<^bold>|x\<^bold>| < \<^bold>|u\<^bold>| \<Longrightarrow> v <s y"
+  using eq_less_pref[reversed, folded strict_suffix_to_prefix, OF \<open>x \<cdot> y = u \<cdot> v\<close>[symmetric]]
+  unfolding eq_len_iff_less[OF \<open>x \<cdot> y = u \<cdot> v\<close>].
 
 lemma pref_prod_cancel: assumes "u \<le>p p\<cdot>w\<cdot>q" and "\<^bold>|p\<^bold>| \<le> \<^bold>|u\<^bold>|" and "\<^bold>|u\<^bold>| \<le> \<^bold>|p\<cdot>w\<^bold>|"
-  obtains r where "u = p \<cdot> r" and "r \<le>p w"
+  obtains r where "p \<cdot> r = u" and "r \<le>p w"
 proof-
-  have "p \<le>p u"
-    using pref_prod_long[OF \<open>u \<le>p p\<cdot>w\<cdot>q\<close>  \<open>\<^bold>|p\<^bold>| \<le> \<^bold>|u\<^bold>|\<close>].
-  then obtain r where "u = p \<cdot> r" using prefD by blast
-  hence "r \<le>p w"  using \<open>\<^bold>|u\<^bold>| \<le> \<^bold>|p\<cdot>w\<^bold>|\<close> \<open>u \<le>p p\<cdot>w\<cdot>q\<close>
-    unfolding \<open>u = p \<cdot> r\<close> pref_cancel_conv length_append using pref_prod_short[of r w q] by simp
-  from that[OF \<open>u = p \<cdot> r\<close> this]
-  show thesis.
+  obtain r where [symmetric]: "u = p \<cdot> r" using pref_prod_long[OF \<open>u \<le>p p\<cdot>w\<cdot>q\<close>  \<open>\<^bold>|p\<^bold>| \<le> \<^bold>|u\<^bold>|\<close>]..
+  moreover have "r \<le>p w"
+    using pref_prod_le[OF \<open>u \<le>p p\<cdot>w\<cdot>q\<close>[unfolded lassoc] \<open>\<^bold>|u\<^bold>| \<le> \<^bold>|p\<cdot>w\<^bold>|\<close>]
+    unfolding \<open>p \<cdot> r = u\<close>[symmetric] by simp
+  ultimately show thesis..
 qed
 
 lemma pref_prod_cancel': assumes "u \<le>p p\<cdot>w\<cdot>q" and "\<^bold>|p\<^bold>| < \<^bold>|u\<^bold>|" and "\<^bold>|u\<^bold>| \<le> \<^bold>|p\<cdot>w\<^bold>|"
-  obtains r where "u = p \<cdot> r" and "r \<le>p w" and "r \<noteq> \<epsilon>"
+  obtains r where "p \<cdot> r = u" and "r \<le>p w" and "r \<noteq> \<epsilon>"
 proof-
-  obtain r where "u = p \<cdot> r" and "r \<le>p w"
+  obtain r where "p \<cdot> r = u" and "r \<le>p w"
     using pref_prod_cancel[OF \<open>u \<le>p p\<cdot>w\<cdot>q\<close> less_imp_le[OF \<open>\<^bold>|p\<^bold>| < \<^bold>|u\<^bold>|\<close>] \<open>\<^bold>|u\<^bold>| \<le> \<^bold>|p\<cdot>w\<^bold>|\<close>].
-  moreover have "r \<noteq> \<epsilon>" using  \<open>u = p \<cdot> r\<close> less_not_refl3[OF \<open>\<^bold>|p\<^bold>| < \<^bold>|u\<^bold>|\<close>, folded self_append_conv] by simp
-  ultimately show thesis using that by simp
-qed
-
-
-lemma pref_comp_eq: "u \<bowtie> v \<Longrightarrow>\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \<Longrightarrow> u = v"
-  by auto
+  moreover have "r \<noteq> \<epsilon>" using  \<open>p \<cdot> r = u\<close> less_imp_neq[OF \<open>\<^bold>|p\<^bold>| < \<^bold>|u\<^bold>|\<close>] by fastforce
+  ultimately show thesis..
+qed
 
 lemma non_comp_parallel: "\<not> u \<bowtie> v \<longleftrightarrow> u \<parallel> v"
   unfolding prefix_comparable_def parallel_def de_Morgan_disj..
 
 lemma comp_refl: "u \<bowtie> u"
   by simp
 
 lemma incomp_cancel: "\<not> p\<cdot>u \<bowtie> p\<cdot>v \<Longrightarrow> \<not> u \<bowtie> v"
   by simp
 
-lemma comp_cancel: "z \<cdot> u \<bowtie> z \<cdot> v \<Longrightarrow> u \<bowtie> v"
-  by simp
-
 lemma comm_ruler: "r \<cdot> s \<le>p w1 \<Longrightarrow> s \<cdot> r \<le>p w2 \<Longrightarrow> w1 \<bowtie> w2 \<Longrightarrow> r \<cdot> s = s \<cdot> r"
   using pref_comp_eq[OF ruler_comp swap_len].
 
+lemma comm_comp_eq: "r \<cdot> s \<bowtie> s \<cdot> r \<Longrightarrow> r \<cdot> s = s \<cdot> r"
+  using comm_ruler by blast
+
 lemma pref_share_take: "u \<le>p v \<Longrightarrow> q \<le> \<^bold>|u\<^bold>| \<Longrightarrow> take q u = take q v"
-  by auto
+  by (auto simp add: prefix_def)
 
 lemma pref_prod_longer: "u \<le>p z \<cdot> w \<Longrightarrow> v \<le>p w \<Longrightarrow> \<^bold>|z \<cdot> v\<^bold>| \<le> \<^bold>|u\<^bold>|  \<Longrightarrow> z \<cdot> v \<le>p u"
   using ruler_le[OF pref_cancel'].
 
 lemma pref_comp_not_pref: "u \<bowtie> v \<Longrightarrow> \<not> v \<le>p u \<Longrightarrow> u <p v"
   by auto
 
 lemma pref_comp_not_spref: "u \<bowtie> v \<Longrightarrow> \<not> u <p v \<Longrightarrow> v \<le>p u"
   using contrapos_np[OF _ pref_comp_not_pref].
 
 lemma hd_prod: "u \<noteq> \<epsilon> \<Longrightarrow> (u \<cdot> v)!0 = u!0"
   by (cases u) (blast, simp)
 
 lemma distinct_first: assumes "w \<noteq> \<epsilon>" "z \<noteq> \<epsilon>" "w!0 \<noteq> z!0" shows "w \<cdot> w' \<noteq> z \<cdot> z'"
   using hd_prod[of w w', OF \<open>w \<noteq> \<epsilon>\<close>] hd_prod[of z z', OF \<open>z \<noteq> \<epsilon>\<close>] \<open>w!0 \<noteq> z!0\<close> by auto
 
 lemmas last_no_split = prefix_snoc
 
-lemma last_no_split': assumes "u <p w" "w \<le>p u \<cdot> [a]" shows "w = u \<cdot> [a]"
-  using assms(1)[unfolded prefix_order.less_le_not_le] assms(2)[unfolded last_no_split] by presburger
-
-lemma pcomp_shorter: "v \<bowtie> w \<Longrightarrow> \<^bold>|v\<^bold>| \<le> \<^bold>|w\<^bold>| \<Longrightarrow> v \<le>p w"
-  by auto
+lemma last_no_split': "u <p w \<Longrightarrow> w \<le>p u \<cdot> [a] \<Longrightarrow> w = u \<cdot> [a]"
+  unfolding prefix_order.less_le_not_le last_no_split by blast
+
+lemma comp_shorter: "v \<bowtie> w \<Longrightarrow> \<^bold>|v\<^bold>| \<le> \<^bold>|w\<^bold>| \<Longrightarrow> v \<le>p w"
+  by (auto simp add: prefix_def)
 
 lemma pref_comp_len_trans: "w \<le>p v \<Longrightarrow> u \<bowtie> v \<Longrightarrow> \<^bold>|w\<^bold>| \<le> \<^bold>|u\<^bold>| \<Longrightarrow> w \<le>p u"
-  unfolding prefix_comparable_def
-  using prefix_length_prefix[of w v u] prefix_order.trans[of w v u]
-  by argo
-
-lemma comp_ext: "z \<cdot> w1 \<bowtie> z \<cdot> w2 \<longleftrightarrow> w1 \<bowtie> w2"
+  using ruler_le pref_trans by (elim pref_compE)
+
+lemma comp_cancel: "z \<cdot> w1 \<bowtie> z \<cdot> w2 \<longleftrightarrow> w1 \<bowtie> w2"
   using pref_cancel by auto
 
 lemma emp_pref: "\<epsilon> \<le>p u"
   by simp
 
 lemma emp_spref:  "u \<noteq> \<epsilon> \<Longrightarrow> \<epsilon> <p u"
   by simp
 
 lemma long_pref: "u \<le>p v \<Longrightarrow> \<^bold>|v\<^bold>| \<le> \<^bold>|u\<^bold>| \<Longrightarrow> u = v"
-  by auto
-
-lemma incomp_ext: "\<not> w1 \<bowtie>  w2 \<Longrightarrow> \<not> w1 \<cdot> z \<bowtie> w2 \<cdot> z'"
+  by (auto simp add: prefix_def)
+
+lemma not_comp_ext: "\<not> w1 \<bowtie>  w2 \<Longrightarrow> \<not> w1 \<cdot> z \<bowtie> w2 \<cdot> z'"
   using contrapos_nn[OF _ ruler_comp[OF triv_pref triv_pref]].
 
 lemma mismatch_incopm: "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \<Longrightarrow> x \<noteq> y \<Longrightarrow> \<not> u \<cdot> [x] \<bowtie> v \<cdot> [y]"
-  by simp
+  by (auto simp add: prefix_def)
 
 lemma comp_prefs_comp: "u \<cdot> z \<bowtie> v \<cdot> w \<Longrightarrow> u \<bowtie> v"
-  using ruler_comp[OF prefI[of _ z] prefI[of _ w], OF refl refl].
+  using ruler_comp[OF triv_pref triv_pref].
 
 lemma comp_hd_eq: "u \<bowtie> v \<Longrightarrow> u \<noteq> \<epsilon> \<Longrightarrow> v \<noteq> \<epsilon> \<Longrightarrow> hd u = hd v"
-  by auto
+  by (auto simp add: prefix_def)
 
 lemma pref_hd_eq': "p \<le>p u \<Longrightarrow> p \<le>p v \<Longrightarrow> p \<noteq> \<epsilon> \<Longrightarrow>  hd u = hd v"
-  by auto
+  by (auto simp add: prefix_def)
 
 lemma pref_hd_eq: "u \<le>p v \<Longrightarrow> u \<noteq> \<epsilon> \<Longrightarrow>  hd u = hd v"
-  by auto
+  by (auto simp add: prefix_def)
+
+lemma sing_pref_hd: "[a] \<le>p v \<Longrightarrow> hd v = a" 
+  by (auto simp add: prefix_def)
 
 lemma suf_last_eq: "p \<le>s u \<Longrightarrow> p \<le>s v \<Longrightarrow> p \<noteq> \<epsilon> \<Longrightarrow>  last u = last v"
-  by auto
-
-lemma comp_hd_eq': assumes  "u \<cdot> r \<bowtie> v \<cdot> s" "u \<noteq> \<epsilon>" "v \<noteq> \<epsilon>" shows "hd u = hd v"
-  using comp_prefs_comp[OF \<open>u \<cdot> r \<bowtie> v \<cdot> s\<close>] \<open>u \<noteq> \<epsilon>\<close> \<open>v \<noteq> \<epsilon>\<close> by auto
+  by (auto simp add: suf_def)
+
+lemma comp_hd_eq': "u \<cdot> r \<bowtie> v \<cdot> s \<Longrightarrow> u \<noteq> \<epsilon> \<Longrightarrow> v \<noteq> \<epsilon> \<Longrightarrow> hd u = hd v"
+  using comp_hd_eq[OF comp_prefs_comp].
+
+subsection \<open>Minimal and maximal prefix with a given property\<close>
+
+lemma le_take_pref: assumes "k \<le> n" shows "take k ws \<le>p take n ws"
+  using take_add[of k "(n-k)" ws, unfolded le_add_diff_inverse[OF \<open>k \<le> n\<close>]]
+  by force
+
+lemma min_pref: assumes  "u \<le>p w" and "P u"
+  obtains v where "v \<le>p w" and "P v" and  "\<And> y. y \<le>p w \<Longrightarrow> P y \<Longrightarrow> v \<le>p y"
+  using assms
+proof(induction "\<^bold>|u\<^bold>|" arbitrary: u rule: less_induct)
+  case (less u')
+  then show ?case
+  proof (cases "\<forall> y. y \<le>p w \<longrightarrow> P y \<longrightarrow> u' \<le>p y", blast)
+    assume "\<not> (\<forall>y. y \<le>p w \<longrightarrow> P y \<longrightarrow> u' \<le>p y)"
+    then obtain x where "x \<le>p w" and "P x" and " \<not> u' \<le>p x"
+      by blast
+    have "\<^bold>|x\<^bold>| < \<^bold>|u'\<^bold>|"
+      using prefix_length_less[OF pref_comp_not_pref[OF ruler'[OF \<open>x \<le>p w\<close> \<open>u' \<le>p w\<close>]\<open> \<not> u' \<le>p x\<close>]].
+    from less.hyps[OF this _ \<open>x \<le>p w\<close> \<open>P x\<close>] that
+    show thesis by blast
+  qed
+qed
+
+(*ALT proof*)
+(* proof- *)
+  (* define v where "v = take (LEAST n. P (take n w)) w" *)
+  (* from LeastI[of "\<lambda> n. P (take n w)" "\<^bold>|u\<^bold>|", unfolded pref_take[OF \<open>u \<le>p w\<close>], OF \<open>P u\<close>] *)
+  (* have "P v" *)
+    (* unfolding v_def. *)
+  (* have "v \<le>p y" if "y \<le>p w" and "P y" for y *)
+  (* proof- *)
+    (* have "P (take \<^bold>|y\<^bold>| w)" *)                          
+      (* unfolding pref_take[OF \<open>y \<le>p w\<close>] by fact *)
+    (* from le_take_pref[OF Least_le[of "\<lambda> n. P (take n w)" "\<^bold>|y\<^bold>|", unfolded pref_take[OF \<open>y \<le>p w\<close>], OF \<open>P y\<close>], of w, folded v_def] *) 
+    (* show "v \<le>p y" *)
+      (* unfolding pref_take[OF \<open>y \<le>p w\<close>]. *)
+  (* qed *)
+  (* from that[OF _ \<open>P v\<close> this, unfolded v_def, OF take_is_prefix] *) 
+  (* show thesis. *)
+(* qed *)  
+
+lemma min_pref': assumes  "u \<le>p w" and "P u"
+  obtains v where "v \<le>p w" and "P v" and  "\<And> y. y \<le>p v \<Longrightarrow> P y \<Longrightarrow> y = v"
+proof-
+  from min_pref[of _  _ P, OF assms]
+  obtain v where "v \<le>p w" and "P v" and min: "\<And>y. y \<le>p w \<Longrightarrow> P y \<Longrightarrow> v \<le>p y" by blast
+  have "y = v" if "y \<le>p v" and "P y" for y  
+    using min[OF pref_trans[OF \<open>y \<le>p v\<close> \<open>v \<le>p w\<close>] \<open>P y\<close>] \<open>y \<le>p v\<close> by force
+  from that[OF \<open>v \<le>p w\<close> \<open>P v\<close> this]
+  show thesis.
+qed
+
+lemma max_pref: assumes  "u \<le>p w" and "P u"
+  obtains v where "v \<le>p w" and "P v" and  "\<And> y. y \<le>p w \<Longrightarrow> P y \<Longrightarrow> y \<le>p v"
+  using assms
+proof(induction "\<^bold>|w\<^bold>|-\<^bold>|u\<^bold>|" arbitrary: u rule: less_induct)
+  case (less u')
+  then show ?case
+  proof (cases "\<forall> y. y \<le>p w \<longrightarrow> P y \<longrightarrow> y \<le>p u'", blast) 
+    assume "\<not> (\<forall>y. y \<le>p w \<longrightarrow> P y \<longrightarrow>  y \<le>p  u')"
+    then obtain x where "x \<le>p w" and "P x" and "\<not> x \<le>p u'" and "u' \<noteq> w"
+      by blast
+    from ruler'[OF \<open>x \<le>p w\<close> \<open>u' \<le>p w\<close>]
+    have "\<^bold>|u'\<^bold>| < \<^bold>|x\<^bold>|"
+      using  comp_shorter[OF \<open>x \<bowtie> u'\<close>] \<open>\<not> x \<le>p u'\<close> by fastforce
+    hence "\<^bold>|w\<^bold>| - \<^bold>|x\<^bold>| < \<^bold>|w\<^bold>| - \<^bold>|u'\<^bold>|"
+      using  \<open>x \<le>p w\<close>  \<open>u' \<noteq> w\<close> diff_less_mono2 leI[THEN long_pref[OF \<open>u' \<le>p w\<close>]] by blast
+    from less.hyps[OF this _  \<open>x \<le>p w\<close> \<open>P x\<close>] that
+    show thesis by blast
+  qed
+qed
 
 section "Suffix and suffix comparability  properties"
 
 lemmas suf_emp = suffix_bot.extremum_uniqueI
 
 lemma triv_suf: "u \<le>s v \<cdot> u"
-  by simp
+  by (simp add: suf_def)
 
 lemma emp_ssuf: "u \<noteq> \<epsilon> \<Longrightarrow> \<epsilon> <s u"
   by simp
 
 lemma suf_cancel: "u\<cdot>v \<le>s w\<cdot>v \<Longrightarrow> u \<le>s w"
   by simp
 
 lemma suf_cancel': "u \<le>s w \<Longrightarrow> u\<cdot>v \<le>s w\<cdot>v"
   by simp
 
-lemmas suf_cancel_eq = same_suffix_suffix \<comment> \<open>provided by Sublist.thy\<close>
+lemma ssuf_cancel_conv: "x \<cdot> z <s y \<cdot> z \<longleftrightarrow> x <s y"
+  by auto
 
 text\<open>Straightforward relations of suffix and prefix follow.\<close>
 
 lemmas suf_rev_pref_iff = suffix_to_prefix \<comment> \<open>provided by Sublist.thy\<close>
 
 lemmas ssuf_rev_pref_iff = strict_suffix_to_prefix \<comment> \<open>provided by Sublist.thy\<close>
 
 lemma pref_rev_suf_iff: "u \<le>p v \<longleftrightarrow> rev u \<le>s rev v"
   using suffix_to_prefix[of "rev u" "rev v"] unfolding rev_rev_ident
   by blast
 
 lemma spref_rev_suf_iff: "s <p w \<longleftrightarrow> rev s <s rev w"
   using strict_suffix_to_prefix[of "rev s" "rev w", unfolded rev_rev_ident, symmetric].
 
 lemma nsuf_rev_pref_iff: "s \<le>ns w \<longleftrightarrow> rev s \<le>np rev w"
   unfolding nonempty_prefix_def nonempty_suffix_def suffix_to_prefix
   by fast
 
 lemma npref_rev_suf_iff: "s \<le>np w \<longleftrightarrow> rev s \<le>ns rev w"
   unfolding nonempty_prefix_def nonempty_suffix_def pref_rev_suf_iff
   by fast
 
 lemmas [reversal_rule] =
   suf_rev_pref_iff[symmetric]
   pref_rev_suf_iff[symmetric]
   nsuf_rev_pref_iff[symmetric]
   npref_rev_suf_iff[symmetric]
   ssuf_rev_pref_iff[symmetric]
   spref_rev_suf_iff[symmetric]
 
+lemmas sufE = prefixE[reversed] and
+       prefE = prefixE
+
+lemmas suf_prolong_per_root = pref_prolong_per_root[reversed]
+
 lemmas suf_ext = suffix_appendI \<comment> \<open>provided by Sublist.thy\<close>
 
 lemmas ssuf_ext = spref_ext[reversed] and
+  ssuf_extD = spref_extD[reversed] and
   suf_ext_nem = pref_ext_nemp[reversed] and
   suf_same_len = pref_same_len[reversed] and
   suf_take = pref_drop[reversed] and
   suf_share_take = pref_share_take[reversed] and
-  long_suf = long_pref[reversed]
+  long_suf = long_pref[reversed] and
+  strict_suffixE' = strict_prefixE'[reversed] and
+  ssuf_tl_suf  = spref_butlast_pref[reversed]
+
+
+lemma ssuf_Cons_iff [simp]: "u <s a # v \<longleftrightarrow> u \<le>s v"
+  by (auto simp only: strict_suffix_def suffix_Cons) (simp add: suf_def)
+
+lemma ssuf_induct [case_names ssuf]:
+  assumes "\<And>u. (\<And>v. v <s u \<Longrightarrow> P v) \<Longrightarrow> P u"
+  shows "P u"
+proof (induction u rule: list.induct[of "\<lambda>u. \<forall>v. v \<le>s u \<longrightarrow> P v", rule_format, OF _ _ triv_suf],
+       use assms suffix_bot.extremum_strict in blast)
+qed (metis assms ssuf_Cons_iff suffix_Cons) 
 
 subsection "Suffix comparability"
 
 lemma pref_comp_rev_suf_comp[reversal_rule]: "(rev w) \<bowtie>\<^sub>s (rev v) \<longleftrightarrow> w \<bowtie> v"
-  by simp
+  unfolding suffix_comparable_def by simp
 
 lemma suf_comp_rev_pref_comp[reversal_rule]: "(rev w) \<bowtie> (rev v) \<longleftrightarrow> w \<bowtie>\<^sub>s v"
-  by simp
+  unfolding suffix_comparable_def by simp
 
 lemmas suf_ruler_le = suffix_length_suffix \<comment> \<open>provided by Sublist.thy, same as ruler\_le[reversed]\<close>
 
 lemmas suf_ruler = suffix_same_cases \<comment> \<open>provided by Sublist.thy, same as ruler[reversed]\<close>
 
-lemmas suf_ruler_equal = ruler_equal[reversed] and
-    suf_ruler_comp = ruler_comp[reversed] and
-    ruler_suf = ruler_pref[reversed] and
-    suf_prod_short = pref_prod_short[reversed] and
-    suf_prod_short' = pref_prod_short'[reversed] and
-    suf_prod_cancel = pref_prod_cancel[reversed] and
-    suf_prod_cancel' = pref_prod_cancel'[reversed] and
-    suf_prod_suf_short = pref_prod_pref_short[reversed] and
-    suf_prod_suf = pref_prod_pref[reversed] and
-    suf_prod_suf' = pref_prod_pref'[reversed, unfolded rassoc] and
-    suf_prolong = pref_prolong[reversed] and
-    suf_prolong' = pref_prolong'[reversed, unfolded rassoc] and
-    suf_prolong_comp = pref_prolong_comp[reversed, unfolded rassoc] and
-    suf_prod_long = pref_prod_long[reversed] and
-    suf_prod_longer = pref_prod_longer[reversed] and
-    suf_keeps_root = pref_keeps_root[reversed] and
-    comm_suf_ruler = comm_ruler[reversed]
+lemmas suf_ruler_eq_len = ruler_eq_len[reversed] and
+  suf_ruler_comp = ruler_comp[reversed] and
+  ruler_suf'' = ruler_pref''[reversed] and
+  suf_prod_le = pref_prod_le[reversed] and
+  suf_prod_eq = pref_prod_eq[reversed] and
+  suf_prod_less = pref_prod_less[reversed] and
+  suf_prod_cancel = pref_prod_cancel[reversed] and
+  suf_prod_cancel' = pref_prod_cancel'[reversed] and
+  suf_prod_suf_short = pref_prod_pref_short[reversed] and
+  suf_prod_suf = pref_prod_pref[reversed] and
+  suf_prod_suf' = pref_prod_pref'[reversed, unfolded rassoc] and
+  suf_prolong = pref_prolong[reversed] and
+  suf_prolong' = pref_prolong'[reversed, unfolded rassoc] and
+  suf_prolong_comp = pref_prolong_comp[reversed, unfolded rassoc] and
+  suf_prod_long = pref_prod_long[reversed] and
+  suf_prod_long_less = pref_prod_long_less[reversed] and
+  suf_prod_longer = pref_prod_longer[reversed] and
+  suf_keeps_root = pref_keeps_root[reversed] and
+  comm_suf_ruler = comm_ruler[reversed]
 
 lemmas comp_sufs_comp = comp_prefs_comp[reversed] and
   suf_comp_not_suf = pref_comp_not_pref[reversed] and
   suf_comp_not_ssuf = pref_comp_not_spref[reversed] and
   (* hd_no_split = last_no_split[reversed] *) (* this is suffix_Cons *)
-  suf_comp_ext = comp_ext[reversed] and
-  suf_incomp_ext = incomp_ext[reversed] and
+  suf_comp_cancel = comp_cancel[reversed] and
+  suf_not_comp_ext = not_comp_ext[reversed] and
   mismatch_suf_incopm = mismatch_incopm[reversed] and
-  suf_comp_sym[sym] = pref_comp_sym[reversed]
+  suf_comp_sym[sym] = pref_comp_sym[reversed] and
+  suf_comp_refl = comp_refl[reversed]
+
+lemma suf_comp_or: "u \<bowtie>\<^sub>s v \<longleftrightarrow> u \<le>s v \<or> v \<le>s u" 
+  unfolding suffix_comparable_def prefix_comparable_def suf_rev_pref_iff..
+
+lemma comm_comp_eq_conv: "r \<cdot> s \<bowtie> s \<cdot> r \<longleftrightarrow> r \<cdot> s = s \<cdot> r" 
+  using pref_comp_eq[OF _ swap_len] comp_refl by metis
+
+lemma comm_comp_eq_conv_suf: "r \<cdot> s \<bowtie>\<^sub>s s \<cdot> r \<longleftrightarrow> r \<cdot> s = s \<cdot> r"
+  using pref_comp_eq[reversed, OF _ swap_len, of r s] suf_comp_refl[of "r \<cdot> s"] by argo
 
 lemma suf_comp_last_eq: assumes "u \<bowtie>\<^sub>s v" "u \<noteq> \<epsilon>" "v \<noteq> \<epsilon>"
   shows "last u = last v"
-  using comp_hd_eq[reversed, OF assms] unfolding hd_rev hd_rev .
+   using comp_hd_eq[reversed, OF assms] unfolding hd_rev hd_rev.
 
 lemma suf_comp_last_eq': "r \<cdot> u \<bowtie>\<^sub>s s \<cdot> v \<Longrightarrow> u \<noteq> \<epsilon> \<Longrightarrow> v \<noteq> \<epsilon> \<Longrightarrow> last u = last v"
   using comp_sufs_comp suf_comp_last_eq  by blast
 
 section "Left and Right Quotient"
 
 text\<open>A useful function of left quotient is given. Note that the function is sometimes undefined.\<close>
 
 definition left_quotient:: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"   ("(_\<inverse>\<^sup>>)(_)" [75,74] 74)
   where left_quotient_def[simp]: "left_quotient u v  = (if u \<le>p v then (THE z. u \<cdot> z = v) else undefined)"
 notation (latex output) left_quotient  ("\<^latex>\<open>\\ensuremath{ {\<close>_ \<^latex>\<open>}^{-1} \\cdot {\<close> _ \<^latex>\<open>}}\<close>")
 
 text\<open>Analogously, we define the right quotient.\<close>
 
 definition right_quotient :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"  ("(_)(\<^sup><\<inverse>_) " [76,77] 76)
   where right_quotient_def[simp]: "right_quotient u v  = rev ((rev v)\<inverse>\<^sup>>(rev u))"
 notation (latex output) right_quotient ("\<^latex>\<open>\\ensuremath{ {\<close>_ \<^latex>\<open>} \\cdot {\<close> _ \<^latex>\<open>}^{-1}}\<close>")
 
 text\<open>Priorities of these operations are as follows:\<close>
 
 lemma "u\<^sup><\<inverse>v\<^sup><\<inverse>w = (u\<^sup><\<inverse>v)\<^sup><\<inverse>w"
   by simp
 
 lemma "u\<inverse>\<^sup>>v\<inverse>\<^sup>>w = u\<inverse>\<^sup>>(v\<inverse>\<^sup>>w)"
   by simp
 
 lemma "u\<inverse>\<^sup>>v\<^sup><\<inverse>w = u\<inverse>\<^sup>>(v\<^sup><\<inverse>w)"
   by simp
 
 lemma "r \<cdot> u\<inverse>\<^sup>>w\<^sup><\<inverse>v \<cdot> s = r \<cdot> (u\<inverse>\<^sup>>w\<^sup><\<inverse>v) \<cdot> s"
   by simp
 
 
 lemma rq_rev_lq[reversal_rule]: "(rev v)\<^sup><\<inverse>(rev u) = rev (u\<inverse>\<^sup>>v)"
   by simp
 
 lemma lq_rev_rq[reversal_rule]: "(rev v)\<inverse>\<^sup>>rev u = rev (u\<^sup><\<inverse>v)"
   by simp
 
 subsection \<open>Left Quotient\<close>
 
 lemma lqI:  "u \<cdot> z = v \<Longrightarrow> u\<inverse>\<^sup>>v = z"
   by auto
 
 lemma lq_triv[simp]:  "u\<inverse>\<^sup>>(u \<cdot> z) = z"
   using lqI[OF refl].
 
 lemma lq_triv'[simp]:  "u \<cdot> u\<inverse>\<^sup>>(u \<cdot> z) = u \<cdot>z"
   by simp
 
+lemma append_lq: assumes "u\<cdot>v \<le>p w" shows "(u\<cdot>v)\<inverse>\<^sup>>w = v\<inverse>\<^sup>>(u\<inverse>\<^sup>>w)"
+  using lq_triv[of "u\<cdot>v"] lq_triv[of "v"] lq_triv[of "u" "v\<cdot>_"] assms[unfolded pref_def]
+  by force 
+
 lemma lq_self[simp]: "u\<inverse>\<^sup>>u = \<epsilon>"
   by auto
 
 lemma lq_emp[simp]: "\<epsilon>\<inverse>\<^sup>>u = u"
   by auto
 
 lemma lq_pref[simp]: "u \<le>p v \<Longrightarrow> u \<cdot> (u\<inverse>\<^sup>>v) = v"
-  by auto
+  by (auto simp add: prefix_def)
+
+lemmas lcp_lq = lq_pref[OF longest_common_prefix_prefix1] lq_pref[OF longest_common_prefix_prefix2]
+
+lemma lq_pref_cancel: "u \<le>p v \<Longrightarrow> v \<cdot> r = u \<cdot> s \<Longrightarrow>  (u\<inverse>\<^sup>>v) \<cdot> r = s" 
+  by (auto simp add: prefix_def)
 
 lemma lq_the[simp]: "u \<le>p v \<Longrightarrow> (u\<inverse>\<^sup>>v) = (THE z. u \<cdot> z = v)"
   by simp
 
 lemma lq_reassoc: "u \<le>p v \<Longrightarrow> (u\<inverse>\<^sup>>v)\<cdot>w = u\<inverse>\<^sup>>(v\<cdot>w)"
-  by auto
+  by (auto simp add: prefix_def)
 
 lemma lq_trans: "u \<le>p v \<Longrightarrow> v \<le>p w \<Longrightarrow> (u\<inverse>\<^sup>>v) \<cdot> (v\<inverse>\<^sup>>w) = u\<inverse>\<^sup>>w"
-  by auto
-
-lemma lq_rq_reassoc_suf: "u \<le>p z \<Longrightarrow> u \<le>s w \<Longrightarrow> w\<cdot>u\<inverse>\<^sup>>z = w\<^sup><\<inverse>u \<cdot> z"
-  using lq_pref[reversed]
-  by fastforce
+  by (auto simp add: prefix_def)
+
+lemma lq_rq_reassoc_suf: assumes "u \<le>p z" "u \<le>s w" shows "w\<cdot>u\<inverse>\<^sup>>z = w\<^sup><\<inverse>u \<cdot> z"
+  using rassoc[of "w\<^sup><\<inverse>u"  u  "u\<inverse>\<^sup>>z", unfolded lq_pref[OF \<open>u \<le>p z\<close>] lq_pref[reversed, OF \<open>u \<le>s w\<close>]].   
 
 lemma lq_ne: "p \<le>p u\<cdot>p \<Longrightarrow> u \<noteq> \<epsilon> \<Longrightarrow> p\<inverse>\<^sup>>(u\<cdot>p) \<noteq> \<epsilon>"
   using lq_pref[of p "u \<cdot> p"] by fastforce
 
 lemma lq_spref: "u <p v \<Longrightarrow> u\<inverse>\<^sup>>v \<noteq> \<epsilon>"
-  using lq_pref by auto
+  using lq_pref by (auto simp add: prefix_def)
 
 lemma lq_suf_suf: "r \<le>p s \<Longrightarrow> (r\<inverse>\<^sup>>s) \<le>s s"
-  by auto
+  by (auto simp add: prefix_def)
 
 lemma lq_len: "r \<le>p s \<Longrightarrow> \<^bold>|r\<^bold>| +  \<^bold>|r\<inverse>\<^sup>>s\<^bold>| = \<^bold>|s\<^bold>|"
-  by auto
+  by (auto simp add: prefix_def)
 
 lemma pref_lq: "u \<le>p v \<Longrightarrow> v \<le>p w \<Longrightarrow> u\<inverse>\<^sup>>v \<le>p u\<inverse>\<^sup>>w"
-  by auto
+  by (auto simp add: prefix_def)
 
 lemma spref_lq: "u \<le>p v \<Longrightarrow> v <p w \<Longrightarrow> u\<inverse>\<^sup>>v <p u\<inverse>\<^sup>>w"
-  by force
+  by (auto simp add: prefix_def)
+
+lemma pref_gcd_lq: assumes "u \<le>p v" shows "(gcd \<^bold>|u\<^bold>| \<^bold>|u\<inverse>\<^sup>>v\<^bold>|) = gcd \<^bold>|u\<^bold>| \<^bold>|v\<^bold>|"
+         using gcd_add2[of "\<^bold>|u\<^bold>|" "\<^bold>|u\<inverse>\<^sup>>v\<^bold>|", unfolded lq_len[OF assms], symmetric].
 
 lemma conjug_lq: "x \<cdot> z = z \<cdot> y \<Longrightarrow> y = z\<inverse>\<^sup>>(x \<cdot> z)"
   by simp
 
 lemma conjug_emp_emp: "p \<le>p u \<cdot> p \<Longrightarrow> p\<inverse>\<^sup>>(u \<cdot> p) = \<epsilon> \<Longrightarrow> u = \<epsilon>"
   using lq_ne by blast
 
 lemma lq_drop:  "u \<le>p v \<Longrightarrow> u\<inverse>\<^sup>>v = drop \<^bold>|u\<^bold>| v"
-  by fastforce
+  by (auto simp add: prefix_def)
+
+lemma hd_lq_conv_nth: assumes "u <p v" shows "hd(u\<inverse>\<^sup>>v) = v!\<^bold>|u\<^bold>|"
+  using prefix_length_less[OF assms, THEN hd_drop_conv_nth] unfolding lq_drop[OF sprefD1[OF assms]]. 
+
+lemma concat_morph_lq: "us \<le>p ws \<Longrightarrow> concat (us\<inverse>\<^sup>>ws) = (concat us)\<inverse>\<^sup>>(concat ws)"
+  by (auto simp add: prefix_def)
 
 lemma lq_code [code]:
   "left_quotient \<epsilon> v = v"
   "left_quotient (a#u) \<epsilon> = undefined"
   "left_quotient (a#u) (b#v) = (if a=b then left_quotient u v else undefined)"
   by simp_all
 
+lemma pref_cancel_lq: "u \<le>p x \<cdot> y \<Longrightarrow> \<^bold>|x\<^bold>| \<le> \<^bold>|u\<^bold>| \<Longrightarrow> x\<inverse>\<^sup>>u \<le>p y"
+  using lq_pref[OF pref_prod_long] pref_cancel by metis  
+
+lemma pref_cancel_lq_ext: assumes "u \<cdot> v \<le>p x \<cdot> y" and  "\<^bold>|x\<^bold>| \<le> \<^bold>|u\<^bold>|" shows "x\<inverse>\<^sup>>u \<cdot> v \<le>p y"
+proof-
+  note pref_prod_long[OF append_prefixD, OF \<open>u \<cdot> v \<le>p x \<cdot> y\<close> \<open>\<^bold>|x\<^bold>| \<le> \<^bold>|u\<^bold>|\<close>]
+  from  pref_cancel_lq[OF \<open>u \<cdot> v \<le>p x \<cdot> y\<close>] 
+  show "x\<inverse>\<^sup>>u \<cdot> v \<le>p y"
+    unfolding lq_reassoc[OF \<open>x \<le>p u\<close>] using \<open>\<^bold>|x\<^bold>| \<le> \<^bold>|u\<^bold>|\<close> by force
+qed
+
+lemma pref_cancel_lq_ext': assumes "u \<cdot> v \<le>p x \<cdot> y" and  "\<^bold>|u\<^bold>| \<le> \<^bold>|x\<^bold>|" shows "v \<le>p u\<inverse>\<^sup>>x \<cdot> y"
+  using pref_lq[OF triv_pref \<open>u \<cdot> v \<le>p x \<cdot> y\<close>] 
+  unfolding lq_triv lq_reassoc[OF pref_prod_le[OF append_prefixD[OF \<open>u \<cdot> v \<le>p x \<cdot> y\<close>] \<open>\<^bold>|u\<^bold>| \<le> \<^bold>|x\<^bold>|\<close>]].
+
+lemma empty_lq_eq: "r \<le>p z \<Longrightarrow> r\<inverse>\<^sup>>z = \<epsilon> \<Longrightarrow> r = z"
+  unfolding prefix_def by force
+
 subsection "Right quotient"
 
 lemmas rqI = lqI[reversed] and
   rq_triv = lq_triv[reversed] and
   rq_triv' = lq_triv'[reversed] and
-  rq_sefl = lq_self[reversed] and
+  rq_self = lq_self[reversed] and
   rq_emp = lq_emp[reversed] and
   rq_suf = lq_pref[reversed] and
   rq_ssuf = lq_spref[reversed] and
   rq_reassoc = lq_reassoc[reversed] and
   rq_len = lq_len[reversed] and
   rq_trans = lq_trans[reversed] and
   rq_lq_reassoc_suf = lq_rq_reassoc_suf[reversed] and
   rq_ne = lq_ne[reversed] and
   rq_suf_suf = lq_suf_suf[reversed] and
   suf_rq = pref_lq[reversed] and
   ssuf_rq = spref_lq[reversed] and
   conjug_rq = conjug_lq[reversed] and
   conjug_emp_emp' = conjug_emp_emp[reversed] and
-  rq_take = lq_drop[reversed]
+  rq_take = lq_drop[reversed] and
+  empty_rq_eq = empty_lq_eq[reversed] and
+  append_rq = append_lq[reversed]
+
 
 subsection \<open>Left and right quotients combined\<close>
 
+lemma pref_lq_rq_id:  "p \<le>p w \<Longrightarrow> w\<^sup><\<inverse>(p\<inverse>\<^sup>>w) = p"
+  by (auto simp add: prefix_def)
+
+
+lemmas suf_rq_lq_id = pref_lq_rq_id[reversed]
+
 lemma rev_lq': "r \<le>p s \<Longrightarrow> rev (r\<inverse>\<^sup>>s) = (rev s)\<^sup><\<inverse>(rev r)"
-  by auto
+  by simp
 
 lemma pref_rq_suf_lq: "s \<le>s u \<Longrightarrow> r \<le>p (u\<^sup><\<inverse>s) \<Longrightarrow> s \<le>s (r\<inverse>\<^sup>>u)"
   using lq_reassoc[of r "u\<^sup><\<inverse>s" s] rq_suf[of s u] triv_suf[of s "r\<inverse>\<^sup>>u\<^sup><\<inverse>s"]
   by presburger
 
 lemmas suf_lq_pref_rq = pref_rq_suf_lq[reversed]
 
 lemma "w\<cdot>s = v \<Longrightarrow> v\<^sup><\<inverse>s = w" using rqI.
 
 lemma lq_rq_assoc: "s \<le>s u \<Longrightarrow> r \<le>p (u\<^sup><\<inverse>s) \<Longrightarrow> (r\<inverse>\<^sup>>u)\<^sup><\<inverse>s = r\<inverse>\<^sup>>(u\<^sup><\<inverse>s)"
   using lq_reassoc[of r "u\<^sup><\<inverse>s" s] rq_suf[of s u] rqI[of "r\<inverse>\<^sup>>u\<^sup><\<inverse>s" s "r\<inverse>\<^sup>>u"]
   by argo
 
 lemmas rq_lq_assoc = lq_rq_assoc[reversed]
 
 lemma lq_prod: "u \<le>p v\<cdot>u \<Longrightarrow> u \<le>p w \<Longrightarrow>  u\<inverse>\<^sup>>(v\<cdot>u)\<cdot>u\<inverse>\<^sup>>w = u\<inverse>\<^sup>>(v\<cdot>w)"
-  using lq_reassoc[of u "v \<cdot> u" "u\<inverse>\<^sup>>w"] lq_rq_reassoc_suf[of u w "v \<cdot> u", unfolded rq_triv[of v u]]
-  by auto
+  using lq_reassoc[of u "v \<cdot> u" "u\<inverse>\<^sup>>w"] lq_rq_reassoc_suf[of u w "v \<cdot> u", unfolded rq_triv[of v u]] 
+  by (simp add: suf_def)
 
 lemmas rq_prod = lq_prod[reversed]
 
 section \<open>Equidivisibility\<close>
 
 text\<open>Equidivisibility is the following property: if
 \[
 xy = uv,
 \]
 then there exists a word $t$ such that $xt = u$ and $ty = v$, or $ut = x$ and $y = tv$.
 For monoids over words, this property is equivalent to the freeness of the monoid.
 As the monoid of all words is free, we can prove that it is equidivisible.
 Related lemmas based on this property follow.
 \<close>
 
 
 lemma eqd: "x \<cdot> y = u \<cdot> v \<Longrightarrow> \<^bold>|x\<^bold>| \<le> \<^bold>|u\<^bold>| \<Longrightarrow> \<exists> t. x \<cdot> t = u \<and> t \<cdot> v = y"
   by (simp add: append_eq_conv_conj)
 
 lemma eqdE: assumes "x \<cdot> y = u \<cdot> v" and "\<^bold>|x\<^bold>| \<le> \<^bold>|u\<^bold>|"
   obtains t where "x \<cdot> t = u" and "t \<cdot> v = y"
   using eqd[OF assms] by blast
 
 lemma eqdE': assumes "x \<cdot> y = u \<cdot> v" and "\<^bold>|v\<^bold>| \<le> \<^bold>|y\<^bold>|"
   obtains t where "x \<cdot> t = u" and "t \<cdot> v = y"
-  using eqdE[OF assms(1)] lenarg[OF assms(1), unfolded length_append] assms(2)
+  using eqdE[OF assms(1)] lenarg[OF assms(1), unfolded lenmorph] assms(2)
   by auto
 
+thm long_pref
+
+lemma eqd_pref_suf_iff: assumes "x \<cdot> y = u \<cdot> v" shows "x \<le>p u \<longleftrightarrow> v \<le>s y"
+  by (rule linorder_le_cases[of "\<^bold>|x\<^bold>|" "\<^bold>|u\<^bold>|"], use eqd[OF assms] in blast)
+  (use eqd[OF assms[symmetric]] in fastforce)
+
+
+lemma eqd_spref_ssuf_iff: assumes "x \<cdot> y = u \<cdot> v" shows "x <p u \<longleftrightarrow> v <s y"
+  using eqd_pref_suf_iff[OF assms] assms by force
+
 lemma eqd_pref: "x \<cdot> y = u \<cdot> v \<Longrightarrow> \<^bold>|x\<^bold>| \<le> \<^bold>|u\<^bold>| \<Longrightarrow> x \<cdot> (x\<inverse>\<^sup>>u) = u \<and> (x\<inverse>\<^sup>>u) \<cdot> v = y"
   using eqd lq_triv by blast
 
-lemma eqd_prefE: assumes "x \<cdot> y = u \<cdot> v" and  "\<^bold>|x\<^bold>| \<le> \<^bold>|u\<^bold>|"
-  obtains t where "x \<cdot> t = u" and  "t \<cdot> v = y"
-  using eqd_pref assms by blast
-
 lemma eqd_pref1: "x \<cdot> y = u \<cdot> v \<Longrightarrow> \<^bold>|x\<^bold>| \<le> \<^bold>|u\<^bold>| \<Longrightarrow> x \<cdot> (x\<inverse>\<^sup>>u) = u"
   using eqd_pref by blast
 
 lemma eqd_pref2: "x \<cdot> y = u \<cdot> v \<Longrightarrow> \<^bold>|x\<^bold>| \<le> \<^bold>|u\<^bold>| \<Longrightarrow> (x\<inverse>\<^sup>>u) \<cdot> v = y"
   using eqd_pref by blast
 
-lemma eqd_equal: "x \<cdot> y = u \<cdot> v \<Longrightarrow> \<^bold>|x\<^bold>| = \<^bold>|u\<^bold>| \<Longrightarrow> x = u \<and> y = v"
+lemma eqd_eq: "x \<cdot> y = u \<cdot> v \<Longrightarrow> \<^bold>|x\<^bold>| = \<^bold>|u\<^bold>| \<Longrightarrow> x = u \<and> y = v"
   by simp
 
 lemma pref_equal: "u \<le>p v \<cdot> w \<Longrightarrow> \<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \<Longrightarrow> u = v"
-  by simp
+  by (simp add: prefix_def)
 
 lemma eqd_equal_suf: "x \<cdot> y = u \<cdot> v \<Longrightarrow> \<^bold>|y\<^bold>| = \<^bold>|v\<^bold>| \<Longrightarrow> x = u \<and> y = v"
   by simp
 
 lemma eqd_comp: assumes "x \<cdot> y = u \<cdot> v" shows "x \<bowtie> u"
   using le_cases[of "\<^bold>|x\<^bold>|" "\<^bold>|u\<^bold>|" "x \<bowtie> u"]
     eqd_pref1[of x y u v, THEN prefI[of x "x\<inverse>\<^sup>>u" u], OF assms]
     eqd_pref1[of u v x y, THEN prefI[of u "u\<inverse>\<^sup>>x" x], OF assms[symmetric]] by auto
 
 \<comment> \<open>not equal to eqd\_pref1[reversed]\<close>
 lemma eqd_suf1: "x \<cdot> y = u \<cdot> v \<Longrightarrow> \<^bold>|x\<^bold>| \<le> \<^bold>|u\<^bold>| \<Longrightarrow> (y\<^sup><\<inverse>v)\<cdot>v = y"
   using eqd_pref2 rq_triv by blast
 
 \<comment> \<open>not equal to eqd\_pref2[reversed]\<close>
 lemma eqd_suf2: assumes "x \<cdot> y = u \<cdot> v" "\<^bold>|x\<^bold>| \<le> \<^bold>|u\<^bold>|" shows "x \<cdot> (y\<^sup><\<inverse>v) = u"
   using rq_reassoc[OF sufI[OF eqd_suf1[OF \<open>x \<cdot> y = u \<cdot> v\<close> \<open>\<^bold>|x\<^bold>| \<le> \<^bold>|u\<^bold>|\<close>]], of x, unfolded \<open>x \<cdot> y = u \<cdot> v\<close> rq_triv[of u v]].
 
 \<comment> \<open> not equal to eqd\_pref[reversed] \<close>
 lemma eqd_suf: assumes "x \<cdot> y = u \<cdot> v" and "\<^bold>|x\<^bold>| \<le> \<^bold>|u\<^bold>|"
   shows "(y\<^sup><\<inverse>v)\<cdot>v = y \<and> x \<cdot> (y\<^sup><\<inverse>v) = u"
   using eqd_suf1[OF assms] eqd_suf2[OF assms] by blast
 
+context
+begin
+private lemma eqd_exchange_aux:
+  assumes "u \<cdot> v = x \<cdot> y" and "u \<cdot> v' = x \<cdot> y'" and "u' \<cdot> v = x' \<cdot> y" and "\<^bold>|u\<^bold>| \<le> \<^bold>|x\<^bold>|"
+  shows "u' \<cdot> v' = x' \<cdot> y'" 
+  using eqd[OF \<open>u \<cdot> v = x \<cdot> y\<close> \<open>\<^bold>|u\<^bold>| \<le> \<^bold>|x\<^bold>|\<close>] eqd[OF \<open>u \<cdot> v' = x \<cdot> y'\<close> \<open>\<^bold>|u\<^bold>| \<le> \<^bold>|x\<^bold>|\<close>] \<open>u' \<cdot> v = x' \<cdot> y\<close> by force
+
+lemma eqd_exchange:
+  assumes "u \<cdot> v = x \<cdot> y" and "u \<cdot> v' = x \<cdot> y'" and "u' \<cdot> v = x' \<cdot> y"
+  shows "u' \<cdot> v' = x' \<cdot> y'" 
+  using eqd_exchange_aux[OF assms]  eqd_exchange_aux[OF assms[symmetric], symmetric] by force
+end
+
 section \<open>Longest common prefix\<close>
 
-notation longest_common_prefix  ("_ \<and>\<^sub>p _" [61,62] 64) \<comment> \<open>provided by Sublist.thy\<close>
-
 lemmas lcp_simps = longest_common_prefix.simps \<comment> \<open>provided by Sublist.thy\<close>
 
 lemma lcp_sym: "u \<and>\<^sub>p v = v \<and>\<^sub>p u"
   by (induct u v rule: list_induct2') auto
 
- \<comment> \<open>provided by Sublist.thy\<close>
+\<comment> \<open>provided by Sublist.thy\<close>
 lemmas lcp_pref = longest_common_prefix_prefix1
 lemmas lcp_pref' = longest_common_prefix_prefix2
-lemmas pref_pref_lcp = longest_common_prefix_max_prefix
+lemmas pref_pref_lcp[intro] = longest_common_prefix_max_prefix
+
+lemma lcp_pref_ext: "u \<le>p v \<Longrightarrow> u \<le>p (u \<cdot> w) \<and>\<^sub>p (v \<cdot> z)"
+  using longest_common_prefix_max_prefix prefix_prefix triv_pref by metis
+
+lemma pref_non_pref_lcp_pref: assumes "u \<le>p w" and "\<not> u \<le>p z" shows "w \<and>\<^sub>p z <p u"
+proof-
+  note ruler'[OF \<open>u \<le>p w\<close> lcp_pref, of z, unfolded prefix_comparable_def]
+  with pref_trans[of u "w \<and>\<^sub>p z", OF _ lcp_pref'] \<open>\<not> u \<le>p z\<close>
+  show "w \<and>\<^sub>p z <p u"
+    by auto
+qed
+
+lemmas lcp_take = pref_take[OF lcp_pref] and
+       lcp_take' = pref_take[OF lcp_pref']
 
 lemma lcp_take_eq: "take (\<^bold>|u \<and>\<^sub>p v\<^bold>|) u = take (\<^bold>|u \<and>\<^sub>p v\<^bold>|) v"
-  using pref_take[OF lcp_pref[of u v]] pref_take[OF lcp_pref'[of u v]] by simp
+  unfolding lcp_take lcp_take'..
 
 lemma lcp_pref_conv: "u \<and>\<^sub>p v = u \<longleftrightarrow> u \<le>p v"
   unfolding prefix_order.eq_iff[of "u \<and>\<^sub>p v" u]
   using lcp_pref'[of u v]
     lcp_pref[of u v] longest_common_prefix_max_prefix[OF self_pref[of u], of v]
   by auto
 
+lemma lcp_pref_conv': "u \<and>\<^sub>p v = v \<longleftrightarrow> v \<le>p u"
+  using lcp_pref_conv[of v u, unfolded lcp_sym[of v]].
+
+lemma lcp_per_root:  "r \<cdot> s \<and>\<^sub>p s \<cdot> r \<le>p r \<cdot> (r \<cdot> s \<and>\<^sub>p s \<cdot> r)"
+  using  pref_prod_pref[OF pref_prolong[OF lcp_pref triv_pref] lcp_pref'].
+
+lemma lcp_per_root':  "r \<cdot> s \<and>\<^sub>p s \<cdot> r \<le>p s \<cdot> (r \<cdot> s \<and>\<^sub>p s \<cdot> r)"
+  using lcp_per_root[of s r, unfolded lcp_sym[of "s \<cdot> r"]].
+
 lemma pref_lcp_pref: "w \<le>p u \<and>\<^sub>p v \<Longrightarrow> w \<le>p u"
   using lcp_pref pref_trans by blast
 
 lemma pref_lcp_pref': "w \<le>p u \<and>\<^sub>p v \<Longrightarrow> w \<le>p v"
   using pref_lcp_pref[of w v u, unfolded lcp_sym[of v u]].
 
 lemma lcp_self[simp]: "w \<and>\<^sub>p w = w"
   using lcp_pref_conv by blast
 
-lemma lcp_eq: "\<^bold>|u\<^bold>| = \<^bold>|u \<and>\<^sub>p v\<^bold>| \<Longrightarrow> u = u \<and>\<^sub>p v"
+lemma lcp_eq_len: "\<^bold>|u\<^bold>| = \<^bold>|u \<and>\<^sub>p v\<^bold>| \<Longrightarrow> u = u \<and>\<^sub>p v"
   using  long_pref[OF lcp_pref, of u v] by auto
 
 lemma lcp_len: "\<^bold>|u\<^bold>| \<le> \<^bold>|u \<and>\<^sub>p v\<^bold>| \<Longrightarrow> u \<le>p v"
   using long_pref[OF lcp_pref, of u v] unfolding lcp_pref_conv[symmetric].
 
 lemma lcp_len': "\<not> u \<le>p v \<Longrightarrow> \<^bold>|u \<and>\<^sub>p v\<^bold>| < \<^bold>|u\<^bold>|"
   using not_le_imp_less[OF contrapos_nn[OF _ lcp_len]].
 
-lemma incomp_lcp_len: assumes "\<not> u \<bowtie> v" shows "\<^bold>|u \<and>\<^sub>p v\<^bold>| < min \<^bold>|u\<^bold>| \<^bold>|v\<^bold>|"
-  unfolding min_less_iff_conj[of "\<^bold>|u \<and>\<^sub>p v\<^bold>|" "\<^bold>|u\<^bold>|" "\<^bold>|v\<^bold>|"]
-  using assms lcp_len'[of u v] lcp_len'[of v u, folded lcp_sym[of u v]]
-    min_less_iff_conj[of "\<^bold>|u \<and>\<^sub>p v\<^bold>|" "\<^bold>|u\<^bold>|" "\<^bold>|v\<^bold>|"] by blast
+lemma incomp_lcp_len: "\<not> u \<bowtie> v \<Longrightarrow> \<^bold>|u \<and>\<^sub>p v\<^bold>| < min \<^bold>|u\<^bold>| \<^bold>|v\<^bold>|"
+  using lcp_len'[of u v] lcp_len'[of v u] unfolding lcp_sym[of v] min_less_iff_conj by blast
+
+lemma lcp_ext_right_conv: "\<not> r \<bowtie> r' \<Longrightarrow> (r \<cdot> u) \<and>\<^sub>p (r' \<cdot> v) = r \<and>\<^sub>p r'"
+  by (induct r r' rule: list_induct2', simp+)
 
 lemma lcp_ext_right [case_names comp non_comp]: obtains  "r \<bowtie> r'" | "(r \<cdot> u) \<and>\<^sub>p (r' \<cdot> v) = r \<and>\<^sub>p r'"
-proof-
-  have "\<not> r \<bowtie> r' \<Longrightarrow> r \<cdot> u \<and>\<^sub>p r' \<cdot> v = r \<and>\<^sub>p r'"
-    by (induct r r' rule: list_induct2', simp+)
-  thus ?thesis
-    using that(1) that(2) by linarith
-qed
-
-lemma lcp_same_len: "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \<Longrightarrow> u \<noteq> v \<Longrightarrow> u \<and>\<^sub>p v = u \<cdot> w \<and>\<^sub>p v \<cdot> w'"
-  using lcp_ext_right[of u v _ w w'] pref_comp_eq[of u v] by argo
+  using lcp_ext_right_conv by blast
+
+lemma lcp_same_len: "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \<Longrightarrow> u \<noteq> v \<Longrightarrow> u \<cdot> w \<and>\<^sub>p v \<cdot> w' = u \<and>\<^sub>p v"
+  using pref_comp_eq by (cases rule: lcp_ext_right) (elim notE)
 
 lemma lcp_mismatch: "\<^bold>|u \<and>\<^sub>p v\<^bold>| < \<^bold>|u\<^bold>| \<Longrightarrow> \<^bold>|u \<and>\<^sub>p v\<^bold>| < \<^bold>|v\<^bold>| \<Longrightarrow> u! \<^bold>|u \<and>\<^sub>p v\<^bold>| \<noteq> v! \<^bold>|u \<and>\<^sub>p v\<^bold>|"
   by (induct u v rule: list_induct2') auto
 
-lemma lcp_mismatch': assumes "\<not> u \<bowtie> v" shows "u! \<^bold>|u \<and>\<^sub>p v\<^bold>| \<noteq> v! \<^bold>|u \<and>\<^sub>p v\<^bold>|"
-  using incomp_lcp_len[OF assms, unfolded min_less_iff_conj] lcp_mismatch
-  by blast
+lemma lcp_mismatch': "\<not> u \<bowtie> v \<Longrightarrow> u! \<^bold>|u \<and>\<^sub>p v\<^bold>| \<noteq> v! \<^bold>|u \<and>\<^sub>p v\<^bold>|"
+  using incomp_lcp_len lcp_mismatch unfolding min_less_iff_conj.. 
+
+lemma lcp_mismatchE: assumes "\<not> us \<bowtie> vs"
+  obtains us' vs'
+  where "(us \<and>\<^sub>p vs) \<cdot> us' = us" and "(us \<and>\<^sub>p vs) \<cdot> vs' = vs" and
+    "us' \<noteq> \<epsilon>" and "vs' \<noteq> \<epsilon>" and "hd us' \<noteq> hd vs'"
+proof -
+  obtain us' vs' where us: "(us \<and>\<^sub>p vs) \<cdot> us' = us" and vs: "(us \<and>\<^sub>p vs) \<cdot> vs' = vs"
+    using prefixE[OF lcp_pref prefixE[OF lcp_pref']]
+    unfolding eq_commute[of "x\<cdot>y" for x y].
+  with \<open>\<not> us \<bowtie> vs\<close> have "us' \<noteq> \<epsilon>" and "vs' \<noteq> \<epsilon>"
+    unfolding prefix_comparable_def lcp_pref_conv[symmetric] lcp_sym[of vs]
+    by fastforce+
+  hence "us! \<^bold>|us \<and>\<^sub>p vs\<^bold>| = hd us'" and "vs! \<^bold>|us \<and>\<^sub>p vs\<^bold>| = hd vs'"
+    using hd_lq_conv_nth[OF triv_spref, symmetric] unfolding lq_triv
+    unfolding arg_cong[OF us[symmetric], of nth] arg_cong[OF vs[symmetric], of nth]
+    by blast+
+  from lcp_mismatch'[OF \<open>\<not> us \<bowtie> vs\<close>, unfolded this]
+  have "hd us' \<noteq> hd vs'".
+  from that[OF us vs \<open>us' \<noteq> \<epsilon>\<close> \<open>vs' \<noteq> \<epsilon>\<close> this]
+  show thesis.
+qed
+
+lemma lcp_mismatch_lq: assumes "\<not> u \<bowtie> v"
+  shows
+  "(u \<and>\<^sub>p v)\<inverse>\<^sup>>u \<noteq> \<epsilon>" and 
+  "(u \<and>\<^sub>p v)\<inverse>\<^sup>>v \<noteq> \<epsilon>" and 
+  "hd ((u \<and>\<^sub>p v)\<inverse>\<^sup>>u) \<noteq> hd ((u \<and>\<^sub>p v)\<inverse>\<^sup>>v)"
+proof-
+  from lcp_mismatchE[OF assms]
+  obtain su sv where "(u \<and>\<^sub>p v) \<cdot> su = u" and
+      "(u \<and>\<^sub>p v) \<cdot> sv = v" and "su \<noteq> \<epsilon>" and "sv \<noteq> \<epsilon>" and "hd su \<noteq> hd sv".
+  thus "(u \<and>\<^sub>p v)\<inverse>\<^sup>>u \<noteq> \<epsilon>" and "(u \<and>\<^sub>p v)\<inverse>\<^sup>>v \<noteq> \<epsilon>" and "hd ((u \<and>\<^sub>p v)\<inverse>\<^sup>>u) \<noteq> hd ((u \<and>\<^sub>p v)\<inverse>\<^sup>>v)"
+    using lqI[OF \<open>(u \<and>\<^sub>p v) \<cdot> su = u\<close>] lqI[OF \<open>(u \<and>\<^sub>p v) \<cdot> sv = v\<close>] by blast+
+qed
 
 lemma lcp_ext_left: "(z \<cdot> u) \<and>\<^sub>p (z \<cdot> v) = z \<cdot> (u \<and>\<^sub>p v)"
   by (induct z) auto
 
 lemma lcp_first_letters: "u!0 \<noteq> v!0 \<Longrightarrow> u \<and>\<^sub>p v = \<epsilon>"
   by (induct u v rule: list_induct2') auto
 
 lemma lcp_first_mismatch: "a \<noteq> b \<Longrightarrow> w \<cdot> [a] \<cdot> u \<and>\<^sub>p w \<cdot> [b] \<cdot> v  = w"
   by (simp add: lcp_ext_left)
 
 lemma lcp_first_mismatch': "a \<noteq> b \<Longrightarrow> u \<cdot> [a] \<and>\<^sub>p u \<cdot> [b] = u"
   using lcp_first_mismatch[of a b u \<epsilon> \<epsilon>] by simp
 
-lemma lcp_mismatch_shorter: assumes "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|" "x \<noteq> y" shows "u \<cdot> [x] \<and>\<^sub>p v \<cdot> [y] = u \<and>\<^sub>p v"
-  by (cases "u = v")
-    (simp add: lcp_self[of v]  lcp_first_mismatch'[OF \<open>x \<noteq> y\<close>, of v],
-    use lcp_same_len[OF \<open>\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|\<close>, of "[x]" "[y]"] in auto)
-
-lemma lcp_rulers: "r \<le>p s \<Longrightarrow> r' \<le>p s' \<Longrightarrow> (r \<bowtie> r' \<or> r \<and>\<^sub>p r' = s \<and>\<^sub>p s')"
-  using lcp_ext_right prefD[of r s] prefD[of r' s'] by metis
-
-lemma pref_pref_lcp': "w \<le>p r \<Longrightarrow> w' \<le>p s \<Longrightarrow> w \<and>\<^sub>p w' \<le>p (r \<and>\<^sub>p s)"
-  using pref_pref_lcp lcp_pref lcp_sym pref_trans by metis
+lemma lcp_mismatch_eq_len: assumes "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|" "x \<noteq> y" shows "u \<cdot> [x] \<and>\<^sub>p v \<cdot> [y] = u \<and>\<^sub>p v"
+  using lcp_self lcp_first_mismatch'[OF \<open>x \<noteq> y\<close>] lcp_same_len[OF \<open>\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|\<close>]
+  by (cases "u = v") auto
+
+lemma lcp_first_mismatch_pref: assumes "p \<cdot> [a] \<le>p u" and "p \<cdot> [b] \<le>p v" and "a \<noteq> b"
+  shows "u \<and>\<^sub>p v = p"
+  using assms(1-2) lcp_first_mismatch[OF \<open>a \<noteq> b\<close>]
+  unfolding  prefix_def rassoc by blast
+
+lemma lcp_rulersE: assumes "r \<le>p s" and "r' \<le>p s'" obtains "r \<bowtie> r'" | "s \<and>\<^sub>p s' = r \<and>\<^sub>p r'"
+  by (cases rule: lcp_ext_right[of _ _ _ "r\<inverse>\<^sup>>s" "r'\<inverse>\<^sup>>s'"]) (assumption, simp only: assms lq_pref)
+
+lemma lcp_rulers: "r \<le>p s \<Longrightarrow> r' \<le>p s' \<Longrightarrow> (r \<bowtie> r' \<or>  s \<and>\<^sub>p s' = r \<and>\<^sub>p r')"
+  by (cases rule: lcp_ext_right[of _ _ _ "r\<inverse>\<^sup>>s" "r'\<inverse>\<^sup>>s'"], blast) (meson lcp_rulersE)
+
+lemma lcp_rulers': "w \<le>p r \<Longrightarrow> w' \<le>p s \<Longrightarrow> \<not> w \<bowtie> w' \<Longrightarrow> (r \<and>\<^sub>p s) = w \<and>\<^sub>p w'"
+  using lcp_rulers by blast
+
+lemma lcp_pref_monotone: assumes "w \<le>p r" and "w' \<le>p s" shows "w \<and>\<^sub>p w' \<le>p (r \<and>\<^sub>p s)"
+  by (intro pref_pref_lcp, 
+      intro pref_trans[OF _ \<open>w \<le>p r\<close>], 
+      intro lcp_pref, 
+      intro pref_trans[OF  _ \<open>w' \<le>p s\<close>], 
+      intro lcp_pref') 
+
+lemma lcp_append_monotone: "u \<and>\<^sub>p x \<le>p (u \<cdot> v) \<and>\<^sub>p (x \<cdot> y)"
+  by (simp add: lcp_pref_monotone)
 
 lemma lcp_distinct_hd: "hd u \<noteq> hd v \<Longrightarrow> u \<and>\<^sub>p v = \<epsilon>"
-proof-
-  assume "hd u \<noteq> hd v"
-  hence "(u \<noteq> \<epsilon> \<and> v \<noteq> \<epsilon>) \<Longrightarrow> hd u \<noteq> hd v \<Longrightarrow>  u \<and>\<^sub>p v = \<epsilon>"
-    by (simp add: lcp_first_letters hd_conv_nth)
-  moreover have "u = \<epsilon> \<or> v = \<epsilon> \<Longrightarrow>  u \<and>\<^sub>p v = \<epsilon>"
-    using lcp_pref' by auto
-  ultimately show ?thesis using \<open>hd u \<noteq> hd v\<close> by blast
+  using pref_hd_eq'[OF lcp_pref lcp_pref'] by blast
+
+lemma nemp_lcp_distinct_hd: assumes "u \<noteq> \<epsilon>" and "v \<noteq> \<epsilon>" and "u \<and>\<^sub>p v = \<epsilon>"
+  shows "hd u \<noteq> hd v"
+proof
+  assume "hd u = hd v"
+  from lcp_ext_left[of "[hd u]" "tl u" "tl v", 
+       unfolded hd_tl[OF \<open>u \<noteq> \<epsilon>\<close>] hd_tl[OF \<open>v \<noteq> \<epsilon>\<close>, folded this]]
+  show False 
+    using \<open>u \<and>\<^sub>p v = \<epsilon>\<close> by simp
 qed
 
 lemma lcp_lenI: assumes "i < min \<^bold>|u\<^bold>| \<^bold>|v\<^bold>|" and "take i u = take i v" and "u!i \<noteq> v!i"
   shows "i = \<^bold>|u \<and>\<^sub>p v\<^bold>|"
 proof-
-  have u: "take i u \<cdot> [u ! i] \<cdot> (drop (Suc i) u) = u"
+  have u: "take i u \<cdot> [u ! i] \<cdot> drop (Suc i) u = u"
     using \<open>i < min \<^bold>|u\<^bold>| \<^bold>|v\<^bold>|\<close> id_take_nth_drop[of i u] by simp
-  have v: "take i u \<cdot> [v ! i] \<cdot> drop (Suc i) v = v" using \<open>i < min \<^bold>|u\<^bold>| \<^bold>|v\<^bold>|\<close>
-    unfolding \<open>take i u = take i v\<close> using id_take_nth_drop by fastforce
+  have v: "take i u \<cdot> [v ! i] \<cdot> drop (Suc i) v = v"
+    using \<open>i < min \<^bold>|u\<^bold>| \<^bold>|v\<^bold>|\<close>
+    unfolding \<open>take i u = take i v\<close> using id_take_nth_drop[of i v] by force
   from lcp_first_mismatch[OF \<open>u!i \<noteq> v!i\<close>, of "take i u" "drop (Suc i) u" "drop (Suc i) v", unfolded u v]
   have "u \<and>\<^sub>p v = take i u".
   thus ?thesis
     using \<open>i < min \<^bold>|u\<^bold>| \<^bold>|v\<^bold>|\<close> by auto
 qed
 
 lemma lcp_prefs: "\<^bold>|u \<cdot> w \<and>\<^sub>p v \<cdot> w'\<^bold>| < \<^bold>|u\<^bold>| \<Longrightarrow> \<^bold>|u \<cdot> w \<and>\<^sub>p v \<cdot> w'\<^bold>| < \<^bold>|v\<^bold>| \<Longrightarrow> u \<and>\<^sub>p v = u \<cdot> w \<and>\<^sub>p v \<cdot> w'"
   by (induct u v rule: list_induct2') auto
 
 subsection "Longest common prefix and prefix comparability"
 
 lemma lexord_cancel_right: "(u \<cdot> z, v \<cdot> w) \<in> lexord r \<Longrightarrow> \<not> u \<bowtie> v \<Longrightarrow> (u,v) \<in> lexord r"
   by (induction rule: list_induct2', simp+, auto)
 
-lemma lcp_ruler: "r \<bowtie> w1 \<Longrightarrow> r \<bowtie> w2 \<Longrightarrow> \<not> w1 \<bowtie> w2 \<Longrightarrow> r \<le>p w1 \<and>\<^sub>p w2"
-  unfolding prefix_comparable_def
-  by (meson pref_pref_lcp pref_trans ruler)
+lemma lcp_ruler: "r \<bowtie> w1 \<Longrightarrow> r \<bowtie> w2 \<Longrightarrow> \<not> w1 \<bowtie> w2 \<Longrightarrow> r \<le>p w1 \<and>\<^sub>p w2" 
+  unfolding prefix_comparable_def by (meson pref_pref_lcp pref_trans ruler)
 
 lemma comp_monotone: "w \<bowtie> r  \<Longrightarrow> u \<le>p w \<Longrightarrow> u \<bowtie> r"
-  using pref_trans[of u w r] ruler[of u w r] by blast
+  using pref_compI1[OF pref_trans] ruler' by (elim pref_compE) 
 
 lemma comp_monotone': "w \<bowtie> r  \<Longrightarrow> w \<and>\<^sub>p w' \<bowtie> r"
-  using comp_monotone[of w r "w \<and>\<^sub>p w'", OF _ longest_common_prefix_prefix1].
-
-lemma double_ruler: assumes "w \<bowtie> r" and "w' \<bowtie> r'" and "\<not> r \<bowtie> r'"
-  shows "w \<and>\<^sub>p w' \<le>p r \<and>\<^sub>p r'"
-  using comp_monotone'[OF \<open>w' \<bowtie> r'\<close>, of w]  unfolding lcp_sym[of w' w]
-  using lcp_ruler[OF comp_monotone'[OF \<open>w \<bowtie> r\<close>, of w'] _ \<open>\<not> r \<bowtie> r'\<close>] by blast
+  using comp_monotone[OF _ lcp_pref].
+
+lemma double_ruler: assumes "w \<bowtie> r" and "w' \<bowtie> r'"
+  shows "\<not> r \<bowtie> r' \<Longrightarrow> w \<and>\<^sub>p w' \<le>p r \<and>\<^sub>p r'"
+  using comp_monotone'[OF \<open>w' \<bowtie> r'\<close>] unfolding lcp_sym[of w']
+  by (rule lcp_ruler[OF comp_monotone'[OF \<open>w \<bowtie> r\<close>]])
+
+lemma pref_lcp_iff: "w \<le>p u \<and>\<^sub>p v \<longleftrightarrow> w \<le>p u \<and> w \<le>p v"
+  by (intro iffI conjI longest_common_prefix_max_prefix)
+    (blast dest: pref_lcp_pref pref_lcp_pref')+
 
 lemma pref_comp_ruler: assumes "w \<bowtie> u \<cdot> [x]" and "w \<bowtie> v \<cdot> [y]" and "x \<noteq> y" and "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|"
   shows "w \<le>p u \<and> w \<le>p v"
-  using double_ruler[OF \<open>w \<bowtie> u \<cdot> [x]\<close> \<open>w \<bowtie> v \<cdot> [y]\<close> mismatch_incopm[OF \<open>\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|\<close> \<open>x \<noteq> y\<close>]] unfolding lcp_self[of w] lcp_mismatch_shorter[OF \<open>\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|\<close> \<open>x \<noteq> y\<close>]
-  using pref_lcp_pref pref_lcp_pref' by blast
-
-lemmas suf_comp_ruler = pref_comp_ruler[reversed]
+  using double_ruler[OF \<open>w \<bowtie> u \<cdot> [x]\<close> \<open>w \<bowtie> v \<cdot> [y]\<close> mismatch_incopm[OF \<open>\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|\<close> \<open>x \<noteq> y\<close>]]
+  unfolding lcp_self lcp_mismatch_eq_len[OF \<open>\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|\<close> \<open>x \<noteq> y\<close>] pref_lcp_iff.
+
+subsection \<open>Longest common suffix\<close>
+
+definition longest_common_suffix ("_ \<and>\<^sub>s _ " [61,62] 64)
+  where 
+    "longest_common_suffix u v \<equiv> rev (rev u \<and>\<^sub>p rev v)" 
+
+lemma lcs_lcp [reversal_rule]: "rev u \<and>\<^sub>p rev v = rev (u \<and>\<^sub>s v)"
+  unfolding longest_common_suffix_def rev_rev_ident..
+
+lemmas lcs_simp = lcp_simps[reversed] and
+       lcs_sym = lcp_sym[reversed] and
+       lcs_suf = lcp_pref[reversed] and
+       lcs_suf' = lcp_pref'[reversed] and
+       suf_suf_lcs = pref_pref_lcp[reversed] and
+       suf_non_suf_lcs_suf = pref_non_pref_lcp_pref[reversed] and
+       lcs_drop_eq = lcp_take_eq[reversed] and
+       lcs_take = lcp_take[reversed] and
+       lcs_take' = lcp_take'[reversed] and
+       lcs_suf_conv = lcp_pref_conv[reversed] and
+       lcs_suf_conv' = lcp_pref_conv'[reversed] and 
+       lcs_per_root = lcp_per_root[reversed] and
+       lcs_per_root' = lcp_per_root'[reversed] and
+       suf_lcs_suf = pref_lcp_pref[reversed] and 
+       suf_lcs_suf' = pref_lcp_pref'[reversed] and
+       lcs_self[simp] = lcp_self[reversed] and
+       lcs_eq_len = lcp_eq_len[reversed] and
+       lcs_len = lcp_len[reversed] and
+       lcs_len' = lcp_len'[reversed] and
+       suf_incomp_lcs_len = incomp_lcp_len[reversed] and  
+       lcs_ext_left_conv = lcp_ext_right_conv[reversed] and
+       lcs_ext_left [case_names comp non_comp] = lcp_ext_right[reversed] and
+       lcs_same_len = lcp_same_len[reversed] and 
+       lcs_mismatch = lcp_mismatch[reversed] and
+       lcs_mismatch' = lcp_mismatch'[reversed] and
+       lcs_mismatchE = lcp_mismatchE[reversed] and
+       lcs_mismatch_rq = lcp_mismatch_lq[reversed] and
+       lcs_ext_right = lcp_ext_left[reversed] and
+       lcs_first_mismatch = lcp_first_mismatch[reversed, unfolded rassoc] and
+       lcs_first_mismatch' = lcp_first_mismatch'[reversed, unfolded rassoc] and
+       lcs_mismatch_eq_len = lcp_mismatch_eq_len[reversed] and
+       lcs_first_mismatch_suf = lcp_first_mismatch_pref[reversed] and
+       lcs_rulers = lcp_rulers[reversed] and
+       lcs_rulers' = lcp_rulers'[reversed] and
+       suf_suf_lcs' = lcp_pref_monotone[reversed] and
+       lcs_distinct_last = lcp_distinct_hd[reversed] and
+       lcs_lenI = lcp_lenI[reversed] and
+       lcs_sufs = lcp_prefs[reversed]
+
+lemmas lcs_ruler = lcp_ruler[reversed] and
+       suf_comp_monotone = comp_monotone[reversed] and
+       suf_comp_monotone' = comp_monotone'[reversed] and
+       double_ruler_suf = double_ruler[reversed] and
+       suf_lcs_iff = pref_lcp_iff[reversed] and
+       suf_comp_ruler = pref_comp_ruler[reversed]
 
 section "Mismatch"
 
 text \<open>The first pair of letters on which two words/lists disagree\<close>
 
-fun mismatch_pair :: "'a list \<Rightarrow> 'a list \<Rightarrow> ('a \<times> 'a)" where
+function mismatch_pair :: "'a list \<Rightarrow> 'a list \<Rightarrow> ('a \<times> 'a)" where
   "mismatch_pair \<epsilon> v = (\<epsilon>!0, v!0)" |
   "mismatch_pair v \<epsilon> = (v!0, \<epsilon>!0)" |
   "mismatch_pair (a#u) (b#v) = (if a=b then mismatch_pair u v else (a,b))"
+  using shuffles.cases by blast+ 
+termination
+  by (relation "measure (\<lambda> (t,s). length t)", simp_all)
 
 text \<open>Alternatively, mismatch pair may be defined using the longest common prefix as follows.\<close>
 
 lemma mismatch_pair_lcp: "mismatch_pair u v = (u!\<^bold>|u\<and>\<^sub>pv\<^bold>|,v!\<^bold>|u\<and>\<^sub>pv\<^bold>|)"
 proof(induction u v rule: mismatch_pair.induct, simp+)
 qed
 
 text \<open>For incomparable words the pair is out of diagonal.\<close>
 
 lemma incomp_neq: "\<not> u \<bowtie> v \<Longrightarrow> (mismatch_pair u v) \<notin> Id"
   unfolding mismatch_pair_lcp by (simp add: lcp_mismatch')
 
 lemma mismatch_ext_left: "\<not> u \<bowtie> v \<Longrightarrow> mismatch_pair u v = mismatch_pair (p\<cdot>u) (p\<cdot>v)"
   unfolding mismatch_pair_lcp by (simp add: lcp_ext_left)
 
 lemma mismatch_ext_right: assumes  "\<not> u \<bowtie> v"
   shows "mismatch_pair u v = mismatch_pair (u\<cdot>z) (v\<cdot>w)"
 proof-
   have less1: "\<^bold>|u \<and>\<^sub>p v\<^bold>| < \<^bold>|u\<^bold>|" and less2: "\<^bold>|v \<and>\<^sub>p u\<^bold>| < \<^bold>|v\<^bold>|"
     using lcp_len'[of u v] lcp_len'[of v u] assms  by auto
   show ?thesis
     unfolding mismatch_pair_lcp unfolding pref_index[OF triv_pref less1, of z]  pref_index[OF triv_pref less2, of w, unfolded lcp_sym[of v]]
     using assms lcp_ext_right[of u v _ z w] by metis
 qed
 
 lemma mismatchI: "\<not> u \<bowtie> v \<Longrightarrow> i < min \<^bold>|u\<^bold>| \<^bold>|v\<^bold>| \<Longrightarrow> take i u = take i v \<Longrightarrow> u!i \<noteq> v!i
    \<Longrightarrow> mismatch_pair u v = (u!i,v!i)"
   unfolding mismatch_pair_lcp using lcp_lenI by blast
 
 text \<open>For incomparable words, the mismatch letters work in a similar way as the lexicographic order\<close>
 
 lemma mismatch_lexord: assumes "\<not> u \<bowtie> v" and "mismatch_pair u v \<in> r"
   shows "(u,v) \<in> lexord r"
   unfolding lexord_take_index_conv mismatch_pair_lcp
   using  \<open>mismatch_pair u v \<in> r\<close>[unfolded mismatch_pair_lcp]
     incomp_lcp_len[OF assms(1)] lcp_take_eq by blast
 
 text \<open>However, the equivalence requires r to be irreflexive.
 (Due to the definition of lexord which is designed for irreflexive relations.)\<close>
 
 lemma lexord_mismatch: assumes "\<not> u \<bowtie> v" and "irrefl r"
   shows "mismatch_pair u v \<in> r \<longleftrightarrow> (u,v) \<in> lexord r"
 proof
   assume "(u,v) \<in> lexord r"
   obtain i where  "i < min \<^bold>|u\<^bold>| \<^bold>|v\<^bold>|" and  "take i u = take i v" and "(u ! i, v ! i) \<in> r"
     using \<open>(u,v) \<in> lexord r\<close>[unfolded lexord_take_index_conv] \<open>\<not> u \<bowtie> v\<close> pref_take_conv by blast
   have "u!i \<noteq> v!i"
     using  \<open>irrefl r\<close>[unfolded irrefl_def] \<open>(u ! i, v ! i) \<in> r\<close> by fastforce
   from \<open>(u ! i, v ! i) \<in> r\<close>[folded mismatchI[OF \<open>\<not> u \<bowtie> v\<close> \<open>i < min \<^bold>|u\<^bold>| \<^bold>|v\<^bold>|\<close> \<open>take i u = take i v\<close> \<open>u!i \<noteq> v!i\<close>]]
   show  "mismatch_pair u v \<in> r".
 next
   from mismatch_lexord[OF \<open>\<not> u \<bowtie> v\<close>]
   show "mismatch_pair u v \<in> r \<Longrightarrow> (u, v) \<in> lexord r".
 qed
 
 section "Factor properties"
 
+lemmas [simp] = sublist_Cons_right
+
 lemma rev_fac[reversal_rule]: "rev u \<le>f rev v \<longleftrightarrow> u \<le>f v"
   using Sublist.sublist_rev.
 
 lemma fac_pref: "u \<le>f v \<equiv> \<exists> p. p \<cdot> u \<le>p v"
-  by simp
+  by (simp add: prefix_def fac_def)
 
 lemma fac_pref_suf: "u \<le>f v \<Longrightarrow> \<exists> p. p \<le>p v \<and> u \<le>s p"
   using sublist_altdef by blast
 
 lemma pref_suf_fac: "r \<le>p v \<Longrightarrow> u \<le>s r \<Longrightarrow> u \<le>f v"
   using sublist_altdef by blast
 
 lemmas
   fac_suf = fac_pref[reversed] and
   fac_suf_pref = fac_pref_suf[reversed] and
   suf_pref_fac = pref_suf_fac[reversed]
 
 lemma suf_pref_eq: "s \<le>s p \<Longrightarrow> p \<le>p s \<Longrightarrow> p = s"
-  using long_pref suffix_length_le by blast
-
-lemma fac_triv': assumes  "p\<cdot>x\<cdot>q = x" shows "q = \<epsilon>"
-  using prefI[of "p\<cdot>x" q "p\<cdot>x\<cdot>q"] sufI[of \<epsilon> "p\<cdot>x\<cdot>q" "x", THEN suf_ext[of "p\<cdot>x\<cdot>q" x p]]
-    suf_pref_eq[of x "p\<cdot>x"] self_append_conv[of "p\<cdot>x" q]
-  unfolding assms append_Nil rassoc
-  by blast
+  using sublist_order.order.eq_iff by blast
 
 lemma fac_triv: "p\<cdot>x\<cdot>q = x \<Longrightarrow> p = \<epsilon>"
-  using fac_triv' by force
+  using long_pref[OF prefI suf_len'] unfolding append_self_conv2 rassoc.
+
+lemma fac_triv': "p\<cdot>x\<cdot>q = x \<Longrightarrow> q = \<epsilon>"
+  using fac_triv[reversed] unfolding rassoc.
 
 lemmas
   suf_fac = suffix_imp_sublist and
   pref_fac = prefix_imp_sublist
 
-lemma fac_Cons_E: assumes "u \<le>f (a#v)"
+lemma fac_ConsE: assumes "u \<le>f (a#v)"
   obtains "u \<le>p (a#v)" | "u \<le>f v"
-  using assms[unfolded sublist_Cons_right]
-  by fast
+  using assms unfolding sublist_Cons_right
+  by blast
 
 lemmas
-  fac_snoc_E = fac_Cons_E[reversed]
+  fac_snocE = fac_ConsE[reversed]
+
+lemma fac_elim_suf: assumes "f \<le>f m\<cdot>s" "\<not> f \<le>f s"
+  shows "f \<le>f m\<cdot>(take (\<^bold>|f\<^bold>|-1) s)"
+  using assms
+proof(induction s rule:rev_induct)
+  case (snoc s ss)
+  have "\<not> f \<le>f ss"
+    using \<open>\<not> f \<le>f ss \<cdot> [s]\<close>[unfolded sublist_append] by blast
+
+  show ?case
+  proof(cases)
+    assume  "f \<le>f m \<cdot> ss"
+    hence "f \<le>f m \<cdot> take (\<^bold>|f\<^bold>| - 1) ss"
+      using \<open>\<not> f \<le>f ss\<close> snoc.IH by blast
+    then show ?thesis
+      unfolding take_append lassoc using append_assoc sublist_append by metis
+  next
+    assume "\<not> f \<le>f m \<cdot> ss"
+    hence "f \<le>s m \<cdot> ss \<cdot> [s]"
+      using  snoc.prems(1)[unfolded lassoc sublist_snoc, unfolded rassoc] by blast
+    from suf_prod_le[OF this, THEN suffix_imp_sublist] \<open>\<not> f \<le>f ss \<cdot> [s]\<close>
+    have "\<^bold>|ss \<cdot> [s]\<^bold>| < \<^bold>|f\<^bold>|"
+      by linarith 
+    from this Suc_less_iff_Suc_le length_append_singleton[of ss s]
+    show ?thesis
+      using snoc.prems(1) take_all_iff by metis
+  qed
+qed auto
+
+lemmas fac_elim_pref = fac_elim_suf[reversed]
+
+lemma fac_elim: assumes "f \<le>f p\<cdot>m\<cdot>s" and  "\<not> f \<le>f p" and "\<not> f \<le>f s"
+  shows "f \<le>f (drop (\<^bold>|p\<^bold>| - (\<^bold>|f\<^bold>| - 1)) p) \<cdot> m \<cdot> (take (\<^bold>|f\<^bold>|-1) s)"
+  using  fac_elim_suf[OF fac_elim_pref[OF \<open>f \<le>f p\<cdot>m\<cdot>s\<close>, unfolded lassoc], unfolded rassoc, OF assms(2-3)]. 
+
+lemma fac_ext_pref: "u \<le>f w \<Longrightarrow> u \<le>f p \<cdot> w"
+  by (meson sublist_append)  
+
+lemma fac_ext_suf: "u \<le>f w \<Longrightarrow> u \<le>f w \<cdot> s"
+  by (meson sublist_append)  
+
+lemma fac_ext: "u \<le>f w \<Longrightarrow> u \<le>f p \<cdot> w \<cdot> s"
+  by (meson fac_ext_pref fac_ext_suf)
+
+lemma fac_ext_hd:"u \<le>f w \<Longrightarrow> u \<le>f a#w"
+  by (metis sublist_Cons_right)  
+
+lemma card_switch_fac: assumes "2 \<le> card (set ws)" 
+  obtains c d where "c \<noteq> d" and  "[c,d] \<le>f ws"
+  using assms                                                                                           
+proof (induct ws, force)
+  case (Cons a ws)
+  then show ?case 
+  proof (cases)
+    assume "2 \<le> card (set ws)"
+    from Cons.hyps[OF _ this] Cons.prems(1) fac_ext_hd
+    show thesis by metis
+  next 
+    assume "\<not> 2 \<le> card (set ws)"
+    have "ws \<noteq> \<epsilon>" 
+      using \<open>2 \<le> card (set (a # ws))\<close>  by force
+    hence "a = hd ws \<Longrightarrow> set (a # ws) = set ws" 
+      using hd_Cons_tl[OF \<open>ws \<noteq> \<epsilon>\<close>] by force  
+    hence "a \<noteq> hd ws"
+      using \<open>2 \<le> card (set (a # ws))\<close> \<open>\<not> 2 \<le> card (set ws)\<close>  by force   
+    from Cons.prems(1)[OF this]
+    show thesis
+      using  Cons_eq_appendI[OF _ hd_tl[OF \<open>ws \<noteq> \<epsilon>\<close>, symmetric]] sublist_append_rightI by blast
+  qed
+qed
 
 section "Power and its properties"
 
 text\<open>Word powers are often investigated in Combinatorics on Words.
 We thus interpret words as @{term monoid_mult} and adopt a notation for the word power.
 \<close>
 
-
 declare power.power.simps [code]
 
-interpretation  monoid_mult "\<epsilon>" "append"
-   by standard simp+
+interpretation monoid_mult "\<epsilon>" "append"
+  by standard simp+
 
 notation power (infixr "\<^sup>@" 80)
+notation power2 ("(_)\<^sup>@\<^sup>2" 80)
 
 \<comment> \<open>inherited power properties\<close>
 
-lemma pow_zero [simp]:  "u\<^sup>@0 = \<epsilon>"
-  using power.power_0.
-
-lemma emp_pow: "\<epsilon>\<^sup>@n = \<epsilon>"
-  using power_one.
-
-lemma pow_Suc_list: "u\<^sup>@(Suc n) = u \<cdot> u\<^sup>@n"
-  using power.power_Suc.
-
-lemma pow_commutes_list: "u\<^sup>@n \<cdot> u = u \<cdot> u\<^sup>@n"
-  using power_commutes.
-
-lemma pow_add_list: "x\<^sup>@(a+b) = x\<^sup>@a\<cdot>x\<^sup>@b"
-  using power_add.
-
-lemma pow_Suc2_list: "u\<^sup>@Suc n = u\<^sup>@n \<cdot> u"
-  using power_Suc2.
-
-lemma pow_eq_if_list: "p\<^sup>@m = (if m = 0 then \<epsilon> else p \<cdot> p\<^sup>@(m-1))"
-  using power_eq_if.
-
-lemma pow_one_id: "u\<^sup>@1 = u"
-  using power_one_right.
-
-lemma pow2_list: "u\<^sup>@2 = u \<cdot> u"
-  using power2_eq_square.
-
-lemma comm_add_exp: "u \<cdot> v = v \<cdot> u \<Longrightarrow> u \<^sup>@ n \<cdot> v = v \<cdot> u \<^sup>@ n"
-  using power_commuting_commutes.
-
-lemma pow_mult_list: "u\<^sup>@(m*n) = (u\<^sup>@m)\<^sup>@n"
-  using power_mult.
-
-lemma pow_rev_emp_conv[reversal_rule]: "power.power (rev \<epsilon>) (\<cdot>) = (\<^sup>@)"
+lemmas pow_zero = power.power_0 and 
+  pow_one = power_Suc0_right and
+  pow_one' = power_one_right and
+  emp_pow = power_one and
+  pow_two[simp] = power2_eq_square and
+  pow_Suc = power_Suc and
+  pow_Suc2 = power_Suc2 and
+  pow_comm = power_commutes and
+  add_exps = power_add and
+  pow_eq_if_list = power_eq_if and 
+  pow_mult = power_mult and
+  comm_add_exp = power_commuting_commutes 
+
+lemmas clean_pows = pow_zero pow_one emp_pow clean_emp
+                    numeral_nat less_eq_Suc_le neq0_conv
+
+lemma pow_rev_emp_conv[reversal_rule]: "power.power (rev \<epsilon>) (\<cdot>) = (\<^sup>@)" 
+  by simp
+
+lemma pow_rev_map_rev_emp_conv [reversal_rule]: "power.power (rev (map rev  \<epsilon>)) (\<cdot>) = (\<^sup>@)"
   by simp
 
 \<comment> \<open>more power properties\<close>
 
+lemma sing_Cons_to_pow: "[a, a] = [a] \<^sup>@ Suc (Suc 0)" "a # [a] \<^sup>@ k = [a] \<^sup>@ Suc k"
+  by simp_all
+
 lemma zero_exp: "n = 0 \<Longrightarrow> r\<^sup>@n = \<epsilon>"
   by simp
 
-lemma nemp_pow[elim]: "t\<^sup>@m \<noteq> \<epsilon> \<Longrightarrow> m \<noteq> 0"
+lemma emp_pow_emp: "r = \<epsilon> \<Longrightarrow> r\<^sup>@n = \<epsilon>"
+  by simp
+
+lemma nemp_pow[simp]: "t\<^sup>@m \<noteq> \<epsilon> \<Longrightarrow> m \<noteq> 0"
   using zero_exp by blast
 
-lemma nemp_pow'[elim]: "t\<^sup>@m \<noteq> \<epsilon> \<Longrightarrow> t \<noteq> \<epsilon>"
+lemma nemp_pow_SucE: assumes "ws \<noteq> \<epsilon>" and "ws = t\<^sup>@k" obtains l where "ws = t\<^sup>@Suc l"
+  using nemp_pow[OF \<open>ws \<noteq> \<epsilon>\<close>[unfolded \<open>ws =t\<^sup>@k\<close>], THEN not0_implies_Suc] \<open>ws = t\<^sup>@k\<close> by fast 
+
+lemma nemp_exp_pos[intro]: "w \<noteq> \<epsilon> \<Longrightarrow> r\<^sup>@k = w \<Longrightarrow> k \<noteq> 0"
+  using nemp_pow by blast 
+
+lemma nemp_pow_nemp[intro]: "t\<^sup>@m \<noteq> \<epsilon> \<Longrightarrow> t \<noteq> \<epsilon>"
   using emp_pow by auto
 
-lemma sing_pow:"i < m \<Longrightarrow> ([a]\<^sup>@m) ! i = a"
+lemma sing_pow_nth:"i < m \<Longrightarrow> ([a]\<^sup>@m) ! i = a"
   by (induct i m rule: diff_induct) auto
 
 lemma pow_is_concat_replicate: "u\<^sup>@n = concat (replicate n u)"
   by (induct n) auto
 
 lemma pow_slide: "u \<cdot> (v \<cdot> u)\<^sup>@n  \<cdot> v = (u \<cdot> v)\<^sup>@(Suc n)"
   by (induct n) simp+
 
-lemma pop_pow_one:  "m \<noteq> 0 \<Longrightarrow> r\<^sup>@m = r \<cdot> r\<^sup>@(m-1)"
-  by (simp add: pow_eq_if_list)
+lemma pop_pow_one:  "m \<noteq> 0 \<Longrightarrow> r\<^sup>@m = r \<cdot> r\<^sup>@(m-1)" 
+  using Suc_minus[of m] pow_Suc[of r "m-1"] by presburger
 
 lemma hd_pow: assumes "n \<noteq> 0" shows "hd(u\<^sup>@n) = hd u"
   unfolding pop_pow_one[OF \<open>n \<noteq> 0\<close>] using  hd_append2 by (cases "u = \<epsilon>", simp)
 
-
 lemma pop_pow: "m \<le> k \<Longrightarrow>u\<^sup>@m \<cdot> u\<^sup>@(k-m) =  u\<^sup>@k"
-  using le_add_diff_inverse pow_add_list  by metis
+  using le_add_diff_inverse add_exps  by metis
 
 lemma pop_pow_cancel: "u\<^sup>@k \<cdot> v = u\<^sup>@m \<cdot> w \<Longrightarrow> m \<le> k \<Longrightarrow> u\<^sup>@(k-m) \<cdot> v = w"
   using  lassoc pop_pow[of m k u] same_append_eq[of "u\<^sup>@m" "u\<^sup>@(k-m)\<cdot>v" w, unfolded lassoc] by argo
 
-lemma pow_comm: "t\<^sup>@k \<cdot> t\<^sup>@m = t\<^sup>@m \<cdot> t\<^sup>@k"
-  unfolding pow_add_list[symmetric] add.commute[of k]..
+lemma pows_comm: "t\<^sup>@k \<cdot> t\<^sup>@m = t\<^sup>@m \<cdot> t\<^sup>@k"
+  unfolding add_exps[symmetric] add.commute[of k]..
 
 lemma comm_add_exps: assumes "r \<cdot> u = u \<cdot> r" shows "r\<^sup>@m \<cdot> u\<^sup>@k = u\<^sup>@k \<cdot> r\<^sup>@m"
   using comm_add_exp[OF comm_add_exp[OF assms, symmetric], symmetric].
 
 lemma rev_pow: "rev (x\<^sup>@m) = (rev x)\<^sup>@m"
-  by (induct m, simp, simp add: pow_commutes_list)
+  by (induct m, simp, simp add: pow_comm)
+
+lemma pows_comp: "x\<^sup>@i \<bowtie> x\<^sup>@j"
+  unfolding prefix_comparable_def using ruler_eqE[OF pows_comm, of x i j] by blast  
+
+lemmas pows_suf_comp = pows_comp[reversed, folded rev_pow suffix_comparable_def]
 
 lemmas [reversal_rule] = rev_pow[symmetric]
 
 lemmas pow_eq_if_list' = pow_eq_if_list[reversed] and
   pop_pow_one' = pop_pow_one[reversed] and
   pop_pow' = pop_pow[reversed] and
   pop_pow_cancel' = pop_pow_cancel[reversed]
 
 lemma pow_len:  "\<^bold>|u\<^sup>@k\<^bold>| = k * \<^bold>|u\<^bold>|"
   by (induct k) simp+
 
-lemma eq_pow_exp: assumes "u \<noteq> \<epsilon>" shows "u\<^sup>@k = u\<^sup>@m \<longleftrightarrow> k = m"
+lemma pow_set: "set (w\<^sup>@Suc k) = set w"
+  by (induction k, simp_all)
+
+lemma eq_pow_exp[simp]: assumes "u \<noteq> \<epsilon>" shows "u\<^sup>@k = u\<^sup>@m \<longleftrightarrow> k = m"
 proof
   assume "k = m" thus "u\<^sup>@k = u\<^sup>@m" by simp
 next
   assume "u\<^sup>@k = u\<^sup>@m"
   from lenarg[OF this, unfolded pow_len mult_cancel2]
   show "k = m"
-  using \<open>u \<noteq> \<epsilon>\<close>[folded length_0_conv] by blast
-qed
-
-
-lemma nemp_emp_power: assumes "u \<noteq> \<epsilon>" shows "u\<^sup>@m = \<epsilon> \<longleftrightarrow> m = 0"
-   using  eq_pow_exp[OF assms]  by fastforce
-
-lemma nonzero_pow_emp: assumes "m \<noteq> 0" shows "u\<^sup>@m = \<epsilon> \<longleftrightarrow>  u = \<epsilon>"
-  by (meson assms nemp_emp_power nemp_pow')
+    using \<open>u \<noteq> \<epsilon>\<close>[folded length_0_conv] by blast
+qed
+
+
+lemma nemp_emp_pow: assumes "u \<noteq> \<epsilon>" shows "u\<^sup>@m = \<epsilon> \<longleftrightarrow> m = 0"
+  using  eq_pow_exp[OF assms, of m 0, unfolded pow_zero].
+
+lemma nemp_Suc_pow_nemp: "u \<noteq> \<epsilon> \<Longrightarrow> u\<^sup>@Suc k \<noteq> \<epsilon>"
+  by simp
+
+lemma nonzero_pow_emp: "m \<noteq> 0 \<Longrightarrow> u\<^sup>@m = \<epsilon> \<longleftrightarrow>  u = \<epsilon>"
+  by (cases "u = \<epsilon>", simp)
+  (use nemp_emp_pow[of u m] in blast)
 
 lemma pow_eq_eq:
   assumes "u\<^sup>@k = v\<^sup>@k" and "k \<noteq> 0"
   shows "u = v"
 proof-
   have "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|"
     using lenarg[OF \<open>u\<^sup>@k = v\<^sup>@k\<close>, unfolded pow_len] \<open>k \<noteq> 0\<close> by simp
-  from eqd_equal[of u "u\<^sup>@(k-1)" v "v\<^sup>@(k-1)", OF _ this]
+  from eqd_eq[of u "u\<^sup>@(k-1)" v "v\<^sup>@(k-1)", OF _ this]
   show ?thesis
-      using \<open>u\<^sup>@k = v\<^sup>@k\<close> unfolding pop_pow_one[OF \<open>k \<noteq> 0\<close>] by blast
-qed
-
-lemma sing_pow_empty: "[a]\<^sup>@n = \<epsilon> \<longleftrightarrow> n = 0"
-  by (simp add: nemp_emp_power)
+    using \<open>u\<^sup>@k = v\<^sup>@k\<close> unfolding pop_pow_one[OF \<open>k \<noteq> 0\<close>] by blast
+qed
+
+lemma Suc_pow_eq_eq[elim]: "u\<^sup>@Suc k = v\<^sup>@Suc k \<Longrightarrow> u = v"
+  using pow_eq_eq by blast
+  
+lemma map_pow: "map f (r\<^sup>@k) = (map f r)\<^sup>@k"
+  by (induct k, simp_all) 
+
+lemmas [reversal_rule] = map_pow[symmetric]
+
+lemma concat_pow: "concat (r\<^sup>@k) = (concat r)\<^sup>@k"
+  by (induct k, simp_all)
+
+lemma concat_sing_pow[simp]: "concat ([a]\<^sup>@k) = a\<^sup>@k"
+  unfolding concat_pow concat_sing'..
+
+lemma sing_pow_empty: "[a]\<^sup>@n = \<epsilon> \<longleftrightarrow> n = 0" 
+  using nemp_emp_pow[OF list.simps(3), of _ \<epsilon>]. 
 
 lemma sing_pow_lists: "a \<in> A \<Longrightarrow> [a]\<^sup>@n \<in> lists A"
   by (induct n, auto)
 
-lemma long_power: "r \<noteq> \<epsilon> \<Longrightarrow> \<^bold>|x\<^bold>| \<le> \<^bold>|r\<^sup>@\<^bold>|x\<^bold>|\<^bold>|"
-  unfolding pow_len[of r "\<^bold>|x\<^bold>|"] using nemp_pos_len by auto
+lemma long_power: assumes "r \<noteq> \<epsilon>" shows "\<^bold>|x\<^bold>| \<le> \<^bold>|r\<^sup>@\<^bold>|x\<^bold>|\<^bold>|"
+  unfolding pow_len using  mult_le_mono2[OF nemp_le_len[OF assms], unfolded mult.right_neutral].
 
 lemma long_power': "r \<noteq> \<epsilon> \<Longrightarrow> \<^bold>|x\<^bold>| < \<^bold>|r\<^sup>@(Suc \<^bold>|x\<^bold>|)\<^bold>|"
-  unfolding pow_Suc_list length_append
-  by (simp add: long_power add_strict_increasing)
+  unfolding pow_Suc lenmorph by (simp add: long_power add_strict_increasing)
 
 lemma long_pow_exp: "r \<noteq> \<epsilon> \<Longrightarrow> m \<le> \<^bold>|r\<^sup>@m\<^bold>|"
-  unfolding pow_len[of r m] using nemp_pos_len[of r] by simp
+  unfolding pow_len[of r m] using nemp_le_len[of r] by simp
 
 lemma long_pow_ex: assumes "r \<noteq> \<epsilon>" obtains n where  "m \<le> \<^bold>|r\<^sup>@n\<^bold>|" and "n \<noteq> 0"
-proof-
-  obtain x :: "'a list" where "\<^bold>|x\<^bold>| = m"
-    using Ex_list_of_length by auto
-  show thesis
-    using that[of m, OF long_power[OF \<open>r \<noteq> \<epsilon>\<close>, of x, unfolded \<open>\<^bold>|x\<^bold>| = m\<close>]] that[of "Suc 1"] by auto
-qed
+  using assms long_pow_exp by auto
 
 lemma pref_pow_ext: "x \<le>p r\<^sup>@k \<Longrightarrow> x \<le>p r\<^sup>@Suc k"
-  using pref_trans[OF _ prefI[OF pow_Suc2_list[symmetric]]].
+  using pref_trans[OF _ prefI[OF pow_Suc2[symmetric]]].
 
 lemma pref_pow_ext': "u \<le>p r\<^sup>@k \<Longrightarrow> u \<le>p r \<cdot> r\<^sup>@k"
-  using pref_pow_ext[unfolded pow_Suc_list].
+  using pref_pow_ext[unfolded pow_Suc].
 
 lemma pref_pow_root_ext: "x \<le>p r\<^sup>@k \<Longrightarrow> r \<cdot> x \<le>p r\<^sup>@Suc k"
   by simp
 
 lemma pref_prod_root: "u \<le>p r\<^sup>@k \<Longrightarrow> u \<le>p r \<cdot> u"
   using pref_pow_ext'[THEN pref_prod_pref].
 
-lemma pref_exps_pow:  "k \<le> l \<Longrightarrow> r\<^sup>@k \<le>p r\<^sup>@l"
+lemma le_exps_pref:  "k \<le> l \<Longrightarrow> r\<^sup>@k \<le>p r\<^sup>@l"
   using leI pop_pow[of k l r] by blast
 
 lemma pref_exp_le: assumes "u \<noteq> \<epsilon>" "u\<^sup>@m \<le>p u\<^sup>@n" shows "m \<le> n"
   using mult_cancel_le[OF nemp_len[OF \<open>u \<noteq> \<epsilon>\<close>], of m n]
     prefix_length_le[OF \<open>u\<^sup>@m \<le>p u\<^sup>@n\<close>, unfolded pow_len[of u m] pow_len[of u n]]
   by blast
 
+lemma sing_exp_pref_iff: assumes "a \<noteq> b" 
+  shows "[a]\<^sup>@i \<le>p [a]\<^sup>@k\<cdot>[b] \<cdot> w \<longleftrightarrow> i \<le> k"
+proof
+  assume "i \<le> k"
+  thus "[a]\<^sup>@i \<le>p [a]\<^sup>@k\<cdot>[b] \<cdot> w"
+    using pref_ext[OF le_exps_pref[OF \<open>i \<le> k\<close>]] by blast
+next
+  have "\<not> [a]\<^sup>@i \<le>p [a]\<^sup>@k\<cdot>[b] \<cdot> w" if "\<not> i \<le> k"
+  proof (rule notI)
+  assume "[a]\<^sup>@i \<le>p [a]\<^sup>@k\<cdot>[b] \<cdot> w"
+  hence "k < i" and "i - k \<noteq> 0" using \<open>\<not> i \<le> k\<close> by force+
+  from pop_pow[OF less_imp_le, OF this(1)]
+  have "[a]\<^sup>@k \<cdot> [a]\<^sup>@(i - k) = [a]\<^sup>@i".
+  from \<open>[a]\<^sup>@i \<le>p [a]\<^sup>@k\<cdot>[b] \<cdot> w\<close>[folded this, unfolded pref_cancel_conv
+       pop_pow_one[OF \<open>i - k \<noteq> 0\<close>]]
+  show False 
+    using \<open>a \<noteq> b\<close> by simp
+ qed
+ thus "[a] \<^sup>@ i \<le>p [a] \<^sup>@ k \<cdot> [b] \<cdot> w \<Longrightarrow> i \<le> k"
+   by blast
+qed
+
 lemmas
-    suf_pow_ext = pref_pow_ext[reversed] and
-    suf_pow_ext'= pref_pow_ext'[reversed] and
-    suf_pow_root_ext = pref_pow_root_ext[reversed] and
-    suf_prod_root = pref_prod_root[reversed] and
-    suf_exps_pow = pref_exps_pow[reversed] and
-    suf_exp_le = pref_exp_le[reversed]
+  suf_pow_ext = pref_pow_ext[reversed] and
+  suf_pow_ext'= pref_pow_ext'[reversed] and
+  suf_pow_root_ext = pref_pow_root_ext[reversed] and
+  suf_prod_root = pref_prod_root[reversed] and
+  suf_exps_pow = le_exps_pref[reversed] and
+  suf_exp_le = pref_exp_le[reversed] and
+  sing_exp_suf_iff = sing_exp_pref_iff[reversed]       
 
 lemma comm_common_power: assumes "r \<cdot> u = u \<cdot> r" shows "r\<^sup>@\<^bold>|u\<^bold>| = u\<^sup>@\<^bold>|r\<^bold>|"
-  using eqd_equal[OF comm_add_exps[OF \<open>r \<cdot> u = u \<cdot> r\<close>], of "\<^bold>|u\<^bold>|" "\<^bold>|r\<^bold>|"]
+  using eqd_eq[OF comm_add_exps[OF \<open>r \<cdot> u = u \<cdot> r\<close>], of "\<^bold>|u\<^bold>|" "\<^bold>|r\<^bold>|"]
   unfolding pow_len by fastforce
 
 lemma one_generated_list_power: "u \<in> lists {x} \<Longrightarrow> \<exists>k. concat u = x\<^sup>@k"
-proof(induction u)
-  case Nil
-  then show ?case
-    by (simp add: pow_is_concat_replicate)
-next
-  case (Cons a u)
-  then show ?case
-    unfolding Cons_in_lists_iff concat.simps(2)
-    using singletonD[of a x] pow_Suc_list[of a] by metis
-qed
-
-lemma pow_lists: "0 < k \<Longrightarrow> u\<^sup>@k \<in> lists B \<Longrightarrow> u \<in> lists B"
-  by (simp add: pow_eq_if_list)
+  by(induction u rule: lists.induct, unfold concat.simps(1), use pow_zero[of x, symmetric] in fast,
+        unfold concat.simps(2))
+  (use pow_Suc[symmetric, of x] singletonD in metis) 
+
+lemma pow_lists: assumes "0 < k" shows "u\<^sup>@k \<in> lists B \<Longrightarrow> u \<in> lists B"
+  unfolding pow_Suc[of u "k-1", unfolded Suc_minus''[OF \<open>0 < k\<close>]] by simp 
 
 lemma concat_morph_power: "xs \<in> lists B \<Longrightarrow> xs = ts\<^sup>@k \<Longrightarrow> concat ts\<^sup>@k = concat xs"
-  by (induct k arbitrary: xs ts) simp+
-
-lemma pref_not_idem:  "z \<noteq> \<epsilon> \<Longrightarrow> z \<noteq> x \<Longrightarrow> z \<cdot> x\<^sup>@k \<noteq> x"
-  using fac_triv by (cases k, simp, auto)
+  by (induct k arbitrary: xs ts) simp_all
+
+(* lemma pref_not_idem:  "z \<noteq> \<epsilon> \<Longrightarrow> z \<noteq> x \<Longrightarrow> z \<cdot> x\<^sup>@k \<noteq> x" *)
+  (* using mult_1_right fac_triv pow_eq_if_list[of x k] by metis *)
+  (* using fac_triv by (cases k, simp, auto) *)
 
 lemma per_exp_pref: "u \<le>p r \<cdot> u \<Longrightarrow> u \<le>p r\<^sup>@k \<cdot> u"
 proof(induct k, simp)
   case (Suc k) show ?case
-    unfolding pow_Suc_list rassoc
+    unfolding pow_Suc rassoc
     using Suc.hyps Suc.prems pref_prolong by blast
 qed
 
 lemmas
-  suf_not_idem =  pref_not_idem[reversed] and
+  (* suf_not_idem =  pref_not_idem[reversed] and *)
   per_exp_suf = per_exp_pref[reversed]
 
-lemma hd_sing_power: "k \<noteq> 0 \<Longrightarrow> hd ([a]\<^sup>@k) = a"
+lemma hd_sing_pow: "k \<noteq> 0 \<Longrightarrow> hd ([a]\<^sup>@k) = a"
   by (induction k) simp+
 
-lemma root_pref_cancel: assumes "t\<^sup>@m \<cdot> y = t\<^sup>@k" shows "y = t\<^sup>@(k - m)"
+(* lemma sing_mismatch_pref: "x \<noteq> y \<Longrightarrow> [y]\<^sup>@k \<cdot> [x] \<le>p w \<Longrightarrow> [y]\<^sup>@l \<cdot> [x] \<le>p w \<Longrightarrow> k = l" *)
+(* proof(rule ccontr, induction k l arbitrary: w rule: diff_induct) *)
+  (* case (1 k) *)
+  (* then show ?case *)
+    (* using not0_implies_Suc[OF \<open>k \<noteq> 0\<close>] by (auto simp add: prefix_def) *)
+(* qed (auto simp add: prefix_def) *)
+
+lemma sing_pref_comp_mismatch:
+  assumes "b \<noteq> a" and "c \<noteq> a" and "[a]\<^sup>@k \<cdot> [b] \<bowtie> [a]\<^sup>@l \<cdot> [c]"
+  shows "k = l \<and> b = c"
+proof
+  show "k = l"
+    using assms by (induction k l rule: diff_induct) 
+         (rule ccontr, elim predE, simp, simp, fastforce)
+  show "b = c" 
+    using assms(3) unfolding \<open>k = l\<close> by auto
+qed
+
+lemma sing_pref_comp_lcp: assumes "r \<noteq> s" and "a \<noteq> b" and "a \<noteq> c" 
+  shows  "[a]\<^sup>@r \<cdot> [b] \<cdot> u \<and>\<^sub>p [a]\<^sup>@s \<cdot> [c] \<cdot> v = [a]\<^sup>@(min r s)"
+proof-
+  have "r \<noteq> s \<longrightarrow>  [a]\<^sup>@r \<cdot> [b] \<cdot> u \<and>\<^sub>p [a]\<^sup>@s \<cdot> [c] \<cdot> v = [a]\<^sup>@(min r s)"
+  proof (rule diff_induct[of "\<lambda> r s. r \<noteq> s \<longrightarrow> [a]\<^sup>@r \<cdot> [b] \<cdot> u \<and>\<^sub>p [a]\<^sup>@s \<cdot> [c] \<cdot> v = [a]\<^sup>@(min r s)"])
+    have "[a] \<^sup>@ Suc (x - 1) \<cdot> [b] \<cdot> u \<and>\<^sub>p [c] \<cdot> v = [a] \<^sup>@ min x 0" if "x \<noteq> 0" for x
+      unfolding pow_Suc  min_0R clean_pows clean_emp rassoc by (simp add: \<open>a \<noteq> c\<close>)
+    thus "x \<noteq> 0 \<longrightarrow> [a] \<^sup>@ x \<cdot> [b] \<cdot> u \<and>\<^sub>p [a] \<^sup>@ 0 \<cdot> [c] \<cdot> v = [a] \<^sup>@ min x 0" for x  by force
+    show "0 \<noteq> Suc y \<longrightarrow> [a] \<^sup>@ 0 \<cdot> [b] \<cdot> u \<and>\<^sub>p [a] \<^sup>@ Suc y \<cdot> [c] \<cdot> v = [a] \<^sup>@ min 0 (Suc y)" for y 
+      unfolding pow_Suc  min_0L clean_pows clean_emp rassoc using \<open>a \<noteq> b\<close> by auto 
+    show "x \<noteq> y \<longrightarrow> [a] \<^sup>@ x \<cdot> [b] \<cdot> u \<and>\<^sub>p [a] \<^sup>@ y \<cdot> [c] \<cdot> v = [a] \<^sup>@ min x y \<Longrightarrow>
+           Suc x \<noteq> Suc y \<longrightarrow> [a] \<^sup>@ Suc x \<cdot> [b] \<cdot> u \<and>\<^sub>p [a] \<^sup>@ Suc y \<cdot> [c] \<cdot> v = [a] \<^sup>@ min (Suc x) (Suc y)" for x y
+      unfolding pow_Suc rassoc min_Suc_Suc by simp 
+  qed
+  with assms
+  show ?thesis by blast
+qed
+
+lemmas sing_suf_comp_mismatch = sing_pref_comp_mismatch[reversed]
+
+lemma exp_pref_cancel: assumes "t\<^sup>@m \<cdot> y = t\<^sup>@k" shows "y = t\<^sup>@(k - m)"
   using lqI[of "t\<^sup>@m" "t\<^sup>@(k-m)" "t\<^sup>@k"]  unfolding lqI[OF \<open>t\<^sup>@m \<cdot> y = t\<^sup>@k\<close>]
   using  nat_le_linear[of m k] pop_pow[of m k t] diff_is_0_eq[of k m]   append.right_neutral[of "t\<^sup>@k"] pow_zero[of t]
-    pref_antisym[of "t\<^sup>@m" "t\<^sup>@k", OF prefI[OF  \<open>t\<^sup>@m \<cdot> y = t\<^sup>@k\<close>] pref_exps_pow[of k m t]]
+    pref_antisym[of "t\<^sup>@m" "t\<^sup>@k", OF prefI[OF  \<open>t\<^sup>@m \<cdot> y = t\<^sup>@k\<close>] le_exps_pref[of k m t]]
   by presburger
 
-lemmas root_suf_cancel = root_pref_cancel[reversed]
+lemmas exp_suf_cancel = exp_pref_cancel[reversed]
 
 lemma index_pow_mod: "i < \<^bold>|r\<^sup>@k\<^bold>| \<Longrightarrow> (r\<^sup>@k)!i = r!(i mod \<^bold>|r\<^bold>|)"
 proof(induction k)
   have aux:  "\<^bold>|r\<^sup>@(Suc l)\<^bold>| = \<^bold>|r\<^sup>@l\<^bold>| + \<^bold>|r\<^bold>|" for l
     by simp
   have aux1: "\<^bold>|(r\<^sup>@l)\<^bold>| \<le> i \<Longrightarrow> i < \<^bold>|r\<^sup>@l\<^bold>| + \<^bold>|r\<^bold>| \<Longrightarrow>  i mod \<^bold>|r\<^bold>| = i -  \<^bold>|r\<^sup>@l\<^bold>|" for l
     unfolding pow_len[of r l] using less_diff_conv2[of "l * \<^bold>|r\<^bold>|" i "\<^bold>|r\<^bold>|", unfolded add.commute[of "\<^bold>|r\<^bold>|"  "l * \<^bold>|r\<^bold>|"]]
       get_mod[of "i - l * \<^bold>|r\<^bold>|" "\<^bold>|r\<^bold>|" l] le_add_diff_inverse[of "l*\<^bold>|r\<^bold>|" i] by argo
   case (Suc k)
   show ?case
-    unfolding aux sym[OF pow_Suc2_list[symmetric]] nth_append le_mod_geq
+    unfolding aux sym[OF pow_Suc2[symmetric]] nth_append le_mod_geq
     using aux1[ OF _ Suc.prems[unfolded aux]]
-      Suc.IH pow_Suc2_list[symmetric] Suc.prems[unfolded aux] leI[of i "\<^bold>|r \<^sup>@ k\<^bold>|"] by presburger
+      Suc.IH pow_Suc2[symmetric] Suc.prems[unfolded aux] leI[of i "\<^bold>|r \<^sup>@ k\<^bold>|"] by presburger
 qed auto
 
-lemma sing_pow_len: "\<^bold>|[r]\<^sup>@l\<^bold>| = l"
+lemma sing_pow_len [simp]: "\<^bold>|[r]\<^sup>@l\<^bold>| = l"
   by (induct l) auto
 
-lemma concat_take_sing: "k \<le> l \<Longrightarrow> concat (take k ([r]\<^sup>@l)) = r\<^sup>@k"
-proof(induct k, simp)
+lemma take_sing_pow: "k \<le> l \<Longrightarrow> take k ([r]\<^sup>@l) = [r]\<^sup>@k"
+proof (induct k)
   case (Suc k)
-  then show ?case
-    using concat_morph[of "take k ((r # \<epsilon>) \<^sup>@ l)""(r # \<epsilon>)", unfolded
-        sym[OF take_Suc_conv_app_nth[of k "[r]\<^sup>@l", unfolded sing_pow_len[of r l] less_eq_Suc_le
-            sing_pow[OF iffD2[OF less_eq_Suc_le Suc.prems], of r], OF \<open>Suc k \<le> l\<close>]]
-        concat_sing'[of r]
-        Suc.hyps[OF Suc_leD[OF Suc.prems]]
-        pow_Suc2_list[symmetric]]
-    by argo
-qed
-
-lemma concat_sing_pow: "concat ([a]\<^sup>@k) = a\<^sup>@k"
-proof(induct k)
-  show "concat ((a # \<epsilon>) \<^sup>@ 0) = a \<^sup>@ 0"
-    by simp
-next
-  fix k assume "concat ((a # \<epsilon>) \<^sup>@ k) = a \<^sup>@ k"
-  thus "concat ((a # \<epsilon>) \<^sup>@ Suc k) = a \<^sup>@ Suc k"
-    by simp
-qed
-
-lemma unique_letter_word: "(\<forall> c. c \<in> set w \<longrightarrow> c = a) \<Longrightarrow> \<exists> k. w = [a]\<^sup>@k"
-proof (induct w)
-  case Nil
-  then show ?case
-    by (metis pow_zero)
-next
+  have "k < \<^bold>|[r]\<^sup>@l\<^bold>|" using Suc_le_lessD[OF \<open>Suc k \<le> l\<close>] unfolding sing_pow_len.
+  from take_Suc_conv_app_nth[OF this]
+  show ?case
+    unfolding Suc.hyps[OF Suc_leD[OF \<open>Suc k \<le> l\<close>]] pow_Suc2
+    unfolding sing_pow_nth[OF Suc_le_lessD[OF \<open>Suc k \<le> l\<close>]].
+qed simp
+
+lemma concat_take_sing: assumes "k \<le> l" shows "concat (take k ([r]\<^sup>@l)) = r\<^sup>@k"
+  unfolding take_sing_pow[OF \<open>k \<le> l\<close>] using concat_sing_pow. 
+
+lemma unique_letter_word: assumes "\<And>c. c \<in> set w \<Longrightarrow> c = a" shows "w = [a]\<^sup>@\<^bold>|w\<^bold>|"
+  using assms proof (induction w)
   case (Cons b w)
-  then show ?case
-  proof-
-    obtain k where "w = [a]\<^sup>@k" using Cons.hyps Cons.prems by auto
-    hence "b#w = [a]\<^sup>@Suc k"
-      by (simp add: \<open>w = (a # \<epsilon>)\<^sup>@k\<close> Cons.prems)
-    thus ?thesis by blast
-  qed
-qed
-
-lemma unique_letter_wordE[elim]: assumes "(\<forall> c. c \<in> set w \<longrightarrow> c = a)" obtains k where "w = [a]\<^sup>@k"
+  have "[a] \<^sup>@ \<^bold>|w\<^bold>| = w" using Cons.IH[OF Cons.prems[OF list.set_intros(2)]]..
+  then show "b # w = [a] \<^sup>@ \<^bold>|b # w\<^bold>|"
+    unfolding Cons.prems[OF list.set_intros(1)] by auto
+qed simp
+
+lemma card_set_le_1_imp_hd_pow: assumes "card (set u) \<le> 1" shows "[hd u] \<^sup>@ \<^bold>|u\<^bold>| = u"
+proof (cases "u = \<epsilon>")
+  assume "u \<noteq> \<epsilon>"
+  then have "card (set u) = 1" using \<open>card (set u) \<le> 1\<close>
+    unfolding le_less less_one card_0_eq[OF finite_set] set_empty by blast
+  then have "set u = {hd u}" using hd_in_set[OF \<open>u \<noteq> \<epsilon>\<close>]
+  by (elim card_1_singletonE) simp
+  then show "[hd u]\<^sup>@\<^bold>|u\<^bold>| = u"
+    by (intro unique_letter_word[symmetric]) blast
+qed simp
+
+lemma unique_letter_wordE'[elim]: assumes "(\<forall> c. c \<in> set w \<longrightarrow> c = a)" obtains k where "w = [a]\<^sup>@k"
   using unique_letter_word assms by metis
 
-lemma unique_letter_wordE'[elim]: assumes "set w \<subseteq> {a}" obtains k where "w = [a] \<^sup>@ k"
+lemma unique_letter_wordE''[elim]: assumes "set w \<subseteq> {a}" obtains k where "w = [a] \<^sup>@ k"
   using assms unique_letter_word[of w a] by blast
 
+lemma unique_letter_wordE[elim]: assumes "set w = {a}" obtains k where "w = [a]\<^sup>@Suc k"
+proof-
+  have "w \<noteq> \<epsilon>" using assms by force
+  obtain l where "w = [a]\<^sup>@l"
+    using unique_letter_wordE''[of w a thesis] assms by force
+  with \<open>w \<noteq> \<epsilon>\<close> have "l \<noteq> 0" by simp
+  show thesis
+    using that[of "l-1"] unfolding \<open>w = [a]\<^sup>@l\<close> Suc_minus[OF \<open>l \<noteq> 0\<close>] by blast
+qed
+
 lemma conjug_pow: "x \<cdot> z = z \<cdot> y \<Longrightarrow> x\<^sup>@k \<cdot> z = z \<cdot> y\<^sup>@k"
   by (induct k) fastforce+
 
-lemma shift_pow: "(u\<cdot>v)\<^sup>@k\<cdot>u = u\<cdot>(v\<cdot>u)\<^sup>@k"
-  by (simp add: conjug_pow)
-
 lemma lq_conjug_pow: assumes "p \<le>p x \<cdot> p" shows "p\<inverse>\<^sup>>(x\<^sup>@k \<cdot> p) = (p\<inverse>\<^sup>>(x \<cdot> p))\<^sup>@k"
   using lqI[OF sym[OF conjug_pow[of x p  "p\<inverse>\<^sup>>(x \<cdot> p)", OF sym[OF lq_pref[OF \<open>p \<le>p x \<cdot> p\<close>]], of k]]].
 
 lemmas rq_conjug_pow = lq_conjug_pow[reversed]
 
-section "Total morphisms"
-
-locale  morphism =
-  fixes f :: "'a list \<Rightarrow> 'b list"
-  assumes morph: "f (u \<cdot> v) = f u \<cdot> f v"
-begin
-
-lemma emp_to_emp[simp]: "f \<epsilon> = \<epsilon>"
-  using morph[of \<epsilon> \<epsilon>] self_append_conv2[of "f \<epsilon>" "f \<epsilon>"] by simp
-
-lemma pow_morph: "f (x\<^sup>@k) = (f x)\<^sup>@k"
-  by (induction k) (simp add: morph)+
-
-lemma pop_hd: "f (a#u) = f [a] \<cdot> f u"
-  unfolding hd_word[of a u] using morph.
-
-lemma pop_hd_nemp: "u \<noteq> \<epsilon> \<Longrightarrow> f (u) = f [hd u] \<cdot> f (tl u)"
-  using list.exhaust_sel pop_hd[of "hd u" "tl u"] by force
-
-lemma pop_last_nemp: "u \<noteq> \<epsilon> \<Longrightarrow> f (u) = f (butlast u) \<cdot> f [last u]"
-  unfolding morph[symmetric] append_butlast_last_id ..
-
-lemma pref_mono: "u \<le>p v \<Longrightarrow> f u \<le>p f v"
-  using morph by auto
-
-lemma morph_concat_map: "f x = concat (map (\<lambda> x. f [x]) x)"
-proof (induction x, simp)
-  case (Cons a x)
-  then show ?case
-    unfolding pop_hd[of a x] by auto
-qed
-
-end
-
-locale two_morphisms = morphg: morphism g + morphh: morphism h for g h :: "'a list \<Rightarrow> 'b list"
-begin
-lemma def_on_sings:
-  assumes "\<And>a. g [a] = h [a]"
-  shows "g u = h u"
-proof (induct u, simp)
-next
-  case (Cons a u)
-  then show ?case
-    unfolding morphg.pop_hd[of a u] morphh.pop_hd[of a u] using \<open>\<And>a. g [a] = h [a]\<close>  by presburger
-qed
-end
-
-section \<open>Reversed morphism and composition\<close>
-
-definition rev_morph :: "('a list \<Rightarrow> 'b list) \<Rightarrow> ('a list \<Rightarrow> 'b list)" where
-  "rev_morph f = rev \<circ> f \<circ> rev"
-
-lemma rev_morph_idemp[simp]: "rev_morph (rev_morph f) = f"
-  unfolding rev_morph_def by auto
-
-lemma morph_compose: "morphism f \<Longrightarrow> morphism g \<Longrightarrow> morphism (f \<circ> g)"
-  by (simp add: morphism_def)
-
-lemma rev_morph_arg: "rev_morph f u = rev (f (rev u))"
-  by (simp add: rev_morph_def)
-
-lemmas rev_morph_arg_rev[reversal_rule] = rev_morph_arg[reversed add: rev_rev_ident]
-
-lemma rev_morph_sing: "rev_morph f [a] =  rev (f [a])"
-  unfolding rev_morph_def by simp
-
-context morphism
-begin
-
-lemma  rev_morph_morph: "morphism (rev_morph f)"
-  by (standard, auto simp add: rev_morph_def morph)
-
-lemma morph_rev_len:  "\<^bold>|f (rev u)\<^bold>| = \<^bold>|f u\<^bold>|"
-proof (induction u, simp)
-  case (Cons a u)
-  then show ?case
-    unfolding rev.simps(2) pop_hd[of a u] morph length_append by force
-qed
-
-lemma  rev_morph_len: "\<^bold>|rev_morph f u\<^bold>| = \<^bold>|f u\<^bold>|"
-  unfolding rev_morph_def
-  by (simp add: morph_rev_len)
-
-end
+lemma pow_pref_root_one: assumes "k \<noteq> 0" and "r \<noteq> \<epsilon>" and "r\<^sup>@k \<le>p r"
+  shows  "k = 1"
+  unfolding eq_pow_exp[OF \<open>r \<noteq> \<epsilon>\<close>, of k 1, symmetric] pow_one' 
+  using \<open>r\<^sup>@k \<le>p r\<close> triv_pref[of r "r\<^sup>@(k-1)", folded pop_pow_one[OF \<open>k \<noteq> 0\<close>]] by auto
+
+lemma count_list_pow: "count_list (w\<^sup>@k) a = k * (count_list w a)"
+  by (induction k, simp, (simp add: count_list_append))
+
+
+lemma comp_pows_pref: assumes  "v \<noteq> \<epsilon>" and "(u \<cdot> v)\<^sup>@k \<cdot> u \<le>p (u \<cdot> v)\<^sup>@m" shows "k \<le> m"
+  using pref_exp_le[OF _  pref_extD[OF assms(2)]] assms(1) by blast
+
+lemma comp_pows_pref': assumes  "v \<noteq> \<epsilon>" and "(u \<cdot> v)\<^sup>@k \<le>p (u \<cdot> v)\<^sup>@m \<cdot> u" shows "k \<le> m"
+proof(rule ccontr)
+  assume "\<not> k \<le> m"
+  hence "Suc m \<le> k" by simp
+  from le_exps_pref[OF this, unfolded pow_Suc2]
+  have "(u \<cdot> v)\<^sup>@m \<cdot> (u \<cdot> v) \<le>p (u \<cdot> v)\<^sup>@k".
+  from pref_trans[OF this assms(2)] \<open>v \<noteq> \<epsilon>\<close>
+  show False by auto
+qed  
+
+lemma comp_pows_not_pref: "\<not> (u \<cdot> v)\<^sup>@k \<cdot> u \<le>p (u \<cdot> v)\<^sup>@m \<Longrightarrow> m \<le> k"
+  by (induction k m rule: diff_induct, simp, simp, unfold pow_Suc rassoc pref_cancel_conv, simp)    
+
+lemma comp_pows_spref: "u\<^sup>@k <p u\<^sup>@m \<Longrightarrow> k < m" 
+  by (induction k m rule: diff_induct, fastforce, blast, force)   
+
+lemma comp_pows_spref_ext: "(u \<cdot> v)\<^sup>@k \<cdot> u <p (u \<cdot> v)\<^sup>@m \<Longrightarrow> k < m"
+  by (induction k m rule: diff_induct, fastforce, blast, force)   
+
+lemma comp_pows_pref_zero:"(u \<cdot> v)\<^sup>@k <p u \<Longrightarrow> k = 0"
+  by (induct k, simp, unfold pow_Suc, auto) 
+
+lemma comp_pows_spref': "(u \<cdot> v)\<^sup>@k <p (u \<cdot> v)\<^sup>@m \<cdot> u \<Longrightarrow> k < Suc m" 
+  by (induction k m rule: diff_induct, simp_all add: comp_pows_pref_zero)
+
+lemmas comp_pows_suf = comp_pows_pref[reversed] and
+       comp_pows_suf' =  comp_pows_pref'[reversed] and
+       comp_pows_not_suf = comp_pows_not_pref[reversed] and
+       comp_pows_ssuf = comp_pows_spref[reversed] and
+       comp_pows_ssuf_ext = comp_pows_spref_ext[reversed] and 
+       comp_pows_suf_zero = comp_pows_pref_zero[reversed] and
+       comp_pows_ssuf' = comp_pows_spref'[reversed]
+
+subsection Comparison
+
+\<comment> \<open>Lemmas allowing to compare complicated terms with powers\<close>
+
+named_theorems shifts
+lemma shift_pow[shifts]: "(u\<cdot>v)\<^sup>@k\<cdot>u = u\<cdot>(v\<cdot>u)\<^sup>@k"
+  using conjug_pow[OF rassoc].
+(* lemma[shifts]: "(u \<cdot> v \<cdot> w)\<^sup>@k \<cdot> u \<cdot> z = u \<cdot> (v \<cdot> w \<cdot> u)\<^sup>@k \<cdot> z" *)
+  (* by (simp add: shifts) *)
+lemma[shifts]: "(u \<cdot> v)\<^sup>@k \<cdot> u \<cdot> z = u \<cdot> (v \<cdot> u)\<^sup>@k \<cdot> z"
+  by (simp add: shift_pow)
+lemma[shifts]: "u\<^sup>@k \<cdot> u \<cdot> z = u \<cdot> u\<^sup>@k \<cdot> z"
+  by (simp add: conjug_pow)
+lemma[shifts]: "r\<^sup>@k \<le>p r \<cdot> r\<^sup>@k"
+  by (simp add: pow_comm[symmetric])
+lemma [shifts]: "r\<^sup>@k \<le>p r \<cdot> r\<^sup>@k \<cdot> z"
+  unfolding lassoc pow_comm[symmetric] unfolding rassoc by blast
+lemma [shifts]: "(r \<cdot> q)\<^sup>@k \<le>p r \<cdot> q \<cdot>  (r \<cdot> q)\<^sup>@k \<cdot> z"
+  unfolding lassoc pow_comm[symmetric] unfolding rassoc by simp
+lemma [shifts]: "(r \<cdot> q)\<^sup>@k \<le>p r \<cdot> q \<cdot>  (r \<cdot> q)\<^sup>@k"
+  unfolding lassoc pow_comm[symmetric] unfolding rassoc by simp
+lemma[shifts]: "r\<^sup>@k \<cdot> u \<le>p r \<cdot> r\<^sup>@k \<cdot> v \<longleftrightarrow> u \<le>p r \<cdot> v"
+  unfolding lassoc pow_comm[symmetric] unfolding rassoc pref_cancel_conv..
+lemma[shifts]: "u \<cdot> u\<^sup>@k \<cdot> z = u\<^sup>@k \<cdot> w \<longleftrightarrow> u \<cdot> z = w" 
+   unfolding lassoc pow_comm[symmetric] unfolding rassoc cancel..
+lemma[shifts]: "(r \<cdot> q)\<^sup>@k \<cdot> u \<le>p r \<cdot> q  \<cdot> (r \<cdot> q)\<^sup>@k \<cdot> v \<longleftrightarrow> u \<le>p r \<cdot> q \<cdot> v"   
+  unfolding lassoc pow_comm[symmetric] unfolding rassoc pref_cancel_conv..
+lemma[shifts]: "(r \<cdot> q)\<^sup>@k \<cdot> u = r \<cdot> q  \<cdot> (r \<cdot> q)\<^sup>@k \<cdot> v \<longleftrightarrow> u = r \<cdot> q \<cdot> v"   
+  unfolding lassoc pow_comm[symmetric] unfolding rassoc cancel..
+lemma[shifts]: "r \<cdot> q  \<cdot> (r \<cdot> q)\<^sup>@k \<cdot> v = (r \<cdot> q)\<^sup>@k \<cdot> u \<longleftrightarrow> r \<cdot> q \<cdot> v = u"   
+  unfolding lassoc pow_comm[symmetric] unfolding rassoc cancel..
+lemma shifts_spec [shifts]: "(u\<^sup>@k \<cdot> v)\<^sup>@l \<cdot> u \<cdot> u\<^sup>@k \<cdot> z = u\<^sup>@k \<cdot> (v \<cdot> u\<^sup>@k)\<^sup>@l \<cdot> u \<cdot> z"
+  unfolding lassoc cancel_right unfolding rassoc pow_comm[symmetric]
+  unfolding lassoc cancel_right shift_pow..
+lemmas [shifts] = shifts_spec[of "r \<cdot> q", unfolded rassoc] for r q
+lemmas [shifts] = shifts_spec[of "r \<cdot> q" _ _ _ \<epsilon> , unfolded rassoc clean_emp] for r q
+lemmas [shifts] = shifts_spec[of "r \<cdot> q" _ "r \<cdot> q", unfolded rassoc] for r q
+lemmas [shifts] = shifts_spec[of "r \<cdot> q" _ "r \<cdot> q" _ \<epsilon> , unfolded rassoc clean_emp] for r q
+lemma[shifts]: "(u \<cdot> (v \<cdot> u)\<^sup>@k)\<^sup>@j \<cdot> (u \<cdot> v)\<^sup>@k = (u \<cdot> v)\<^sup>@k \<cdot> (u \<cdot> (u \<cdot> v)\<^sup>@k)\<^sup>@j"
+  by (metis shift_pow)
+lemma[shifts]: "(u \<cdot> (v \<cdot> u)\<^sup>@k \<cdot> z)\<^sup>@j \<cdot> (u \<cdot> v)\<^sup>@k = (u \<cdot> v)\<^sup>@k \<cdot> (u \<cdot> z \<cdot> (u \<cdot> v)\<^sup>@k)\<^sup>@j"
+  by (simp add: conjug_pow) 
+lemmas[shifts] = pow_comm cancel rassoc pow_Suc pref_cancel_conv suf_cancel_conv add_exps cancel_right numeral_nat pow_zero clean_emp
+lemmas[shifts] = less_eq_Suc_le
+lemmas[shifts] =  neq0_conv 
+lemma shifts_hd_hd [shifts]: "a#b#v = [a] \<cdot> b#v"
+  using hd_word.
+lemmas [shifts] =  shifts_hd_hd[of _ _ \<epsilon>]
+lemma[shifts]: "n \<le> k \<Longrightarrow> x\<^sup>@k = x\<^sup>@(n + (k -n))"
+  by simp
+lemma[shifts]: "n < k \<Longrightarrow> x\<^sup>@k = x\<^sup>@(n + (k -n))"
+  by simp
+(* lemmas[shifts] = less_imp_le *)
+
+lemmas shifts_rev = shifts[reversed]
+
+method comparison = ((simp only: shifts; fail) | simp only: shifts_rev)
 
 section \<open>Rotation\<close>
 
 lemma rotate_comp_eq:"w \<bowtie> rotate n w \<Longrightarrow> rotate n w = w"
   using  pref_same_len[OF _ length_rotate[of n w]] pref_same_len[OF _ length_rotate[of n w, symmetric], symmetric]
   by blast
 
 corollary mismatch_iff_lexord: assumes "rotate n w \<noteq> w" and "irrefl r"
   shows "mismatch_pair w (rotate  n w) \<in> r \<longleftrightarrow> (w,rotate n w) \<in> lexord r"
 proof-
   have "\<not> w \<bowtie> rotate n w"
     using rotate_comp_eq \<open>rotate n w \<noteq> w\<close>
     unfolding prefix_comparable_def by blast
   from lexord_mismatch[OF this \<open>irrefl r\<close>]
   show ?thesis.
 qed
 
 lemma rotate_back: obtains m where "rotate m (rotate n u) = u"
 proof(cases "u = \<epsilon>", simp)
   assume "u \<noteq> \<epsilon>"
   show ?thesis
     using that[of "\<^bold>|u\<^bold>| - n mod \<^bold>|u\<^bold>|"]
     unfolding rotate_rotate[of "\<^bold>|u\<^bold>| - n mod \<^bold>|u\<^bold>|" "n mod \<^bold>|u\<^bold>|" u]
       le_add_diff_inverse2[OF
         less_imp_le_nat[OF mod_less_divisor[OF nemp_len[OF \<open>u \<noteq> \<epsilon>\<close>, unfolded neq0_conv], of n]]]
       arg_cong[OF rotate_conv_mod[of n u], of "rotate (\<^bold>|u\<^bold>| - n mod \<^bold>|u\<^bold>|)"]
     by simp
 qed
 
 lemma rotate_class_rotate': "(\<exists>n. rotate n w = u) \<longleftrightarrow> (\<exists>n. rotate n (rotate l w) = u)"
 proof
   obtain m where rot_m: "rotate m (rotate l w) = w" using rotate_back.
   assume "\<exists>n. rotate n w = u"
   then obtain n where rot_n: "rotate n w = u" by blast
   show "\<exists>n. rotate n (rotate l w) = u"
     using  exI[of "\<lambda> x. rotate x (rotate l w) = u" "n+m", OF
         rotate_rotate[symmetric, of n m "rotate l w", unfolded rot_m rot_n]].
 next
   show "\<exists>n. rotate n (rotate l w) = u \<Longrightarrow> \<exists>n. rotate n w = u"
     using rotate_rotate[symmetric] by blast
 qed
 
 lemma rotate_class_rotate: "{u . \<exists>n. rotate n w = u} = {u . \<exists>n. rotate n (rotate l w) = u}"
   using rotate_class_rotate' by blast
 
 lemma rotate_pow_self: "rotate (l*\<^bold>|u\<^bold>|) (u\<^sup>@k) = u\<^sup>@k"
 proof(induct l, simp)
   case (Suc l)
   then show ?case
   proof(cases "k = 0", simp)
     assume "k \<noteq> 0"
     show ?thesis
       unfolding rotate_rotate[of "\<^bold>|u\<^bold>|" "l * \<^bold>|u\<^bold>|" "u\<^sup>@k", unfolded mult_Suc[symmetric] Suc.hyps, symmetric]
       using rotate_append[of u "u\<^sup>@(k-1)", folded pop_pow_one[OF \<open>k \<noteq> 0\<close>, of u] pop_pow_one'[OF \<open>k \<noteq> 0\<close>, of u]].
   qed
 qed
 
 lemma rotate_root_self: "rotate \<^bold>|r\<^bold>| (r\<^sup>@k) = r\<^sup>@k"
   using rotate_pow_self[of 1 r k] by auto
 
 lemma rotate_pow_mod:  "rotate n (u\<^sup>@k) = rotate (n mod \<^bold>|u\<^bold>|) (u\<^sup>@k)"
   using rotate_rotate[of "n mod \<^bold>|u\<^bold>|" "n div \<^bold>|u\<^bold>| * \<^bold>|u\<^bold>|" "u\<^sup>@k", symmetric]
   unfolding rotate_pow_self[of "n div \<^bold>|u\<^bold>|" u k] div_mult_mod_eq[of n "\<^bold>|u\<^bold>|", unfolded add.commute[of "n div \<^bold>|u\<^bold>| * \<^bold>|u\<^bold>|" "n mod \<^bold>|u\<^bold>|"]].
 
 lemma rotate_conj_pow: "rotate \<^bold>|u\<^bold>| ((u\<cdot>v)\<^sup>@k) = (v\<cdot>u)\<^sup>@k"
-  by (induct k, simp, simp add: rotate_append shift_pow)
+ by (induct k, simp, simp add: rotate_append shift_pow) 
 
 lemma rotate_pow_comm: "rotate n (u\<^sup>@k) = (rotate n u)\<^sup>@k"
 proof (cases "u = \<epsilon>", simp)
   assume "u \<noteq> \<epsilon>"
   show ?thesis
     unfolding rotate_drop_take[of n u] rotate_pow_mod[of n u k]
     using rotate_conj_pow[of "take (n mod \<^bold>|u\<^bold>|) u" "drop (n mod \<^bold>|u\<^bold>|) u" k, unfolded append_take_drop_id[of "n mod \<^bold>|u\<^bold>|" u]]
     unfolding  mod_le_divisor[of "\<^bold>|u\<^bold>|" n, THEN take_len, OF \<open>u\<noteq>\<epsilon>\<close>[unfolded length_greater_0_conv[symmetric]]].
 qed
 
-
-subsection \<open>Lists of words and their concatenation\<close>
+lemmas rotate_pow_comm_two = rotate_pow_comm[of _ _ 2, unfolded pow_two]
+
+
+section \<open>Lists of words and their concatenation\<close>
 
 text\<open>The helpful lemmas of this section deal with concatenation of a list of words @{term concat}.
 The main objective is to cover elementary facts needed to study factorizations of words.
 \<close>
 
-
-lemma append_in_lists: "u \<in> lists A \<Longrightarrow> v \<in> lists A \<Longrightarrow> u \<cdot> v \<in> lists A"
-  by simp
-
 lemma concat_take_is_prefix: "concat(take n ws) \<le>p concat ws"
-  using concat_morph[of "take n ws" "drop n ws", unfolded append_take_drop_id[of n ws], THEN prefI].
+  using concat_morph[of "take n ws" "drop n ws",symmetric, unfolded append_take_drop_id[of n ws], THEN prefI].
 
 lemma concat_take_suc: assumes "j < \<^bold>|ws\<^bold>|" shows "concat(take j ws) \<cdot> ws!j = concat(take (Suc j) ws)"
   unfolding take_Suc_conv_app_nth[OF \<open>j < \<^bold>|ws\<^bold>|\<close>]
   using sym[OF concat_append[of "(take j ws)" "[ws ! j]",
         unfolded concat.simps(2)[of "ws!j" \<epsilon>, unfolded concat.simps(1) append_Nil2]]].
 
-lemma pref_mod_list': assumes "u \<le>np concat ws"
-  obtains j r where "j < \<^bold>|ws\<^bold>|" and "r \<le>np ws!j" and "concat (take j ws) \<cdot> r = u"
-proof-
-  have "\<^bold>|ws\<^bold>| \<noteq> 0"
-    using assms by fastforce
-  then obtain l where "Suc l = \<^bold>|ws\<^bold>|"
-    using Suc_pred by blast
-  let ?P = "\<lambda> j. u \<le>p concat(take (Suc j) ws)"
-  have "?P l"
-    using assms  \<open>Suc l = \<^bold>|ws\<^bold>|\<close> by auto
-
-  define j where "j = (LEAST j. ?P j)" \<comment> \<open>largest j such that concat (take j ws) <p u\<close>
-  have "u \<le>p concat(take (Suc j) ws)" and "j < \<^bold>|ws\<^bold>|"
-    using Least_le[of ?P, OF \<open>?P l\<close>]
-      LeastI[of ?P, OF \<open>?P l\<close>] \<open>Suc l = \<^bold>|ws\<^bold>|\<close>
-    unfolding sym[OF j_def] by auto
-
-  have "concat(take j ws) <p u"
-  proof (cases "j = 0")
-    assume "j = 0" thus "concat(take j ws) <p u"
-      using  assms by fastforce
-  next
-    assume "j \<noteq> 0" hence "j - 1 < j" and "Suc (j-1) = j" by auto
-    hence "\<not> ?P (j-1)"
-      using j_def not_less_Least by blast
-    from this[unfolded \<open>Suc (j-1) = j\<close>]
-    show "concat(take j ws) <p u"
-      using pref_comp_not_pref ruler[OF concat_take_is_prefix npD[OF assms], of j]
-      unfolding prefix_comparable_def by blast
-  qed
-
-  let ?r = "concat(take j ws)\<inverse>\<^sup>>u"
-  have "concat(take j ws) \<cdot> ?r = u" and "?r \<noteq> \<epsilon>"
-    using \<open>concat (take j ws) <p u\<close> by auto
-  have "?r \<le>p ws!j"
-    using  pref_cancel[of "concat (take j ws)" "concat (take j ws)\<inverse>\<^sup>>u" "ws ! j"]
-      \<open>u \<le>p concat (take (Suc j) ws)\<close>[unfolded sym[OF concat_take_suc[OF \<open>j < \<^bold>|ws\<^bold>|\<close>]]]
-      \<open>concat (take j ws) \<cdot> concat (take j ws)\<inverse>\<^sup>>u = u\<close> by argo
-  show thesis
-    using that[OF \<open>j < \<^bold>|ws\<^bold>|\<close>  npI[OF \<open>?r \<noteq> \<epsilon>\<close> \<open>?r \<le>p ws!j\<close>] \<open>concat(take j ws) \<cdot> ?r = u\<close>].
-qed
-
-
-lemma pref_mod_list_suf: assumes "u \<le>np concat ws"
-  obtains j s where "j < \<^bold>|ws\<^bold>|" and "s <s ws!j" and "concat (take (Suc j) ws) = u \<cdot> s"
-proof-
-  obtain j r where "j < \<^bold>|ws\<^bold>|" and "r \<le>np ws!j" and "concat (take j ws) \<cdot> r = u"
-    using pref_mod_list'[OF assms] by blast
-  have "r\<inverse>\<^sup>>(ws!j) <s (ws!j)"
-    using ssufI1[OF _ npD'[OF \<open>r \<le>np ws ! j\<close>]]  lq_pref[OF npD[OF \<open>r \<le>np ws ! j\<close>]].
-  have "concat (take (Suc j) ws) = u \<cdot> r\<inverse>\<^sup>>(ws!j)"
-    using lq_pref[OF npD[OF \<open>r \<le>np ws ! j\<close>], symmetric, unfolded
-        same_append_eq[of "concat (take j ws)" "ws ! j" "r \<cdot> r\<inverse>\<^sup>>ws ! j", symmetric] lassoc
-        \<open>concat (take j ws) \<cdot> r = u\<close> concat_take_suc[OF \<open>j < \<^bold>|ws\<^bold>|\<close>] \<open>r \<le>np ws!j\<close>].
-  from that[OF \<open>j < \<^bold>|ws\<^bold>|\<close> \<open>r\<inverse>\<^sup>>(ws!j) <s (ws!j)\<close> this]
-  show thesis.
-qed
-
-
-lemma suf_mod_list': "s \<le>ns concat ws \<Longrightarrow> ws \<noteq> \<epsilon> \<Longrightarrow> \<exists>j r. j < \<^bold>|ws\<^bold>| \<and> r \<cdot> (concat (drop (Suc j) ws)) = s \<and> r \<le>ns ws!j"
-proof-
-  assume "s \<le>ns concat ws" "ws \<noteq> \<epsilon>"
-
-  have "rev s \<le>np concat (rev (map (\<lambda>u. rev u) ws))"
-    using \<open>s \<le>ns concat ws\<close>[unfolded nsuf_rev_pref_iff]
-    by (simp add: rev_concat rev_map)
-  have  "rev ws \<noteq> \<epsilon>"
-    by (simp add: \<open>ws \<noteq> \<epsilon>\<close>)
-  then obtain j r where "j < \<^bold>|rev (map rev ws)\<^bold>|" "concat (take j (rev (map rev ws))) \<cdot> r = rev s" "r \<le>np rev (map rev ws) ! j"
-    using pref_mod_list'[of "rev s" "rev (map (\<lambda>u. rev u) ws)" thesis]
-      \<open>rev s \<le>np concat (rev (map rev ws))\<close> by blast
-
-  have "rev ws ! j = rev (rev (map rev ws) ! j)"
-    using \<open>j < \<^bold>|rev (map rev ws)\<^bold>|\<close> length_map nth_map[of j "rev ws" rev, unfolded rev_map[of rev ws, symmetric]]  rev_rev_ident
-    by simp
-  from \<open>j < \<^bold>|rev (map rev ws)\<^bold>|\<close> rev_nth[of j ws, unfolded this]
-  have "rev (rev (map rev ws) ! j) = ws!(\<^bold>|ws\<^bold>|- Suc j)"
-    by fastforce
-  from \<open>r \<le>np rev (map rev ws) ! j\<close>[unfolded npref_rev_suf_iff, unfolded this]
-  have p2: "rev r \<le>ns ws!(\<^bold>|ws\<^bold>|-Suc j)".
-  have "concat (take j (rev (map rev ws))) = rev (concat (drop (\<^bold>|ws\<^bold>|-j) ws))"
-    by (simp add: rev_concat rev_map take_map take_rev)
-  from arg_cong[OF this, of "\<lambda>x. x\<cdot>r", unfolded \<open>concat (take j (rev (map rev ws))) \<cdot> r = rev s\<close>]
-  have p1: "s = rev r \<cdot> (concat (drop (\<^bold>|ws\<^bold>|-j) ws))"
-    using  rev_append[of "rev (concat (drop (\<^bold>|ws\<^bold>| - j) ws))" r] rev_rev_ident[of s] rev_rev_ident[of "(concat (drop (\<^bold>|ws\<^bold>| - j) ws))"]
-    by argo
-
-  have p0: "\<^bold>|ws\<^bold>| - Suc j < \<^bold>|ws\<^bold>|"
-    by (simp add: \<open>ws \<noteq> \<epsilon>\<close>)
-
-  have "\<^bold>|ws\<^bold>| - j = Suc (\<^bold>|ws\<^bold>| - Suc j)"
-    using  Suc_diff_Suc[OF \<open>j < \<^bold>|rev (map rev ws)\<^bold>|\<close>] by auto
-  from p0 p1[unfolded this] p2 show ?thesis
-    by blast
-qed
-
 lemma pref_mod_list: assumes "u <p concat ws"
   obtains j r where "j < \<^bold>|ws\<^bold>|" and "r <p ws!j" and "concat (take j ws) \<cdot> r = u"
 proof-
   have "\<^bold>|ws\<^bold>| \<noteq> 0"
     using assms by auto
   then obtain l where "Suc l = \<^bold>|ws\<^bold>|"
     using Suc_pred by blast
   let ?P = "\<lambda> j. u <p concat(take (Suc j) ws)"
   have "?P l"
     using assms  \<open>Suc l = \<^bold>|ws\<^bold>|\<close> by auto
   define j where "j = (LEAST j. ?P j)" \<comment> \<open>smallest j such that concat (take (Suc j) ws) <p u\<close>
   have "u <p concat(take (Suc j) ws)"
     using  LeastI[of ?P, OF \<open>?P l\<close>] unfolding sym[OF j_def].
   have  "j < \<^bold>|ws\<^bold>|"
-    using Least_le[of ?P, OF \<open>?P l\<close>] \<open>Suc l = \<^bold>|ws\<^bold>|\<close> unfolding sym[OF j_def]
+    using Least_le[of ?P, OF \<open>?P l\<close>] \<open>Suc l = \<^bold>|ws\<^bold>|\<close> unfolding sym[OF j_def] 
     by auto
-  have "0 < j \<Longrightarrow> concat(take j ws) \<le>p u"
-    using Least_le[of ?P "(j- Suc 0)", unfolded sym[OF j_def]]
+  have "concat(take j ws) \<le>p u"
+    using Least_le[of ?P "(j - Suc 0)", unfolded sym[OF j_def]]
       ruler[OF concat_take_is_prefix sprefD1[OF assms], of j]
-    by force
-  hence "concat(take j ws) \<le>p u"
-    by fastforce
-  let ?r = "concat(take j ws)\<inverse>\<^sup>>u"
-  have "concat(take j ws) \<cdot> ?r = u"
-    using \<open>concat (take j ws) \<le>p u\<close> by auto
-  have "?r <p ws!j"
-    using spref_lq[OF \<open>concat (take j ws) \<le>p u\<close> \<open>u <p concat (take (Suc j) ws)\<close>, unfolded
-        lq_triv[of "concat (take j ws)" "ws!j", unfolded concat_take_suc[OF \<open>j < \<^bold>|ws\<^bold>|\<close>]]].
+    by (cases "j = 0", simp) force
+  from prefixE[OF this] 
+  obtain r where "u = concat(take j ws) \<cdot> r".
+  from \<open>u <p concat (take (Suc j) ws)\<close>[unfolded this] 
+  have "r <p ws!j"
+    unfolding concat_take_suc[OF \<open>j < \<^bold>|ws\<^bold>|\<close>, symmetric]  spref_cancel_conv.
   show thesis
-    using that[OF \<open>j < \<^bold>|ws\<^bold>|\<close> \<open>?r <p ws!j\<close> \<open>concat(take j ws) \<cdot> ?r = u\<close>].
+    using that[OF \<open>j < \<^bold>|ws\<^bold>|\<close> \<open>r <p ws!j\<close> \<open>u = concat(take j ws) \<cdot> r\<close>[symmetric]].
 qed
 
 lemma pref_mod_power: assumes "u <p w\<^sup>@l"
   obtains k z where "k < l" and "z <p w" and "w\<^sup>@k\<cdot>z = u"
   using pref_mod_list[of u "[w]\<^sup>@l", unfolded sing_pow_len concat_sing_pow, OF \<open>u <p w\<^sup>@l\<close>, of thesis]
-    sing_pow[of _ l w] concat_take_sing
+    sing_pow_nth[of _ l w] concat_take_sing
     less_imp_le_nat by metis
 
 lemma get_pow_exp: assumes "z <p t" shows "m = \<^bold>|t\<^sup>@m\<cdot>z\<^bold>| div \<^bold>|t\<^bold>|"
-  unfolding length_append[of "t\<^sup>@m" z, unfolded pow_len] using  get_div[OF prefix_length_less[OF assms]].
+  unfolding lenmorph[of "t\<^sup>@m" z, unfolded pow_len] using  get_div[OF prefix_length_less[OF assms]].
 
 lemma get_pow_remainder: assumes "z <p t" shows "z = drop ((\<^bold>|t\<^sup>@m\<cdot>z\<^bold>| div \<^bold>|t\<^bold>|)*\<^bold>|t\<^bold>|) (t\<^sup>@m\<cdot>z)"
   using  drop_pref[of "t\<^sup>@m" z]  pow_len[of t m] get_pow_exp[OF assms, of m] by simp
 
-lemma pref_mod_power': assumes "u \<le>np w\<^sup>@l"
-  obtains k z where "k < l" and "z \<le>np w" and "w\<^sup>@k\<cdot>z = u"
-  using pref_mod_list'[of u "[w]\<^sup>@l", unfolded sing_pow_len concat_sing_pow, OF \<open>u \<le>np w\<^sup>@l\<close>]
-    sing_pow[of _ l w] concat_take_sing[of _ l w]
-    less_imp_le_nat[of _ l] by metis
-
 lemma pref_power: assumes "t \<noteq> \<epsilon>" and  "u \<le>p t\<^sup>@k"
   shows "\<exists> m. t\<^sup>@m \<le>p u \<and> u <p t\<^sup>@m \<cdot> t"
 proof (cases "u = t\<^sup>@k")
   show "u = t \<^sup>@ k \<Longrightarrow> \<exists>m. t \<^sup>@ m \<le>p u \<and> u <p t \<^sup>@ m \<cdot> t"
     using \<open>t \<noteq> \<epsilon>\<close> by blast
 next
   assume "u \<noteq> t \<^sup>@ k"
   obtain m z where "m < k" "z <p t" "t \<^sup>@ m \<cdot> z = u"
     using pref_mod_power[of u t k] \<open>u \<le>p t\<^sup>@k\<close>[unfolded prefix_order.dual_order.order_iff_strict] \<open>u \<noteq> t\<^sup>@k\<close>
     by blast
-  hence "t \<^sup>@ m \<le>p u" and "u <p t \<^sup>@ m \<cdot> t" by auto
+  hence "t \<^sup>@ m \<le>p u" and "u <p t \<^sup>@ m \<cdot> t"
+    using \<open>t \<^sup>@ m \<cdot> z = u\<close> \<open>z <p t\<close> spref_cancel_conv by blast+
   thus ?thesis by blast
 qed
 
 lemma pref_powerE: assumes "t \<noteq> \<epsilon>" and  "u \<le>p t\<^sup>@k"
   obtains m where "t\<^sup>@m \<le>p u" "u <p t\<^sup>@m \<cdot> t"
   using assms pref_power by blast
 
-lemma pref_power': assumes "u \<noteq> \<epsilon>" and  "u \<le>p t\<^sup>@k"
-  shows "\<exists> m. t\<^sup>@m <p u \<and> u \<le>p t\<^sup>@m \<cdot> t"
-proof-
-  obtain m z where "m < k" "z \<le>np t" "t \<^sup>@ m \<cdot> z = u"
-    using pref_mod_power'[OF npI[OF \<open>u \<noteq> \<epsilon>\<close> \<open>u \<le>p t\<^sup>@k\<close>]].
-  thus ?thesis
-    by auto
-qed
-
-lemma suf_power: assumes "t \<noteq> \<epsilon>" and "u \<le>s t\<^sup>@k" shows "\<exists>m. t\<^sup>@m \<le>s u \<and> u <s t \<cdot> t\<^sup>@m"
-proof-
-  have "rev u \<le>p (rev t)\<^sup>@k"
-    using \<open>u \<le>s t\<^sup>@k\<close>[unfolded suffix_to_prefix rev_pow].
-  from pref_power[OF _ this]
-  obtain m where "(rev t)\<^sup>@m \<le>p rev u" and "rev u <p (rev t)\<^sup>@m \<cdot> rev t"
-    using \<open>t \<noteq> \<epsilon>\<close> by blast
-  have "t\<^sup>@m \<le>s u"
-    using \<open>(rev t)\<^sup>@m \<le>p rev u\<close>[folded suffix_to_prefix rev_pow].
-  moreover have "u <s t \<cdot> t\<^sup>@m"
-    using sprefD1[OF \<open>rev u <p (rev t)\<^sup>@m \<cdot> rev t\<close>, folded rev_pow  rev_append suffix_to_prefix]
-      sprefD2[OF \<open>rev u <p (rev t)\<^sup>@m \<cdot> rev t\<close>, folded rev_pow  rev_append]
-     by blast
-  ultimately show ?thesis by blast
-qed
+(* lemma pref_power': assumes "u \<noteq> \<epsilon>" and  "u \<le>p t\<^sup>@k" *)
+  (* shows "\<exists> m. t\<^sup>@m <p u \<and> u \<le>p t\<^sup>@m \<cdot> t" *) 
+(* proof- *)
+  (* obtain m z where "m < k" "z \<le>np t" "t \<^sup>@ m \<cdot> z = u" *)
+    (* using pref_mod_power'[OF npI[OF \<open>u \<noteq> \<epsilon>\<close> \<open>u \<le>p t\<^sup>@k\<close>]]. *)
+  (* thus ?thesis *)
+    (* by auto *)
+(* qed *)
+
+lemmas suf_power = pref_power[reversed]
 
 lemma suf_powerE: assumes "t \<noteq> \<epsilon>" and  "u \<le>s t\<^sup>@k"
   obtains m where "t\<^sup>@m \<le>s u" "u <s t \<cdot> t\<^sup>@m"
   using assms suf_power by blast
 
 lemma del_emp_concat: "concat us = concat (filter (\<lambda>x. x \<noteq> \<epsilon>) us)"
   by (induct us) simp+
 
 lemma lists_drop_emp: "us \<in> lists C\<^sub>+ \<Longrightarrow> us \<in> lists C"
   by blast
 
 lemma lists_drop_emp': "us \<in> lists C \<Longrightarrow> (filter (\<lambda>x. x \<noteq> \<epsilon>) us) \<in> lists C\<^sub>+"
   by (simp add: in_lists_conv_set)
 
 lemma pref_concat_pref: "us \<le>p ws \<Longrightarrow> concat us \<le>p concat ws"
-  by auto
-
-lemma le_take_is_prefix: assumes "k \<le> n" shows "take k ws \<le>p take n ws"
-  using take_add[of k "(n-k)" ws, unfolded le_add_diff_inverse[OF \<open>k \<le> n\<close>]]
-  by force
+  by (auto simp add: prefix_def)
+
+lemmas suf_concat_suf = pref_concat_pref[reversed]
+
+lemma concat_mono_fac: "us \<le>f ws \<Longrightarrow> concat us \<le>f concat ws"
+  using  concat_morph facE facI' by metis
+
+lemma ruler_concat_less: assumes "us \<le>p ws" and "vs \<le>p ws" and "\<^bold>|concat us\<^bold>| < \<^bold>|concat vs\<^bold>|"
+  shows "us <p vs"
+  using ruler[OF \<open>us \<le>p ws\<close> \<open>vs \<le>p ws\<close>] pref_concat_pref[of vs us, THEN prefix_length_le] \<open>\<^bold>|concat us\<^bold>| < \<^bold>|concat vs\<^bold>|\<close>
+  by force                                                                                    
+
+lemma concat_take_mono_strict: assumes "concat (take i ws) <p concat (take j ws)" 
+  shows "take i ws <p take j ws" 
+  using ruler_concat_less[OF _ _ prefix_length_less, OF take_is_prefix take_is_prefix assms].
 
 lemma take_pp_less: assumes "take k ws <p take n ws" shows "k < n"
   using  conjunct2[OF sprefD[OF assms]]
-    leI[of k n, THEN[2] le_take_is_prefix[of n k ws, THEN[2] pref_antisym[of "take k ws" "take n ws"]], OF conjunct1[OF sprefD[OF assms]]]
+    leI[of k n, THEN[2] le_take_pref[of n k ws, THEN[2] pref_antisym[of "take k ws" "take n ws"]], OF conjunct1[OF sprefD[OF assms]]]
   by blast
 
 lemma concat_pp_less: assumes "concat (take k ws) <p concat (take n ws)" shows "k < n"
-  using le_take_is_prefix[of n k ws, THEN pref_concat_pref] conjunct1[OF sprefD[OF assms]]
+  using le_take_pref[of n k ws, THEN pref_concat_pref] conjunct1[OF sprefD[OF assms]]
     conjunct2[OF sprefD[OF assms]] pref_antisym[of "concat(take k ws)" "concat(take n ws)"]
   by fastforce
 
+lemma take_le_take: "j \<le> k \<Longrightarrow> take j (take k xs) = take j xs"
+proof (rule disjE[OF le_less_linear, of k "\<^bold>|xs\<^bold>|"])
+  assume "j \<le> k" and "k \<le> \<^bold>|xs\<^bold>|"
+  show ?thesis
+    using pref_share_take[OF take_is_prefix, of j k xs, unfolded take_len[OF \<open>k \<le> \<^bold>|xs\<^bold>|\<close>], OF \<open>j \<le> k\<close>].
+qed simp
+
+lemma concat_interval: assumes "concat (take k vs) = concat (take j vs) \<cdot> s" shows "concat (drop j (take k vs)) = s"
+proof (rule disjE[OF le_less_linear, of k j])
+  note eq1 = assms[folded  arg_cong[OF takedrop[of j "take k vs"], of concat, unfolded concat_morph]]
+  assume "j < k" 
+  from eq1[unfolded take_le_take[OF less_imp_le[OF this]]]
+  show ?thesis
+    unfolding cancel. 
+next
+  note eq1 = assms[folded  arg_cong[OF takedrop[of j "take k vs"], of concat, unfolded concat_morph]]
+  assume "k \<le> j"
+  from pref_concat_pref[OF le_take_pref, OF this, of vs, unfolded assms]
+  have "s = \<epsilon>"
+    by force
+  from drop_all[OF le_trans[OF len_take1 \<open>k \<le> j\<close>], of vs]
+  have "concat (drop j (take k vs)) = \<epsilon>"
+    using concat.simps(1) by force   
+  with \<open>s = \<epsilon>\<close>
+  show ?thesis by blast
+qed
+
+lemma bin_lists_count_zero': assumes "ws \<in> lists {x,y}" and "count_list ws y = 0"
+  shows "ws \<in> lists {x}"
+  using assms
+proof (induct ws, simp)
+  case (Cons a ws)
+  have "a \<noteq> y"
+    using \<open>count_list (a # ws) y = 0\<close> count_list.simps(2) by force
+  hence "count_list ws y = 0"
+    using \<open>count_list (a # ws) y = 0\<close> count_list.simps(2) by force
+  from Cons.hyps(3)[OF this]
+  show ?case
+    using \<open>a \<in> {x,y}\<close>  \<open>a \<noteq> y\<close> by auto       
+qed 
+
+lemma bin_lists_count_zero: assumes "ws \<in> lists {x,y}" and "count_list ws x = 0"
+  shows "ws \<in> lists {y}"
+  using assms unfolding insert_commute[of x y "{}"] using  bin_lists_count_zero' by metis
+
+lemma count_in: "count_list ws a \<noteq> 0 \<Longrightarrow> a \<in> set ws"
+  using count_notin[of a ws] by fast
+
+lemma count_in_conv: "count_list w a \<noteq> 0 \<longleftrightarrow>  a \<in> set w" 
+  by (induct w, auto)
+
+lemma two_in_set_concat_len: assumes "u \<noteq> v" and "{u,v} \<subseteq> set ws"
+  shows "\<^bold>|u\<^bold>| + \<^bold>|v\<^bold>| \<le> \<^bold>|concat ws\<^bold>|"
+proof-
+  let ?ws = "filter (\<lambda> x. x \<in> {u,v}) ws"
+  have set: "set ?ws = {u,v}"
+    using \<open>{u,v} \<subseteq> set ws\<close> by auto
+  have "\<^bold>|concat ?ws\<^bold>| \<le> \<^bold>|concat ws\<^bold>|"
+    unfolding length_concat  using sum_list_filter_le_nat by blast 
+  have sum: "sum (\<lambda> x. count_list ?ws x * \<^bold>|x\<^bold>|) {u,v} = (count_list ?ws u) * \<^bold>|u\<^bold>| + (count_list ?ws v)*\<^bold>|v\<^bold>|"
+    using assms by simp
+  have "count_list ?ws u \<noteq> 0" and "count_list ?ws v \<noteq> 0"
+    unfolding count_in_conv using assms by simp_all
+  hence "\<^bold>|u\<^bold>| + \<^bold>|v\<^bold>| \<le> \<^bold>|concat ?ws\<^bold>|"
+    unfolding length_concat sum_list_map_eq_sum_count set sum
+    using add_le_mono quotient_smaller by presburger 
+  thus ?thesis
+    using \<open>\<^bold>|concat ?ws\<^bold>| \<le> \<^bold>|concat ws\<^bold>|\<close> by linarith
+qed
+
+
 section \<open>Root\<close>
 
 definition root :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" ("_ \<in> _*" [51,51] 60 )
   where  "u \<in> r* =  (\<exists> k. r\<^sup>@k = u)"
 notation (latex output) root ("_ \<in> _\<^sup>*")
 
+abbreviation not_root :: "['a list, 'a list] \<Rightarrow> bool"  ("_ \<notin> _*" [51,51] 60 )
+  where "u \<notin> r* \<equiv> \<not> (u \<in> r*)"
+
 text\<open>Empty word has all roots, including the empty root.\<close>
 
-lemma "\<epsilon> \<in> r*"
+lemma emp_all_roots [simp]: "\<epsilon> \<in> r*"
   unfolding root_def using power_0 by blast
 
 lemma rootI: "r\<^sup>@k \<in> r*"
   using root_def by auto
 
 lemma self_root: "u \<in> u*"
   using rootI[of u "Suc 0"] by simp
 
 lemma rootE: assumes "u \<in> r*" obtains k where "r\<^sup>@k = u"
-  using assms root_def by auto
-
-lemma empty_all_roots[simp]: "\<epsilon> \<in> r*"
-  using  rootI[of r 0, unfolded pow_zero].
-
-lemma take_root: "k \<noteq> 0 \<Longrightarrow> r = take (length r) (r\<^sup>@k)"
-  by (simp add: pow_eq_if_list)
+  using assms root_def by blast
+
+lemma root_nemp_expE: assumes "w \<in> r*" and "w \<noteq> \<epsilon>"
+  obtains k where "r\<^sup>@Suc k = w"
+proof-
+  obtain k where "r\<^sup>@k = w" using rootE[OF \<open>w \<in> r*\<close>].
+  have "k \<noteq> 0" using pow_zero[of r] \<open>w \<noteq> \<epsilon>\<close>[folded \<open>r\<^sup>@k = w\<close>] by metis 
+  from not0_implies_Suc[OF \<open>k \<noteq> 0\<close>]
+  obtain k' where "k = Suc k'" by blast
+  from that[OF \<open>r\<^sup>@k = w\<close>[unfolded this]] show thesis.
+qed
+
+lemma root_rev_iff[reversal_rule]: "rev u \<in> rev t* \<longleftrightarrow> u \<in> t*"
+  unfolding root_def[reversed] using root_def..
+
+lemma per_root_pref[intro]: "w \<noteq> \<epsilon> \<Longrightarrow> w \<in> r* \<Longrightarrow> r \<le>p w"
+  using root_nemp_expE[unfolded pow_Suc] triv_pref by metis
+
+lemmas per_root_suf[intro] =  per_root_pref[reversed]
+
+lemma per_exp_eq: "u \<le>p r\<cdot>u \<Longrightarrow> \<^bold>|u\<^bold>| = k*\<^bold>|r\<^bold>| \<Longrightarrow> u \<in> r*"
+  using per_exp_pref[THEN pref_prod_eq] unfolding pow_len root_def by blast
+
+lemma take_root: assumes "k \<noteq> 0" shows "r = take \<^bold>|r\<^bold>| (r\<^sup>@k)"
+  unfolding pop_pow_one[OF assms] by force
 
 lemma root_nemp: "u \<noteq> \<epsilon> \<Longrightarrow> u \<in> r* \<Longrightarrow> r \<noteq> \<epsilon>"
   unfolding root_def using emp_pow by auto
 
 lemma root_shorter: "u \<noteq> \<epsilon> \<Longrightarrow> u \<in> r* \<Longrightarrow> u \<noteq> r \<Longrightarrow> \<^bold>|r\<^bold>| < \<^bold>|u\<^bold>|"
   by (metis root_def leI take_all take_root pow_zero)
 
 lemma root_shorter_eq: "u \<noteq> \<epsilon> \<Longrightarrow> u \<in> r* \<Longrightarrow> \<^bold>|r\<^bold>| \<le> \<^bold>|u\<^bold>|"
-  using root_shorter by fastforce
+  using root_shorter le_eq_less_or_eq by auto 
 
 lemma root_trans[trans]: "\<lbrakk>v \<in> u*; u \<in> t*\<rbrakk> \<Longrightarrow> v \<in> t*"
-  by (metis root_def pow_mult_list)
+  by (metis root_def pow_mult)
 
 lemma root_pow_root[trans]: "v \<in> u* \<Longrightarrow> v\<^sup>@n \<in> u*"
   using rootI root_trans by blast
 
 lemma root_len: "u \<in> q* \<Longrightarrow> \<exists>k. \<^bold>|u\<^bold>| = k*\<^bold>|q\<^bold>|"
   unfolding root_def using pow_len by auto
 
 lemma root_len_dvd: "u \<in> t* \<Longrightarrow> \<^bold>|t\<^bold>| dvd \<^bold>|u\<^bold>|"
   using root_len root_def by fastforce
 
 lemma common_root_len_gcd: "u \<in> t* \<Longrightarrow> v \<in> t* \<Longrightarrow> \<^bold>|t\<^bold>| dvd ( gcd \<^bold>|u\<^bold>| \<^bold>|v\<^bold>| )"
   by (simp add: root_len_dvd)
 
 lemma add_root[simp]: "z \<cdot> w \<in> z* \<longleftrightarrow> w \<in> z*"
 proof
   assume "w \<in> z*" thus "z \<cdot> w \<in> z*"
-    unfolding root_def using pow_Suc_list by blast
+    unfolding root_def using pow_Suc by blast
 next
   assume "z \<cdot> w \<in> z*" thus "w \<in> z*"
     unfolding root_def
-    using root_pref_cancel[of z 1 w, unfolded power_one_right] by metis
-qed
-
-lemma add_roots: "w \<in> z* \<Longrightarrow> w' \<in> z* \<Longrightarrow> w \<cdot> w' \<in> z*"
-  unfolding root_def using pow_add_list by blast
+    using exp_pref_cancel[of z 1 w, unfolded power_one_right] by metis
+qed
+
+lemma add_roots[intro]: "w \<in> z* \<Longrightarrow> w' \<in> z* \<Longrightarrow> w \<cdot> w' \<in> z*"
+  unfolding root_def using add_exps by blast
 
 lemma concat_sing_list_pow: "ws \<in> lists {u} \<Longrightarrow> \<^bold>|ws\<^bold>| = k \<Longrightarrow> concat ws = u\<^sup>@k"
 proof(induct k arbitrary: ws)
   case (Suc k)
   have "ws \<noteq> \<epsilon>"
     using  list.size(3) nat.distinct(2)[of k, folded \<open>\<^bold>|ws\<^bold>| = Suc k\<close>] by blast
   from hd_Cons_tl[OF this]
   have "ws = hd ws # tl ws"  and "\<^bold>|tl ws\<^bold>| = k"
     using \<open> \<^bold>|ws\<^bold>| = Suc k\<close> by simp+
   then show ?case
-    unfolding  pow_Suc_list hd_concat_tl[OF \<open>ws \<noteq> \<epsilon>\<close>, symmetric]
-    using Suc.hyps[OF tl_lists[OF \<open> ws \<in> lists {u}\<close>] \<open>\<^bold>|tl ws\<^bold>| = k\<close>]
-          Nitpick.size_list_simp(2) lists_hd[of "ws" "{u}"] \<open>ws \<in> lists{u}\<close> by blast
+    unfolding  pow_Suc hd_concat_tl[OF \<open>ws \<noteq> \<epsilon>\<close>, symmetric]
+    using Suc.hyps[OF tl_in_lists[OF \<open> ws \<in> lists {u}\<close>] \<open>\<^bold>|tl ws\<^bold>| = k\<close>]
+      Nitpick.size_list_simp(2) lists_hd_in_set[of "ws" "{u}"] \<open>ws \<in> lists{u}\<close> by blast
 qed simp
 
 lemma concat_sing_list_pow': "ws \<in> lists{u} \<Longrightarrow> concat ws = u\<^sup>@\<^bold>|ws\<^bold>|"
   by (simp add: concat_sing_list_pow)
 
-lemma root_pref_cancel': assumes "x\<cdot>y \<in> t*" and  "x \<in> t*" shows "y \<in> t*"
+lemma root_pref_cancel: assumes "x\<cdot>y \<in> t*" and  "x \<in> t*" shows "y \<in> t*"
 proof-
   obtain n m where "t\<^sup>@m = x \<cdot> y" and "t\<^sup>@n = x"
-  using \<open>x\<cdot>y \<in> t*\<close>[unfolded root_def] \<open>x \<in> t*\<close>[unfolded root_def] by blast
-  from root_pref_cancel[of t n y m, unfolded this]
+    using \<open>x\<cdot>y \<in> t*\<close>[unfolded root_def] \<open>x \<in> t*\<close>[unfolded root_def] by blast
+  from exp_pref_cancel[of t n y m, unfolded this]
   show "y \<in> t*"
     using rootI by auto
 qed
 
-lemma root_rev_iff[reversal_rule]: "rev u \<in> rev t* \<longleftrightarrow> u \<in> t*"
-  unfolding root_def[reversed] using root_def..
+lemma root_suf_cancel: "v \<in> r* \<Longrightarrow> u \<cdot> v \<in> r* \<Longrightarrow> u \<in> r*"
+  using exp_suf_cancel[of u r] unfolding root_def by metis
 
 section Commutation
 
 text\<open>The solution of the easiest nontrivial word equation, @{term "x \<cdot> y = y \<cdot> x"}, is in fact already contained in List.thy as the fact @{thm comm_append_are_replicate[no_vars]}.\<close>
 
-theorem comm:  "x \<cdot> y = y \<cdot> x  \<longleftrightarrow>  (\<exists> t m k. x = t\<^sup>@k \<and> y = t\<^sup>@m)"
- using  comm_append_are_replicate[of x y, folded pow_is_concat_replicate] pow_comm by auto
+theorem comm:  "x \<cdot> y = y \<cdot> x  \<longleftrightarrow>  (\<exists> t k m. x = t\<^sup>@k \<and> y = t\<^sup>@m)"
+  using  comm_append_are_replicate[of x y, folded pow_is_concat_replicate] pows_comm by auto
 
 corollary comm_root:  "x \<cdot> y = y \<cdot> x   \<longleftrightarrow>  (\<exists> t. x \<in> t* \<and> y \<in> t*)"
   unfolding root_def comm by fast
 
-lemma commD[elim]:  "x \<in> t* \<Longrightarrow> y \<in> t* \<Longrightarrow> x \<cdot> y = y \<cdot> x"
-  using comm_root by auto
+lemma comm_rootI:  "x \<in> t* \<Longrightarrow> y \<in> t* \<Longrightarrow> x \<cdot> y = y \<cdot> x"
+  using comm_root  by blast
 
 lemma commE[elim]: assumes  "x \<cdot> y = y \<cdot> x"
   obtains  t m k where "x = t\<^sup>@k" and "y = t\<^sup>@m"
   using assms[unfolded comm] by blast
 
-lemma comm_rootE: assumes  "x \<cdot> y = y \<cdot> x"
-  obtains  t where "x \<in>  t*" and "y \<in> t*"
-    using assms[unfolded comm_root] by blast
+lemma comm_nemp_eqE: assumes "u \<cdot> v = v \<cdot> u" "u \<noteq> \<epsilon>" "v \<noteq> \<epsilon>"
+  obtains k m where  "u\<^sup>@Suc k = v\<^sup>@Suc m"
+proof-
+  from commE[OF \<open>u \<cdot> v = v \<cdot> u\<close>]
+  obtain t m' k' where "u = t\<^sup>@k'" and "v = t\<^sup>@m'".
+  from nemp_pow_SucE[OF \<open>u \<noteq> \<epsilon>\<close> this(1)] nemp_pow_SucE[OF \<open>v \<noteq> \<epsilon>\<close> this(2)]
+  obtain k'' m'' where "u = t\<^sup>@Suc k''" and "v = t\<^sup>@Suc m''" by metis
+  have "u\<^sup>@Suc m'' = v\<^sup>@Suc k''"
+    unfolding \<open>u = t\<^sup>@Suc k''\<close> \<open>v = t\<^sup>@Suc m''\<close> pow_mult[symmetric]
+    by (simp add: mult.commute) 
+  thus thesis
+     using that by blast
+qed
+
+lemma comm_prod[intro]: assumes "r\<cdot>u = u\<cdot>r" and "r\<cdot>v = v\<cdot>r"
+  shows "r\<cdot>(u\<cdot>v) = (u\<cdot>v)\<cdot>r"
+  using rassoc assms by metis
 
 section \<open>Periods\<close>
 
 text\<open>Periodicity is probably the most studied property of words. It captures the fact that a word overlaps with itself.
 Another possible point of view is that the periodic word is a prefix of an (infinite) power of some nonempty
 word, which can be called its period word. Both these points of view are expressed by the following definition.
 \<close>
 
 subsection "Periodic root"
 
 definition period_root :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" ("_ \<le>p _\<^sup>\<omega>" [51,51] 60 )
   where [simp]: "period_root u r = (u \<le>p r \<cdot> u \<and> r \<noteq> \<epsilon>)"
 
 lemma per_rootI[simp,intro]: "u \<le>p r \<cdot> u \<Longrightarrow> r \<noteq> \<epsilon> \<Longrightarrow> u \<le>p r\<^sup>\<omega>"
- by simp
+  by simp
 
 lemma per_rootI': assumes "u \<le>p r\<^sup>@k" and  "r \<noteq> \<epsilon>" shows  "u \<le>p r\<^sup>\<omega>"
   using per_rootI[OF  pref_prod_pref[OF pref_pow_ext'[OF \<open>u \<le>p r\<^sup>@k\<close>] \<open>u \<le>p r\<^sup>@k\<close>] \<open>r\<noteq>\<epsilon>\<close>].
 
-lemma per_rootD[elim]: "u \<le>p r\<^sup>\<omega> \<Longrightarrow> u \<le>p r \<cdot> u"
+lemma per_rootD[dest]: "u \<le>p r\<^sup>\<omega> \<Longrightarrow> u \<le>p r \<cdot> u"
   by simp
 
-lemma per_rootD': "u \<le>p r\<^sup>\<omega> \<Longrightarrow> r \<noteq> \<epsilon>"
+lemma per_rootD'[dest]: "u \<le>p r\<^sup>\<omega> \<Longrightarrow> r \<noteq> \<epsilon>"
   by simp
 
 text \<open>Empty word is not a periodic root but it has all nonempty periodic roots.\<close>
 
 lemma emp_any_per: "r \<noteq> \<epsilon> \<Longrightarrow> (\<epsilon> \<le>p r\<^sup>\<omega> )"
   by simp
 
 lemma emp_not_per: "\<not> (x \<le>p \<epsilon>\<^sup>\<omega>)"
   by simp
 
 text \<open>Any nonempty word is its own periodic root.\<close>
 
 lemma root_self: "w \<noteq> \<epsilon> \<Longrightarrow> w \<le>p w\<^sup>\<omega>"
   by simp
 
 text\<open>"Short roots are prefixes"\<close>
 
-lemma root_is_take: "w \<le>p r\<^sup>\<omega> \<Longrightarrow> \<^bold>|r\<^bold>| \<le> \<^bold>|w\<^bold>| \<Longrightarrow>  r \<le>p w"
-  unfolding period_root_def using pref_prod_long[of w r w] by fastforce
+lemma "w \<le>p r\<^sup>\<omega> \<Longrightarrow> \<^bold>|r\<^bold>| \<le> \<^bold>|w\<^bold>| \<Longrightarrow>  r \<le>p w"
+  using pref_prod_long[OF per_rootD].
 
 text \<open>Periodic words are prefixes of the power of the root, which motivates the notation\<close>
 
 lemma pref_pow_ext_take: assumes "u \<le>p r\<^sup>@k" shows "u \<le>p take \<^bold>|r\<^bold>| u \<cdot> r\<^sup>@k"
 proof (rule le_cases[of "\<^bold>|u\<^bold>|" "\<^bold>|r\<^bold>|"])
   assume "\<^bold>|r\<^bold>| \<le> \<^bold>|u\<^bold>|"
   show "u \<le>p take \<^bold>|r\<^bold>| u \<cdot> r \<^sup>@ k"
     unfolding pref_take[OF pref_prod_long[OF pref_pow_ext'[OF \<open>u \<le>p r\<^sup>@k\<close>] \<open>\<^bold>|r\<^bold>| \<le> \<^bold>|u\<^bold>|\<close>]]  using pref_pow_ext'[OF \<open>u \<le>p r\<^sup>@k\<close>].
 qed simp
 
 lemma pref_pow_take: assumes "u \<le>p r\<^sup>@k" shows "u \<le>p take \<^bold>|r\<^bold>| u \<cdot> u"
   using pref_prod_pref[of u "take \<^bold>|r\<^bold>| u" "r\<^sup>@k", OF pref_pow_ext_take \<open>u \<le>p r\<^sup>@k\<close>, OF \<open>u \<le>p r\<^sup>@k\<close>].
 
-lemma per_exp: assumes "u \<le>p r\<^sup>\<omega>" shows "u \<le>p r\<^sup>@k \<cdot> u"
-  using  per_exp_pref[OF per_rootD[OF assms]].
+lemma per_exp: "u \<le>p r\<^sup>\<omega> \<Longrightarrow> u \<le>p r\<^sup>@k \<cdot> u"
+  using  per_exp_pref[OF per_rootD].
 
 lemma per_root_spref_powE: assumes "u \<le>p r\<^sup>\<omega>"
   obtains k where "u <p r\<^sup>@k"
-  using pref_prod_short'[OF per_exp[OF assms, of "Suc \<^bold>|u\<^bold>|"] long_power'[of r u, OF per_rootD'[OF assms]]] by blast
+  using pref_prod_less[OF per_exp[OF assms, of "Suc \<^bold>|u\<^bold>|"] long_power'[of r u, OF per_rootD'[OF assms]]] by blast
 
 lemma period_rootE [elim]: assumes "u \<le>p t\<^sup>\<omega>" obtains n r where "r <p t" and "t\<^sup>@n \<cdot> r = u"
 proof-
-  obtain m where "u <p t\<^sup>@m" using \<open>u \<le>p t\<^sup>\<omega>\<close>
-    using per_root_spref_powE by blast
-  from pref_mod_power[OF this that, of "\<lambda> x y. y" "\<lambda> x y. x"]
-  show ?thesis by blast
+  obtain m where "u <p t\<^sup>@m"
+    using per_root_spref_powE[OF \<open>u \<le>p t\<^sup>\<omega>\<close>].
+  from pref_mod_power[OF this that]
+  show ?thesis.
 qed
 
 lemma per_add_exp: assumes "u \<le>p r\<^sup>\<omega>" and "m \<noteq> 0" shows "u \<le>p (r\<^sup>@m)\<^sup>\<omega>"
-  using per_exp_pref[OF per_rootD, OF \<open>u \<le>p r\<^sup>\<omega>\<close>, of m]  per_rootD'[OF \<open>u \<le>p r\<^sup>\<omega>\<close>, folded nonzero_pow_emp[OF \<open>m \<noteq> 0\<close>, of r]]
-  unfolding period_root_def..
+  using per_exp_pref[OF per_rootD, OF \<open>u \<le>p r\<^sup>\<omega>\<close>] per_rootD'[OF \<open>u \<le>p r\<^sup>\<omega>\<close>, folded nonzero_pow_emp[OF \<open>m \<noteq> 0\<close>, of r]]
+  ..
 
 lemma per_pref_ex: assumes "u \<le>p r\<^sup>\<omega>"
   obtains n where "u \<le>p r\<^sup>@n" and "n \<noteq> 0"
-  using pcomp_shorter[OF ruler_pref[OF per_exp[OF \<open>u \<le>p r\<^sup>\<omega>\<close>]]] long_pow_ex[of r "\<^bold>|u\<^bold>|", OF per_rootD'[OF \<open>u \<le>p r\<^sup>\<omega>\<close>], of thesis]
+  using comp_shorter ruler_pref''[OF per_exp[OF \<open>u \<le>p r\<^sup>\<omega>\<close>]] long_pow_ex[of r "\<^bold>|u\<^bold>|", OF per_rootD'[OF \<open>u \<le>p r\<^sup>\<omega>\<close>], of thesis]
   by blast
 
+lemma root_ruler: assumes "w \<le>p u\<cdot>w" "v \<le>p u\<cdot>v" "u \<noteq> \<epsilon>" 
+  shows "w \<bowtie> v"
+proof-
+  obtain k l where "w \<le>p u\<^sup>@k" "v \<le>p u\<^sup>@l"
+    using assms per_pref_ex[unfolded period_root_def] by metis
+  moreover have "u\<^sup>@k \<bowtie> u\<^sup>@l"
+    by (metis conjug_pow eqd_comp)
+  ultimately show ?thesis
+    by (meson ruler_comp)
+qed
+
+lemmas same_len_nemp_root_eq = root_ruler[THEN pref_comp_eq]
+
 theorem per_pref: "x \<le>p r\<^sup>\<omega> \<longleftrightarrow> (\<exists> k. x \<le>p r\<^sup>@k) \<and> r \<noteq> \<epsilon>"
   using per_pref_ex period_root_def pref_pow_ext' pref_prod_pref by metis
 
+lemma per_prefE: assumes "x \<le>p r \<cdot> x" and "r \<noteq> \<epsilon>" 
+  obtains k where  "x \<le>p r\<^sup>@k"
+  using assms per_pref per_rootI by metis
+
+lemma per_root_fac: assumes "w \<le>p r \<cdot> w" and "r \<noteq> \<epsilon>" obtains k where  "w \<le>f r\<^sup>@k"
+  using per_prefE[OF _ _ pref_fac[elim_format], OF assms].
+
 lemma pref_pow_conv: "(\<exists> k. x \<le>p r\<^sup>@k) \<longleftrightarrow> (\<exists> k z. r\<^sup>@k\<cdot>z = x \<and> z \<le>p r)"
 proof
   assume "\<exists>k z. r \<^sup>@ k \<cdot> z = x \<and> z \<le>p r"
   then obtain k z where "r\<^sup>@k \<cdot> z = x" and "z \<le>p r" by blast
   thus "\<exists> k. x \<le>p r\<^sup>@k"
-    using pref_cancel'[OF \<open>z \<le>p r\<close>, of "r\<^sup>@k", unfolded \<open>r\<^sup>@k \<cdot> z = x\<close>, folded pow_Suc2_list] by fast
+    using pref_cancel'[OF \<open>z \<le>p r\<close>, of "r\<^sup>@k", unfolded \<open>r\<^sup>@k \<cdot> z = x\<close>, folded pow_Suc2] by fast
 next
   assume "\<exists> k. x \<le>p r\<^sup>@k" then obtain k where "x \<le>p r\<^sup>@k" by blast
   {assume "r = \<epsilon>"
     have "x = \<epsilon>"
       using pref_emp[OF \<open>x \<le>p r \<^sup>@ k\<close>[unfolded \<open>r = \<epsilon>\<close> emp_pow]].
     hence "\<exists> k z. r\<^sup>@k\<cdot>z = x \<and> z \<le>p r"
       using \<open>r = \<epsilon>\<close> emp_pow by auto}
   moreover
   {assume "r \<noteq> \<epsilon>"  have "x <p r\<^sup>@(Suc k)"
-      using pref_ext_nemp[OF \<open>x \<le>p r\<^sup>@k\<close> \<open>r \<noteq> \<epsilon>\<close>, folded pow_Suc2_list].
+      using pref_ext_nemp[OF \<open>x \<le>p r\<^sup>@k\<close> \<open>r \<noteq> \<epsilon>\<close>, folded pow_Suc2].
     then have "\<exists> k z. r\<^sup>@k\<cdot>z = x \<and> z \<le>p r"
-      using pref_mod_power[OF pref_ext_nemp[OF \<open>x \<le>p r\<^sup>@k\<close> \<open>r \<noteq> \<epsilon>\<close>, folded pow_Suc2_list], of "\<exists> k z. r\<^sup>@k\<cdot>z = x \<and> z \<le>p r"]
+      using pref_mod_power[OF pref_ext_nemp[OF \<open>x \<le>p r\<^sup>@k\<close> \<open>r \<noteq> \<epsilon>\<close>, folded pow_Suc2], of "\<exists> k z. r\<^sup>@k\<cdot>z = x \<and> z \<le>p r"]
       by auto}
   ultimately show "\<exists> k z. r\<^sup>@k\<cdot>z = x \<and> z \<le>p r" by blast
 qed
 
+lemma per_root_eq: assumes "w \<le>p r \<cdot> w" and "r \<noteq> \<epsilon>"
+  obtains p s m where "r = (p \<cdot> s)" and "w = (p \<cdot> s)\<^sup>@m \<cdot> p" 
+  using conjI[OF assms, unfolded per_pref[unfolded pref_pow_conv period_root_def]] prefD by metis  
+
+lemma per_root_eq': assumes "w \<le>p r \<cdot> w" and "r \<noteq> \<epsilon>"
+  obtains p s m where "r = p \<cdot> s" and "w = p \<cdot> (s \<cdot> p)\<^sup>@m"
+proof-
+  obtain p s m where "r = p \<cdot> s" and "w = (p \<cdot> s)\<^sup>@m \<cdot> p"
+    using per_root_eq[OF \<open>w \<le>p r \<cdot> w\<close> \<open>r \<noteq> \<epsilon>\<close>].
+  from that[OF this[unfolded shift_pow]]
+  show thesis.
+qed
+
 lemma per_eq: "x \<le>p r\<^sup>\<omega> \<longleftrightarrow> (\<exists> k z. r\<^sup>@k\<cdot>z = x \<and> z \<le>p r) \<and> r \<noteq> \<epsilon>"
   using per_pref[unfolded pref_pow_conv].
 
 text\<open>The previous theorem allows to prove some basic relations between powers, periods and commutation\<close>
 
 lemma per_drop_exp: "u \<le>p (r\<^sup>@m)\<^sup>\<omega>  \<Longrightarrow> u \<le>p r\<^sup>\<omega>"
-  using per_pref[of u "r\<^sup>@m"] pow_mult_list[of r m, symmetric] unfolding per_pref[of u r]
-  using nemp_pow'[of r m] by auto
-
-lemma per_drop_exp': "i \<noteq> 0 \<Longrightarrow> p \<le>p e\<^sup>@i \<cdot> p \<Longrightarrow>  p \<le>p  e \<cdot> p"
-  by (metis period_root_def eq_pow_exp per_drop_exp pow_zero)
-
-lemma per_drop_exp_rev: assumes "i \<noteq> 0" "p \<le>s p \<cdot> e\<^sup>@i" shows "p \<le>s p \<cdot> e"
-  using per_drop_exp'[OF \<open>i \<noteq> 0\<close> \<open>p \<le>s p \<cdot> e\<^sup>@i\<close>[unfolded suffix_to_prefix rev_append rev_pow], folded rev_append suffix_to_prefix].
-
-corollary comm_drop_exp: assumes "m \<noteq> 0" and "u \<cdot> r\<^sup>@m = r\<^sup>@m \<cdot> u" shows "r \<cdot> u = u \<cdot> r"
-proof-
-  {assume "r \<noteq> \<epsilon>" "u \<noteq> \<epsilon>"
-    hence "u\<cdot>r \<le>p u\<cdot>r\<^sup>@m" using pop_pow_one \<open>m \<noteq> 0\<close>
-      by (simp add: pop_pow_one)
-    have "u\<cdot>r \<le>p r\<^sup>@m\<cdot>(u\<cdot>r)"
-      using pref_ext[of "u \<cdot> r" "r\<^sup>@m \<cdot> u" r, unfolded append_assoc[of "r\<^sup>@m" u r], OF  \<open>u\<cdot>r \<le>p u\<cdot>r\<^sup>@m\<close>[unfolded \<open>u \<cdot> r\<^sup>@m = r\<^sup>@m \<cdot> u\<close>]].
+  unfolding per_pref[of u r] per_pref[of u "r\<^sup>@m"] pow_mult[symmetric] using nemp_pow_nemp
+  by blast
+
+lemma pref_drop_exp: assumes "x \<le>p z \<cdot> x\<^sup>@m" shows "x \<le>p z \<cdot> x"
+  using assms pow_comm pref_prod_pref pref_prolong triv_pref by metis
+
+lemma per_root_drop_exp: "x \<le>p r\<^sup>@(Suc k) \<cdot> x\<^sup>@m \<Longrightarrow>  x \<le>p  r \<cdot> x"
+  using pref_drop_exp per_drop_exp Zero_not_Suc period_root_def power.power_eq_if pref_nemp by metis 
+
+lemma per_drop_exp': assumes "k \<noteq> 0" and "x \<le>p r\<^sup>@k \<cdot> x" shows  "x \<le>p  r \<cdot> x"
+  using per_root_drop_exp[of _ _ "k-1" 1, unfolded pow_one' Suc_minus[OF \<open>k \<noteq> 0\<close>], OF assms(2)]. 
+
+lemmas per_drop_exp_rev = per_drop_exp'[reversed]
+
+
+corollary comm_drop_exp: assumes "m \<noteq> 0" and "u \<cdot> r\<^sup>@m = r\<^sup>@m' \<cdot> u" shows "r \<cdot> u = u \<cdot> r"
+proof
+  assume "r \<noteq> \<epsilon>" "u \<noteq> \<epsilon>"
+  hence "m = m'"
+    using lenarg[OF \<open>u \<cdot> r\<^sup>@m = r\<^sup>@m' \<cdot> u\<close>] unfolding lenmorph pow_len
+    by auto
+  have "u\<cdot>r \<le>p u\<cdot>r\<^sup>@m"
+    unfolding pop_pow_one[OF \<open>m \<noteq> 0\<close>] by simp
+    have "u\<cdot>r \<le>p r\<^sup>@m' \<cdot> u \<cdot> r"
+      using pref_ext[of "u \<cdot> r" "r\<^sup>@m \<cdot> u" r, unfolded rassoc \<open>m = m'\<close>, OF  \<open>u\<cdot>r \<le>p u\<cdot>r\<^sup>@m\<close>[unfolded \<open>u \<cdot> r\<^sup>@m = r\<^sup>@m' \<cdot> u\<close>]].
     hence "u\<cdot>r \<le>p r\<cdot>(u\<cdot>r)"
-      using per_drop_exp[of "u\<cdot>r" r m] \<open>m \<noteq> 0\<close> per_drop_exp' by blast
+      using per_drop_exp[of "u\<cdot>r" r m'] \<open>m \<noteq> 0\<close>[unfolded \<open>m = m'\<close>] per_drop_exp' by blast
     from comm_ruler[OF self_pref[of "r \<cdot> u"], of "r \<cdot> u \<cdot> r", OF this]
-    have "r \<cdot> u = u \<cdot> r" by auto
-  }
-  thus "r \<cdot> u = u \<cdot> r"
-    by fastforce
-qed
+    show "r \<cdot> u = u \<cdot> r" by auto
+qed
+
+lemma comm_drop_exp': "u\<^sup>@Suc k \<cdot> v = v \<cdot> u\<^sup>@Suc k' \<Longrightarrow> u \<cdot> v = v \<cdot> u"
+  using  comm_drop_exp[OF nat.discI] by metis 
+
+lemma comm_drop_exps[elim]: assumes "u\<^sup>@Suc m \<cdot> v\<^sup>@Suc k = v\<^sup>@Suc k \<cdot> u\<^sup>@Suc m" shows "u \<cdot> v = v \<cdot> u"
+  using comm_drop_exp'[OF comm_drop_exp'[OF assms, symmetric], symmetric].
+
+lemma comm_drop_exps_conv: "u\<^sup>@Suc m \<cdot> v\<^sup>@Suc k = v\<^sup>@Suc k \<cdot> u\<^sup>@Suc m \<longleftrightarrow> u \<cdot> v = v \<cdot> u"
+  by (meson comm_add_exps comm_drop_exps)
 
 corollary pow_comm_comm: assumes "x\<^sup>@j = y\<^sup>@k" and "j \<noteq> 0" shows "x\<cdot>y = y\<cdot>x"
-proof(cases "k = 0")
-  assume "k = 0"
-  from \<open>x\<^sup>@j = y\<^sup>@k\<close>[unfolded zero_exp[OF this, of y], unfolded  nonzero_pow_emp[OF \<open>j \<noteq> 0\<close>]]
-  show "x \<cdot> y = y \<cdot> x" by simp
-next
-  assume "k \<noteq> 0" show "x \<cdot> y = y \<cdot> x"
-    using comm_drop_exp[of j y x, OF \<open>j \<noteq> 0\<close>, OF
-        comm_drop_exp[of k "x\<^sup>@j" y, OF \<open>k \<noteq> 0\<close> , unfolded \<open>x\<^sup>@j = y\<^sup>@k\<close>, OF refl, folded \<open>x\<^sup>@j = y\<^sup>@k\<close>]].
-qed
+  using  comm_drop_exp[OF \<open>j \<noteq> 0\<close>, of y x j, unfolded \<open>x\<^sup>@j = y\<^sup>@k\<close>, OF power_commutes[symmetric]].
 
 corollary comm_pow_roots: assumes "m \<noteq> 0" "k \<noteq> 0"
   shows "u\<^sup>@m \<cdot> v\<^sup>@k = v\<^sup>@k \<cdot> u\<^sup>@m \<longleftrightarrow> u \<cdot> v = v \<cdot> u"
   using comm_drop_exp[OF \<open>k \<noteq> 0\<close>, of "u\<^sup>@m" v, THEN comm_drop_exp[OF \<open>m \<noteq> 0\<close>, of v u]]
-        comm_add_exps[of u v m k] by blast
+    comm_add_exps[of u v m k] by blast
 
 lemma pow_comm_comm': assumes comm: "u\<^sup>@(Suc k) = v\<^sup>@(Suc l)" shows "u \<cdot> v = v \<cdot> u"
   using comm pow_comm_comm by blast
 
 lemma comm_trans: assumes uv: "u\<cdot>v =  v\<cdot>u" and vw: "w\<cdot>v = v\<cdot>w" and nemp: "v \<noteq> \<epsilon>" shows "u \<cdot> w = w \<cdot> u"
 proof -
   consider (u_emp) "u = \<epsilon>" | (w_emp) "w = \<epsilon>" | (nemp') "u \<noteq> \<epsilon>" and "w \<noteq> \<epsilon>" by blast
   then show ?thesis proof (cases)
     case nemp'
-      have eq: "u\<^sup>@(\<^bold>|v\<^bold>| * \<^bold>|w\<^bold>|) = w\<^sup>@(\<^bold>|v\<^bold>| * \<^bold>|u\<^bold>|)"
-        unfolding power_mult comm_common_power[OF uv] comm_common_power[OF vw]
-        unfolding pow_mult_list[symmetric] mult.commute[of "\<^bold>|u\<^bold>|"]..
-      obtain k l where k: "\<^bold>|v\<^bold>| * \<^bold>|w\<^bold>| = Suc k" and l: "\<^bold>|v\<^bold>| * \<^bold>|u\<^bold>| = Suc l"
-        using nemp nemp' unfolding length_0_conv[symmetric]
-        using not0_implies_Suc[OF no_zero_divisors]
-        by presburger
-      show ?thesis
-        using pow_comm_comm'[OF eq[unfolded k l]].
+    have eq: "u\<^sup>@(\<^bold>|v\<^bold>| * \<^bold>|w\<^bold>|) = w\<^sup>@(\<^bold>|v\<^bold>| * \<^bold>|u\<^bold>|)"
+      unfolding power_mult comm_common_power[OF uv] comm_common_power[OF vw]
+      unfolding pow_mult[symmetric] mult.commute[of "\<^bold>|u\<^bold>|"]..
+    obtain k l where k: "\<^bold>|v\<^bold>| * \<^bold>|w\<^bold>| = Suc k" and l: "\<^bold>|v\<^bold>| * \<^bold>|u\<^bold>| = Suc l"
+      using nemp nemp' unfolding length_0_conv[symmetric]
+      using not0_implies_Suc[OF no_zero_divisors]
+      by presburger
+    show ?thesis
+      using pow_comm_comm'[OF eq[unfolded k l]].
   qed simp+
 qed
 
+lemma root_comm_root: assumes "x \<le>p u \<cdot> x" and "v \<cdot> u = u \<cdot> v" and "u \<noteq> \<epsilon>"
+  shows "x \<le>p v \<cdot> x"
+  using per_rootI[OF \<open>x \<le>p u\<cdot>x\<close> \<open>u \<noteq> \<epsilon>\<close>] per_exp  commE[OF \<open>v \<cdot> u = u \<cdot> v\<close>] per_drop_exp by metis
+
 theorem per_all_exps: "\<lbrakk> m \<noteq> 0; k \<noteq> 0 \<rbrakk> \<Longrightarrow> (u \<le>p (r\<^sup>@m)\<^sup>\<omega>) \<longleftrightarrow> (u \<le>p (r\<^sup>@k)\<^sup>\<omega>)"
   using per_drop_exp[of u r m, THEN per_add_exp[of u r k]] per_drop_exp[of u r k, THEN per_add_exp[of u r m]] by blast
 
 lemma drop_per_pref: assumes "w \<le>p u\<^sup>\<omega>" shows "drop \<^bold>|u\<^bold>| w \<le>p w"
   using pref_drop[OF per_rootD[OF \<open>w \<le>p u\<^sup>\<omega>\<close>], of "\<^bold>|u\<^bold>|", unfolded drop_pref[of u w]].
 
-lemma per_root_trans[trans]: "w \<le>p u\<^sup>\<omega> \<Longrightarrow> u \<in> t* \<Longrightarrow> w \<le>p t\<^sup>\<omega>"
+lemma per_root_trans[intro]: "w \<le>p u\<^sup>\<omega> \<Longrightarrow> u \<in> t* \<Longrightarrow> w \<le>p t\<^sup>\<omega>"
   using root_def[of u t] per_drop_exp[of w t] by blast
 
+lemma per_root_trans'[intro]: "w \<le>p u \<cdot> w \<Longrightarrow> u \<in> r* \<Longrightarrow> u \<noteq> \<epsilon> \<Longrightarrow> w \<le>p r \<cdot> w"
+  using per_root_trans per_rootD per_rootI by metis
+
+lemmas per_root_trans_suf'[intro] = per_root_trans'[reversed] 
+
 text\<open>Note that
 @{term "w \<le>p u\<^sup>\<omega> \<Longrightarrow> u \<le>p t\<^sup>\<omega> \<Longrightarrow> w \<le>p t\<^sup>\<omega>"}
 does not hold.
 \<close>
 
-lemma per_root_same_prefix:"w \<le>p r\<^sup>\<omega> \<Longrightarrow> w' \<le>p r\<^sup>\<omega> \<Longrightarrow>  w \<bowtie> w"
-  by blast
+lemma per_root_same_prefix:"w \<le>p r\<^sup>\<omega> \<Longrightarrow> w' \<le>p r\<^sup>\<omega> \<Longrightarrow>  w \<bowtie> w'"
+  using root_ruler by auto
 
 lemma take_after_drop:  "\<^bold>|u\<^bold>| + q \<le> \<^bold>|w\<^bold>| \<Longrightarrow> w \<le>p u\<^sup>\<omega> \<Longrightarrow> take q (drop \<^bold>|u\<^bold>| w) = take q w"
   using pref_share_take[OF drop_per_pref[of w u] len_after_drop[of "\<^bold>|u\<^bold>|" q w]].
 
 text\<open>The following lemmas are a weak version of the Periodicity lemma\<close>
 
-lemma two_pers':
+lemma two_pers:
   assumes pu: "w \<le>p u \<cdot> w" and pv: "w \<le>p v \<cdot> w" and len: "\<^bold>|u\<^bold>| + \<^bold>|v\<^bold>| \<le> \<^bold>|w\<^bold>|"
   shows "u \<cdot> v = v \<cdot> u"
 proof-
   have uv: "w \<le>p (u \<cdot> v) \<cdot> w" using pref_prolong[OF pu pv] unfolding lassoc.
   have vu: "w \<le>p (v \<cdot> u) \<cdot> w" using pref_prolong[OF pv pu] unfolding lassoc.
   have "u \<cdot> v \<le>p w" using len pref_prod_long[OF uv] by simp
   moreover have "v \<cdot> u \<le>p w" using len pref_prod_long[OF vu] by simp
   ultimately show "u \<cdot> v = v \<cdot> u" by (rule pref_comp_eq[unfolded prefix_comparable_def, OF ruler swap_len])
 qed
 
-lemma two_pers: assumes "w \<le>p u\<^sup>\<omega>" and  "w \<le>p v\<^sup>\<omega>" and "\<^bold>|u\<^bold>|+\<^bold>|v\<^bold>| \<le> \<^bold>|w\<^bold>|" shows "u\<cdot>v = v\<cdot>u"
-  using two_pers'[OF per_rootD[OF assms(1)] per_rootD[OF assms(2)] assms(3)].
+lemma two_pers_root: assumes "w \<le>p u\<^sup>\<omega>" and  "w \<le>p v\<^sup>\<omega>" and "\<^bold>|u\<^bold>|+\<^bold>|v\<^bold>| \<le> \<^bold>|w\<^bold>|" shows "u\<cdot>v = v\<cdot>u"
+  using two_pers[OF per_rootD[OF assms(1)] per_rootD[OF assms(2)] assms(3)].
+
+lemma split_pow: assumes "x \<cdot> y \<noteq> y \<cdot> x" and "x \<cdot> y = z\<^sup>@k"
+  obtains l m u v where "z\<^sup>@l \<cdot> u = x" and "v \<cdot> z\<^sup>@m = y" and "u \<cdot> v = z" and  "u \<cdot> v \<noteq> v \<cdot> u" and "k = Suc(l + m)" 
+  using assms
+proof (induct k arbitrary: x thesis,simp)
+  case (Suc k)
+  then show ?case  
+  proof-
+    show thesis
+    proof (rule disjE[OF le_less_linear[of "\<^bold>|x\<^bold>|" "\<^bold>|z\<^bold>|"]])
+      assume "\<^bold>|x\<^bold>| \<le> \<^bold>|z\<^bold>|"
+      then obtain v where "v \<cdot> z \<^sup>@ k = y" "x \<cdot> v = z"
+        using eqd[OF \<open>x \<cdot> y = z \<^sup>@ Suc k\<close>[unfolded pow_Suc]] by blast
+      hence "x \<cdot> v \<noteq> v \<cdot> x"
+        using \<open>x \<cdot> v = z\<close> \<open>x \<cdot> y \<noteq> y \<cdot> x\<close> shift_pow rassoc by metis  
+      from Suc.prems(1)[of 0, OF _ \<open>v \<cdot> z \<^sup>@ k = y\<close> \<open>x \<cdot> v = z\<close> this]
+      show thesis by auto
+    next
+      assume "\<^bold>|z\<^bold>| < \<^bold>|x\<^bold>|"
+      then obtain x' where "z \<cdot> x' = x" "x' \<cdot> y = z \<^sup>@ k"
+        using eqd[OF \<open>x \<cdot> y = z \<^sup>@ Suc k\<close>[symmetric, unfolded pow_Suc]] by auto
+      have "x' \<noteq> \<epsilon>"
+        using \<open>\<^bold>|z\<^bold>| < \<^bold>|x\<^bold>|\<close> \<open>z \<cdot> x' = x\<close> by force 
+      have "x' \<cdot> y \<noteq> y \<cdot> x'"
+      proof (rule notI)
+        assume "x' \<cdot> y = y \<cdot> x'"
+        hence "y \<cdot> z\<^sup>@k = z\<^sup>@k \<cdot> y" and "x' \<cdot> z\<^sup>@k = z\<^sup>@k \<cdot> x'"
+          using \<open>x' \<cdot> y = z \<^sup>@ k\<close> by force+
+        have "x \<cdot> z\<^sup>@k = z\<^sup>@k \<cdot> x" 
+          unfolding \<open>z \<cdot> x' = x\<close>[symmetric] rassoc \<open>x' \<cdot> z\<^sup>@k = z\<^sup>@k \<cdot> x'\<close>
+          unfolding lassoc cancel_right pow_comm..      
+        have "z\<^sup>@k \<noteq> \<epsilon>"
+          using \<open>x' \<cdot> y = z \<^sup>@ k\<close> \<open>x' \<noteq> \<epsilon>\<close> by fastforce 
+        show False 
+          using comm_trans[OF \<open>y \<cdot> z\<^sup>@k = z\<^sup>@k \<cdot> y\<close> \<open>x \<cdot> z\<^sup>@k = z\<^sup>@k \<cdot> x\<close> \<open>z\<^sup>@k \<noteq> \<epsilon>\<close>] \<open>x \<cdot> y \<noteq> y \<cdot> x\<close> by argo
+      qed
+      from Suc.hyps[OF _ this \<open>x' \<cdot> y = z \<^sup>@ k\<close>] 
+      obtain l u v m where "z \<^sup>@ l \<cdot> u = x'" "v \<cdot> z \<^sup>@ m = y" "u \<cdot> v = z" "u \<cdot> v \<noteq> v \<cdot> u" "k = Suc (l + m)".
+      from Suc.prems(1)[OF _ this(2-4), of "Suc l", folded \<open>z \<cdot> x' = x\<close>, unfolded pow_Suc rassoc cancel, OF this(1)]
+      show thesis
+        using \<open>k = Suc (l + m)\<close> by simp 
+    qed
+  qed
+qed
+
 
 subsection "Period - numeric"
 
 text\<open>Definition of a period as the length of the periodic root is often offered as the basic one. From our point of view,
 it is secondary, and less convenient for reasoning.\<close>
 
-definition periodN :: "'a list \<Rightarrow> nat \<Rightarrow> bool"
-  where [simp]: "periodN w n =  w \<le>p (take n w)\<^sup>\<omega>"
-
-lemma periodN_I: "w \<noteq> \<epsilon> \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> w \<le>p (take n w) \<cdot> w \<Longrightarrow> periodN w n"
-  unfolding periodN_def period_root_def by fastforce
+definition period :: "'a list \<Rightarrow> nat \<Rightarrow> bool"
+  where [simp]: "period w n =  w \<le>p (take n w)\<^sup>\<omega>"
+
+lemma period_I': "w \<noteq> \<epsilon> \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> w \<le>p (take n w) \<cdot> w \<Longrightarrow> period w n"
+  unfolding period_def period_root_def by fastforce
+
+lemma period_I[intro]: "w \<noteq> \<epsilon> \<Longrightarrow> r \<noteq> \<epsilon> \<Longrightarrow> w \<le>p r \<cdot> w \<Longrightarrow> period w \<^bold>|r\<^bold>|" 
+  using period_I'[of _ "\<^bold>|r\<^bold>|", OF _ nemp_len] per_prefE pref_pow_take by metis
 
 text\<open>The numeric definition respects the following convention about empty words and empty periods.\<close>
 
-lemma emp_no_periodN: "\<not> periodN \<epsilon> n"
-  by simp
-
-lemma zero_not_per: "\<not> periodN w 0"
+lemma emp_no_period: "\<not> period \<epsilon> n"
   by simp
 
-(* lemma periodN_I [intro]: assumes "u \<le>p r\<^sup>@k" and  "u \<noteq> \<epsilon>" shows  "periodN u \<^bold>|r\<^bold>|" *)
-  (* unfolding periodN_def period_root_def *)
-  (* using  pref_pow_take[OF \<open>u \<le>p r\<^sup>@k\<close>] take_nemp_len[OF \<open>u \<noteq> \<epsilon>\<close>] \<open>u \<le>p r\<^sup>@k\<close> by force *)
-
-(* lemma periodNI' [intro]: "u \<le>np r\<^sup>@k \<Longrightarrow> periodN u \<^bold>|r\<^bold>|" *)
-  (* unfolding nonempty_prefix_def by blast *)
-
-lemma periodN_D1: "periodN w n \<Longrightarrow>  w \<noteq> \<epsilon>"
+lemma zero_not_per: "\<not> period w 0"
   by simp
 
-lemma periodN_D2: "periodN w n \<Longrightarrow>  n \<noteq> 0"
+(* lemma period_I [intro]: assumes "u \<le>p r\<^sup>@k" and  "u \<noteq> \<epsilon>" shows  "period u \<^bold>|r\<^bold>|" *)
+(* unfolding period_def period_root_def *)
+(* using  pref_pow_take[OF \<open>u \<le>p r\<^sup>@k\<close>] take_nemp_len[OF \<open>u \<noteq> \<epsilon>\<close>] \<open>u \<le>p r\<^sup>@k\<close> by force *)
+
+(* lemma periodI' [intro]: "u \<le>np r\<^sup>@k \<Longrightarrow> period u \<^bold>|r\<^bold>|" *)
+(* unfolding nonempty_prefix_def by blast *)
+
+lemma period_D1: "period w n \<Longrightarrow>  w \<noteq> \<epsilon>"
   by simp
 
-lemma periodN_D3: "periodN w n \<Longrightarrow>  w \<le>p take n w \<cdot> w"
+lemma period_D2: "period w n \<Longrightarrow>  n \<noteq> 0"
+  by simp
+
+lemma period_D3: "period w n \<Longrightarrow>  w \<le>p take n w \<cdot> w"
   by simp
 
 text\<open>A nonempty word has all "long" periods\<close>
 
-lemma all_long_pers: "\<lbrakk> w \<noteq> \<epsilon>; \<^bold>|w\<^bold>| \<le> n \<rbrakk> \<Longrightarrow> periodN w n"
+lemma all_long_pers: "\<lbrakk> w \<noteq> \<epsilon>; \<^bold>|w\<^bold>| \<le> n \<rbrakk> \<Longrightarrow> period w n"
   by simp
 
-lemmas per_nemp = periodN_D1
-
-lemmas per_positive = periodN_D2
+lemma len_is_per: "w \<noteq> \<epsilon> \<Longrightarrow> period w \<^bold>|w\<^bold>|"
+  by simp
+
+lemmas per_nemp = period_D1
+
+lemmas per_positive = period_D2
 
 text\<open>The standard numeric definition of a period uses indeces.\<close>
 
-lemma periodN_indeces: assumes "periodN w n" and "i + n < \<^bold>|w\<^bold>|" shows "w!i = w!(i+n)"
+lemma period_indeces: assumes "period w n" and "i + n < \<^bold>|w\<^bold>|" shows "w!i = w!(i+n)"
 proof-
   have "w ! i = (take n w \<cdot> w) ! (n + i)"
     using nth_append_length_plus[of "take n w" w i, symmetric]
     unfolding take_len[OF less_imp_le[OF add_lessD2[OF \<open>i + n < \<^bold>|w\<^bold>|\<close>]]].
   also have "... = w ! (i + n)"
-    using pref_index[OF periodN_D3[OF \<open>periodN w n\<close>] \<open>i + n < \<^bold>|w\<^bold>|\<close>, symmetric] unfolding add.commute[of n i].
+    using pref_index[OF period_D3[OF \<open>period w n\<close>] \<open>i + n < \<^bold>|w\<^bold>|\<close>, symmetric] unfolding add.commute[of n i].
   finally show ?thesis.
 qed
 
-lemma indeces_periodN:
+lemma indeces_period:
   assumes  "w \<noteq> \<epsilon>" and "n \<noteq> 0" and  forall: "\<And> i. i + n < \<^bold>|w\<^bold>| \<Longrightarrow> w!i = w!(i+n)"
-  shows "periodN w n"
+  shows "period w n"
 proof-
   have "\<^bold>|w\<^bold>| \<le> \<^bold>|take n w \<cdot> w\<^bold>|"
     by auto
   {fix j assume "j < \<^bold>|w\<^bold>|"
     have "w ! j = (take n w \<cdot> w) ! j"
     proof (cases "j < \<^bold>|take n w\<^bold>|")
       assume "j < \<^bold>|take n w\<^bold>|" show "w ! j = (take n w \<cdot> w) ! j"
         using pref_index[OF take_is_prefix \<open>j < \<^bold>|take n w\<^bold>|\<close>, symmetric]
         unfolding pref_index[OF triv_pref \<open>j < \<^bold>|take n w\<^bold>|\<close>, of w].
     next
       assume "\<not> j < \<^bold>|take n w\<^bold>|"
       from leI[OF this] \<open>j < \<^bold>|w\<^bold>|\<close>
       have "\<^bold>|take n w\<^bold>| = n"
         by force
       hence "j = (j - n) + n" and "(j - n) + n < \<^bold>|w\<^bold>|"
         using  leI[OF \<open>\<not> j < \<^bold>|take n w\<^bold>|\<close>] \<open>j < \<^bold>|w\<^bold>|\<close> by simp+
       hence "w!j = w!(j - n)"
         using forall by simp
       from this[folded nth_append_length_plus[of "take n w" w "j-n", unfolded \<open>\<^bold>|take n w\<^bold>| = n\<close>]]
       show "w ! j = (take n w \<cdot> w) ! j"
         using \<open>j = (j - n) + n\<close> by simp
     qed}
   with index_pref[OF \<open>\<^bold>|w\<^bold>| \<le> \<^bold>|take n w \<cdot> w\<^bold>|\<close>]
   have "w \<le>p take n w \<cdot> w" by blast
   thus ?thesis
     using assms by force
 qed
 
 text\<open>In some cases, the numeric definition is more useful than the definition using the period root.\<close>
 
-lemma periodN_rev: assumes "periodN w p" shows "periodN (rev w) p"
-proof (rule indeces_periodN[of "rev w" p, OF _ periodN_D2[OF assms]])
+lemma period_rev: assumes "period w p" shows "period (rev w) p"
+proof (rule indeces_period[of "rev w" p, OF _ period_D2[OF assms]])
   show "rev w \<noteq> \<epsilon>"
-    using assms[unfolded periodN_def period_root_def] by force
+    using assms[unfolded period_def period_root_def] by force
 next
   fix i assume "i + p < \<^bold>|rev w\<^bold>|"
   from this[unfolded length_rev] add_lessD1
   have "i < \<^bold>|w\<^bold>|" and "i + p < \<^bold>|w\<^bold>|" by blast+
   have e: "\<^bold>|w\<^bold>| - Suc (i + p) + p = \<^bold>|w\<^bold>| - Suc i" using \<open>i + p < \<^bold>|rev w\<^bold>|\<close> by simp
-  have "\<^bold>|w\<^bold>| - Suc (i + p) + p < \<^bold>|w\<^bold>|"  using \<open>i + p < \<^bold>|w\<^bold>|\<close> by linarith
-  from periodN_indeces[OF assms this] rev_nth[OF \<open>i  < \<^bold>|w\<^bold>|\<close>, folded e] rev_nth[OF \<open>i + p < \<^bold>|w\<^bold>|\<close>]
+  have "\<^bold>|w\<^bold>| - Suc (i + p) + p < \<^bold>|w\<^bold>|"  
+    using \<open>i + p < \<^bold>|w\<^bold>|\<close> Suc_diff_Suc \<open>i < \<^bold>|w\<^bold>|\<close>
+      diff_less_Suc e less_irrefl_nat not_less_less_Suc_eq by metis 
+  from period_indeces[OF assms this] rev_nth[OF \<open>i  < \<^bold>|w\<^bold>|\<close>, folded e] rev_nth[OF \<open>i + p < \<^bold>|w\<^bold>|\<close>]
   show "rev w ! i = rev w !(i+p)" by presburger
 qed
 
-lemma periodN_rev_conv [reversal_rule]: "periodN (rev w) n \<longleftrightarrow> periodN w n"
-  using periodN_rev periodN_rev[of "rev w"] unfolding rev_rev_ident by (intro iffI)
-
-lemma periodN_fac: assumes "periodN (u\<cdot>w\<cdot>v) p" and "w \<noteq> \<epsilon>"
-  shows "periodN w p"
-proof (rule indeces_periodN, simp add: \<open>w \<noteq> \<epsilon>\<close>)
-  show "p \<noteq> 0" using periodN_D2[OF \<open>periodN (u\<cdot>w\<cdot>v) p\<close>].
+lemma period_rev_conv [reversal_rule]: "period (rev w) n \<longleftrightarrow> period w n"
+  using period_rev period_rev[of "rev w"] unfolding rev_rev_ident by (intro iffI)
+
+lemma period_fac: assumes "period (u\<cdot>w\<cdot>v) p" and "w \<noteq> \<epsilon>"
+  shows "period w p"
+proof (rule indeces_period, simp add: \<open>w \<noteq> \<epsilon>\<close>)
+  show "p \<noteq> 0" using period_D2[OF \<open>period (u\<cdot>w\<cdot>v) p\<close>].
   fix i assume "i + p < \<^bold>|w\<^bold>|"
   hence "\<^bold>|u\<^bold>| + i + p  < \<^bold>|u\<cdot>w\<cdot>v\<^bold>|"
     by simp
-  from periodN_indeces[OF \<open>periodN (u\<cdot>w\<cdot>v) p\<close> this]
+  from period_indeces[OF \<open>period (u\<cdot>w\<cdot>v) p\<close> this]
   have "(u\<cdot>w\<cdot>v)!(\<^bold>|u\<^bold>| + i) = (u\<cdot>w\<cdot>v)! (\<^bold>|u\<^bold>| + (i + p))"
     by (simp add: add.assoc)
   thus "w!i = w!(i+p)"
-    using nth_append_length_plus[of u "w\<cdot>v" , unfolded lassoc] \<open>i + p < \<^bold>|w\<^bold>|\<close> add_lessD1[OF \<open>i + p < \<^bold>|w\<^bold>|\<close>]
+    using nth_append_length_plus[of u "w\<cdot>v" i, unfolded lassoc] \<open>i + p < \<^bold>|w\<^bold>|\<close> add_lessD1[OF \<open>i + p < \<^bold>|w\<^bold>|\<close>]
       nth_append[of w v] by auto
 qed
 
-lemma periodN_fac': "periodN v p \<Longrightarrow> u \<le>f v \<Longrightarrow> u \<noteq> \<epsilon> \<Longrightarrow> periodN u p"
-  by (elim facE, hypsubst, rule periodN_fac)
+lemma period_fac': "period v p \<Longrightarrow> u \<le>f v \<Longrightarrow> u \<noteq> \<epsilon> \<Longrightarrow> period u p"
+  by (elim facE, hypsubst, rule period_fac)
 
 lemma assumes "y \<noteq> \<epsilon>" and "k \<noteq> 0" shows "y\<^sup>@k \<noteq> \<epsilon>"
-  by (simp add: assms(1) assms(2) nemp_emp_power)
-
-
-lemma pow_per: assumes "y \<noteq> \<epsilon>" and "k \<noteq> 0" shows "periodN (y\<^sup>@k) \<^bold>|y\<^bold>|"
-  using periodN_I[OF \<open>k \<noteq> 0\<close>[folded nemp_emp_power[OF \<open>y \<noteq> \<epsilon>\<close>]] nemp_len[OF \<open>y \<noteq> \<epsilon>\<close>]] pref_pow_ext_take by blast
-
-
-
-lemma per_fac: assumes "y \<noteq> \<epsilon>" and "v \<noteq> \<epsilon>" and "y\<^sup>@k = u\<cdot>v\<cdot>w" shows "periodN v \<^bold>|y\<^bold>|"
+  by (simp add: assms(1) assms(2) nemp_emp_pow)
+
+
+lemma pow_per: assumes "y \<noteq> \<epsilon>" and "k \<noteq> 0" shows "period (y\<^sup>@k) \<^bold>|y\<^bold>|"
+  using period_I'[OF \<open>k \<noteq> 0\<close>[folded nemp_emp_pow[OF \<open>y \<noteq> \<epsilon>\<close>]] nemp_len[OF \<open>y \<noteq> \<epsilon>\<close>]] pref_pow_ext_take by blast
+
+lemma per_fac: assumes "w \<noteq> \<epsilon>" and "w \<le>f y\<^sup>@k" shows "period w \<^bold>|y\<^bold>|" 
 proof-
+  have "y \<noteq> \<epsilon>"
+    using assms  by force                   
   have "k \<noteq> 0"
-    using nemp_pow suf_nemp[OF pref_nemp[OF \<open>v \<noteq> \<epsilon>\<close>, of w], of u, folded \<open>y\<^sup>@k = u\<cdot>v\<cdot>w\<close>] by blast
-  from pow_per[OF \<open>y \<noteq> \<epsilon>\<close> this, unfolded \<open>y\<^sup>@k = u\<cdot>v\<cdot>w\<close>]
-  have "periodN (u \<cdot> v \<cdot> w) \<^bold>|y\<^bold>|".
-  from periodN_fac[OF this \<open>v \<noteq> \<epsilon>\<close>]
-  show "periodN v \<^bold>|y\<^bold>|".
+    using assms nemp_exp_pos sublist_Nil_right by metis
+  from pow_per[OF \<open>y \<noteq> \<epsilon>\<close> this] period_fac  facE[OF \<open>w \<le>f y\<^sup>@k\<close>] \<open>w \<noteq> \<epsilon>\<close>
+  show "period w \<^bold>|y\<^bold>|" by metis
 qed
 
 text\<open>The numeric definition is equivalent to being prefix of a power.\<close>
 
-theorem periodN_pref: "periodN w n \<longleftrightarrow> (\<exists>k r. w \<le>np r\<^sup>@k \<and> \<^bold>|r\<^bold>| = n)" (is "_ \<longleftrightarrow> ?R")
+theorem period_pref: "period w n \<longleftrightarrow> (\<exists>k r. w \<le>np r\<^sup>@k \<and> \<^bold>|r\<^bold>| = n)" (is "_ \<longleftrightarrow> ?R")
 proof(cases "w = \<epsilon>", simp)
   assume "w \<noteq> \<epsilon>"
-  show "periodN w n \<longleftrightarrow> ?R"
+  show "period w n \<longleftrightarrow> ?R"
   proof
-    assume "periodN w n"
+    assume "period w n"
     consider (short) "\<^bold>|w\<^bold>| \<le> n" |  (long) "n < \<^bold>|w\<^bold>|"
       by linarith
     then show ?R
     proof(cases)
       assume "\<^bold>|w\<^bold>| \<le> n"
       from le_add_diff_inverse[OF this]
       obtain z where "\<^bold>|w \<cdot> z\<^bold>| = n"
-        unfolding length_append using exE[OF Ex_list_of_length[of "n - \<^bold>|w\<^bold>|"]] by metis
+        unfolding lenmorph using exE[OF Ex_list_of_length[of "n - \<^bold>|w\<^bold>|"]] by metis
       thus ?R
-        using  pow_one_id npI'[OF \<open>w \<noteq> \<epsilon>\<close>] by metis
+        using  pow_one' npI'[OF \<open>w \<noteq> \<epsilon>\<close>] by metis
     next
       assume "n < \<^bold>|w\<^bold>|"
       then show ?R
-        using \<open>periodN w n\<close>[unfolded periodN_def per_pref[of w "take n w"]]
+        using \<open>period w n\<close>[unfolded period_def per_pref[of w "take n w"]]
           \<open>w \<noteq> \<epsilon>\<close> take_len[OF less_imp_le[OF \<open>n < \<^bold>|w\<^bold>|\<close>]] by blast
     qed
   next
     assume ?R
     then obtain k r where "w \<le>np r\<^sup>@k" and "n = \<^bold>|r\<^bold>|" by blast
     have "w \<le>p take n w \<cdot> w"
-        using  pref_pow_take[OF npD[OF \<open>w \<le>np r \<^sup>@ k\<close>], folded \<open>n = \<^bold>|r\<^bold>|\<close>].
+      using  pref_pow_take[OF npD[OF \<open>w \<le>np r \<^sup>@ k\<close>], folded \<open>n = \<^bold>|r\<^bold>|\<close>].
     have "n \<noteq> 0"
       unfolding length_0_conv[of r, folded \<open>n = \<^bold>|r\<^bold>|\<close>] using \<open>w \<le>np r \<^sup>@ k\<close> by force
     hence "take n w \<noteq> \<epsilon>"
       unfolding \<open>n = \<^bold>|r\<^bold>|\<close> using \<open>w \<noteq> \<epsilon>\<close> by simp
-    thus "periodN w n"
-      unfolding periodN_def period_root_def using \<open>w \<le>p take n w \<cdot> w\<close> by blast
+    thus "period w n"
+      unfolding period_def period_root_def using \<open>w \<le>p take n w \<cdot> w\<close> by blast
   qed
 qed
 
 text \<open>Two more characterizations of a period\<close>
 
 theorem per_shift: assumes "w \<noteq> \<epsilon>" "n \<noteq> 0"
-  shows "periodN w n \<longleftrightarrow> drop n w \<le>p w"
+  shows "period w n \<longleftrightarrow> drop n w \<le>p w"
 proof
-  assume "periodN w n" show "drop n w \<le>p w"
-  using drop_per_pref[OF \<open>periodN w n\<close>[unfolded periodN_def]]
-  append_take_drop_id[of n w, unfolded append_eq_conv_conj] by argo
+  assume "period w n" show "drop n w \<le>p w"
+    using drop_per_pref[OF \<open>period w n\<close>[unfolded period_def]]
+      append_take_drop_id[of n w, unfolded append_eq_conv_conj] by argo
 next
   assume "drop n w \<le>p w"
-  show "periodN w n"
+  show "period w n"
     using conjI[OF pref_cancel'[OF \<open>drop n w \<le>p w\<close>, of "take n w"] take_nemp[OF \<open>w \<noteq> \<epsilon>\<close> \<open>n \<noteq> 0\<close>]]
     unfolding  append_take_drop_id period_root_def by force
 qed
 
 lemma rotate_per_root: assumes "w \<noteq> \<epsilon>" and "n \<noteq> 0" and "w = rotate n w"
-  shows "periodN w n"
+  shows "period w n"
 proof (cases "\<^bold>|w\<^bold>| \<le> n")
   assume "\<^bold>|w\<^bold>| \<le> n"
   from all_long_pers[OF \<open>w \<noteq> \<epsilon>\<close>, OF this]
-  show "periodN w n".
+  show "period w n".
 next
   assume not: "\<not> \<^bold>|w\<^bold>| \<le> n"
   have "drop (n mod \<^bold>|w\<^bold>|) w \<le>p w"
     using prefI[OF rotate_drop_take[symmetric, of n w]]
     unfolding \<open>w = rotate n w\<close>[symmetric].
   from per_shift[OF \<open>w \<noteq> \<epsilon>\<close> \<open>n \<noteq> 0\<close>] this[unfolded mod_less[OF not[unfolded not_le]]]
-  show "periodN w n"..
+  show "period w n"..
 qed
 
 subsubsection \<open>Various lemmas on periods\<close>
 
-lemma periodN_drop: assumes "periodN w p" and "p < \<^bold>|w\<^bold>|"
-  shows "periodN (drop p w) p"
-  using periodN_fac[of "take p w" "drop p w" \<epsilon> p] \<open>p < \<^bold>|w\<^bold>|\<close> \<open>periodN w p\<close>
+lemma period_drop: assumes "period w p" and "p < \<^bold>|w\<^bold>|"
+  shows "period (drop p w) p"
+  using period_fac[of "take p w" "drop p w" \<epsilon> p] \<open>p < \<^bold>|w\<^bold>|\<close> \<open>period w p\<close>
   unfolding append_take_drop_id drop_eq_Nil not_le append_Nil2 by blast
 
-lemma ext_per_left: assumes "periodN w p" and  "p \<le> \<^bold>|w\<^bold>|"
-  shows "periodN (take p w \<cdot> w) p"
+lemma ext_per_left: assumes "period w p" and  "p \<le> \<^bold>|w\<^bold>|"
+  shows "period (take p w \<cdot> w) p"
 proof-
   have f: "take p (take p w \<cdot> w) = take p w"
     using \<open>p \<le> \<^bold>|w\<^bold>|\<close> by simp
   show ?thesis
-    using  \<open>periodN w p\<close> pref_cancel'[of w "take p w \<cdot> w" "take p w" ] unfolding f periodN_def period_root_def
+    using  \<open>period w p\<close> pref_cancel'[of w "take p w \<cdot> w" "take p w" ] unfolding f period_def period_root_def
     by blast
 qed
 
-lemma ext_per_left_power: "periodN w p \<Longrightarrow> p \<le> \<^bold>|w\<^bold>| \<Longrightarrow> periodN ((take p w)\<^sup>@k \<cdot> w) p"
+lemma ext_per_left_power: "period w p \<Longrightarrow> p \<le> \<^bold>|w\<^bold>| \<Longrightarrow> period ((take p w)\<^sup>@k \<cdot> w) p"
 proof (induction k)
   case (Suc k)
   show ?case
-    using ext_per_left[OF Suc.IH[OF \<open>periodN w p\<close> \<open>p \<le> \<^bold>|w\<^bold>|\<close>]] \<open>p \<le> \<^bold>|w\<^bold>|\<close>
-    unfolding pref_share_take[OF per_exp_pref[OF periodN_D3[OF \<open>periodN w p\<close>]] \<open>p \<le> \<^bold>|w\<^bold>|\<close>,symmetric]
-      lassoc pow_Suc_list[symmetric] by fastforce
+    using ext_per_left[OF Suc.IH[OF \<open>period w p\<close> \<open>p \<le> \<^bold>|w\<^bold>|\<close>]] \<open>p \<le> \<^bold>|w\<^bold>|\<close>
+    unfolding pref_share_take[OF per_exp_pref[OF period_D3[OF \<open>period w p\<close>]] \<open>p \<le> \<^bold>|w\<^bold>|\<close>,symmetric]
+      lassoc pow_Suc[symmetric] by fastforce
 qed auto
 
-lemma take_several_pers: assumes "periodN w n" and "m*n \<le> \<^bold>|w\<^bold>|"
+lemma take_several_pers: assumes "period w n" and "m*n \<le> \<^bold>|w\<^bold>|"
   shows "(take n w)\<^sup>@m = take (m*n) w"
 proof (cases "m = 0", simp)
   assume "m \<noteq> 0"
   have "\<^bold>|(take n w)\<^sup>@m\<^bold>| = m*n"
     unfolding pow_len nat_prod_le[OF \<open>m \<noteq> 0\<close> \<open>m*n \<le> \<^bold>|w\<^bold>|\<close>, THEN take_len] by blast
   have "(take n w)\<^sup>@m \<le>p w"
-    using  \<open>periodN w n\<close>[unfolded periodN_def, THEN  per_exp[of w "take n w" m], THEN
-      ruler_le[of "take n w\<^sup>@m" "take n w\<^sup>@m \<cdot> w" w, OF triv_pref], OF  \<open>m * n \<le> \<^bold>|w\<^bold>|\<close>[folded \<open>\<^bold>|take n w\<^sup>@m\<^bold>| = m * n\<close>]].
+    using  \<open>period w n\<close>[unfolded period_def, THEN  per_exp[of w "take n w" m], THEN
+        ruler_le[of "take n w\<^sup>@m" "take n w\<^sup>@m \<cdot> w" w, OF triv_pref], OF  \<open>m * n \<le> \<^bold>|w\<^bold>|\<close>[folded \<open>\<^bold>|take n w\<^sup>@m\<^bold>| = m * n\<close>]].
   show ?thesis
     using pref_take[OF \<open>take n w\<^sup>@m \<le>p w\<close>, unfolded  \<open>\<^bold>|take n w\<^sup>@m\<^bold>| = m * n\<close>, symmetric].
 qed
 
-lemma per_mult: assumes "periodN w n" and "m \<noteq> 0" shows "periodN w (m*n)"
+lemma per_div: assumes "n dvd \<^bold>|w\<^bold>|" and "period w n"
+  shows "(take n w)\<^sup>@(\<^bold>|w\<^bold>| div n) = w"
+  using take_several_pers[OF \<open>period w n\<close> div_times_less_eq_dividend] unfolding dvd_div_mult_self[OF \<open>n dvd \<^bold>|w\<^bold>|\<close>] take_self.
+
+lemma per_mult: assumes "period w n" and "m \<noteq> 0" shows "period w (m*n)"
 proof (cases "m*n \<le> \<^bold>|w\<^bold>|")
-  have "w \<noteq> \<epsilon>" using periodN_D1[OF \<open>periodN w n\<close>].
-  assume "\<not> m * n \<le> \<^bold>|w\<^bold>|" thus "periodN w (m*n)"
+  have "w \<noteq> \<epsilon>" using period_D1[OF \<open>period w n\<close>].
+  assume "\<not> m * n \<le> \<^bold>|w\<^bold>|" thus "period w (m*n)"
     using all_long_pers[of  w "m * n", OF \<open>w \<noteq> \<epsilon>\<close>] by linarith
 next
   assume "m * n \<le> \<^bold>|w\<^bold>|"
-  show "periodN w (m*n)"
-    using  per_add_exp[of w "take n w", OF _ \<open>m \<noteq> 0\<close>] \<open>periodN w n\<close>
-    unfolding periodN_def period_root_def take_several_pers[OF \<open>periodN w n\<close> \<open>m*n \<le> \<^bold>|w\<^bold>|\<close>, symmetric] by blast
-qed
-
-lemma root_periodN: assumes "w \<noteq> \<epsilon>" and  "w \<le>p r\<^sup>\<omega>" shows "periodN w \<^bold>|r\<^bold>|"
-  unfolding periodN_def period_root_def using  per_pref_ex[OF \<open>w \<le>p r\<^sup>\<omega>\<close>
-  pref_pow_take[of w r], of "\<lambda> x. x"] take_nemp_len[OF \<open>w \<noteq> \<epsilon>\<close>  per_rootD'[OF \<open>w \<le>p r\<^sup>\<omega>\<close>]] by blast
-
-theorem  two_periodsN:
-  assumes "periodN w p" "periodN w q"  "p + q \<le> \<^bold>|w\<^bold>|"
-  shows "periodN w (gcd p q)"
+  show "period w (m*n)"
+    using  per_add_exp[of w "take n w", OF _ \<open>m \<noteq> 0\<close>] \<open>period w n\<close>
+    unfolding period_def period_root_def take_several_pers[OF \<open>period w n\<close> \<open>m*n \<le> \<^bold>|w\<^bold>|\<close>, symmetric] by blast
+qed
+
+lemma root_period: assumes "w \<noteq> \<epsilon>" and  "w \<le>p r\<^sup>\<omega>" shows "period w \<^bold>|r\<^bold>|"
+  unfolding period_def period_root_def using  per_pref_ex[OF \<open>w \<le>p r\<^sup>\<omega>\<close>
+      pref_pow_take[of w r], of "\<lambda> x. x"] take_nemp_len[OF \<open>w \<noteq> \<epsilon>\<close>  per_rootD'[OF \<open>w \<le>p r\<^sup>\<omega>\<close>]] by blast
+
+theorem  two_periods:
+  assumes "period w p" "period w q"  "p + q \<le> \<^bold>|w\<^bold>|"
+  shows "period w (gcd p q)"
 proof-
   obtain t where "take p w \<in> t*" "take q w \<in> t*"
-    using two_pers[OF \<open>periodN w p\<close>[unfolded periodN_def] \<open>periodN w q\<close>[unfolded periodN_def],
+    using two_pers_root[OF \<open>period w p\<close>[unfolded period_def] \<open>period w q\<close>[unfolded period_def],
         unfolded take_len[OF add_leD1[OF \<open>p + q \<le> \<^bold>|w\<^bold>|\<close>]] take_len[OF add_leD2[OF \<open>p + q \<le> \<^bold>|w\<^bold>|\<close>]],
         OF \<open>p + q \<le> \<^bold>|w\<^bold>|\<close>, unfolded comm_root[of "take p w" "take q w"]] by blast
   hence "w \<le>p t\<^sup>\<omega>"
-    using \<open>periodN w p\<close> periodN_def per_root_trans by blast
-  have "periodN w \<^bold>|t\<^bold>|"
-    using  root_periodN[OF  per_nemp[OF \<open>periodN w p\<close>] \<open>w \<le>p t\<^sup>\<omega>\<close>].
+    using \<open>period w p\<close> period_def per_root_trans by blast
+  have "period w \<^bold>|t\<^bold>|"
+    using  root_period[OF  per_nemp[OF \<open>period w p\<close>] \<open>w \<le>p t\<^sup>\<omega>\<close>].
   have "\<^bold>|t\<^bold>| dvd (gcd p q)"
     using gcd_nat.boundedI[OF root_len_dvd[OF \<open>take p w \<in> t*\<close>] root_len_dvd[OF \<open>take q w \<in> t*\<close>]]
     unfolding take_len[OF add_leD1[OF \<open>p + q \<le> \<^bold>|w\<^bold>|\<close>]] take_len[OF add_leD2[OF \<open>p + q \<le> \<^bold>|w\<^bold>|\<close>]].
   thus ?thesis
-    using  per_mult[OF \<open>periodN w \<^bold>|t\<^bold>|\<close>, of "gcd p q div \<^bold>|t\<^bold>|", unfolded dvd_div_mult_self[OF \<open>\<^bold>|t\<^bold>| dvd (gcd p q)\<close>]]
+    using  per_mult[OF \<open>period w \<^bold>|t\<^bold>|\<close>, of "gcd p q div \<^bold>|t\<^bold>|", unfolded dvd_div_mult_self[OF \<open>\<^bold>|t\<^bold>| dvd (gcd p q)\<close>]]
       dvd_div_mult_self[OF \<open>\<^bold>|t\<^bold>| dvd (gcd p q)\<close>]
-      gcd_eq_0_iff[of p q] mult_zero_left[of "\<^bold>|t\<^bold>|"] periodN_D2[OF \<open>periodN w p\<close>] by argo
+      gcd_eq_0_iff[of p q] mult_zero_left[of "\<^bold>|t\<^bold>|"] period_D2[OF \<open>period w p\<close>] by argo
 qed
 
 lemma index_mod_per_root: assumes "r \<noteq> \<epsilon>" and i: "\<forall> i < \<^bold>|w\<^bold>|. w!i = r!(i mod \<^bold>|r\<^bold>|)" shows  "w \<le>p r\<^sup>\<omega>"
 proof-
   have "i < \<^bold>|w\<^bold>| \<Longrightarrow> (r \<cdot> w) ! i = r ! (i mod \<^bold>|r\<^bold>|)" for i
     by (simp add: i mod_if nth_append)
   hence "w \<le>p r \<cdot> w"
     using index_pref[of w "r \<cdot> w"] i
     by simp
   thus ?thesis unfolding period_root_def using \<open>r \<noteq> \<epsilon>\<close> by auto
 qed
 
 lemma index_pref_pow_mod: "w \<le>p r\<^sup>@k \<Longrightarrow> i < \<^bold>|w\<^bold>| \<Longrightarrow>  w!i = r!(i mod \<^bold>|r\<^bold>| )"
   using  index_pow_mod[of i r k] less_le_trans[of i "\<^bold>|w\<^bold>|" "\<^bold>|r\<^sup>@k\<^bold>|"] prefix_length_le[of w "r\<^sup>@k"] pref_index[of w "r\<^sup>@k" i] by argo
 
 lemma index_per_root_mod: "w \<le>p r\<^sup>\<omega> \<Longrightarrow> i < \<^bold>|w\<^bold>| \<Longrightarrow>  w!i = r!(i mod \<^bold>|r\<^bold>|)"
   using index_pref_pow_mod[of w r _ i] per_pref[of w r ] by blast
 
-lemma root_divisor: assumes "periodN w k" and  "k dvd \<^bold>|w\<^bold>|" shows "w \<in> (take k w)*"
+lemma root_divisor: assumes "period w k" and  "k dvd \<^bold>|w\<^bold>|" shows "w \<in> (take k w)*"
   using rootI[of "take k w" "(\<^bold>|w\<^bold>| div k)"] unfolding
-    take_several_pers[OF \<open>periodN w k\<close>, of "\<^bold>|w\<^bold>| div k", unfolded dvd_div_mult_self[OF \<open>k dvd \<^bold>|w\<^bold>|\<close>] take_self, OF , OF order_refl].
-
-lemma per_pref': assumes "u \<noteq> \<epsilon>" and "periodN v k" and  "u \<le>p v" shows "periodN u k"
+    take_several_pers[OF \<open>period w k\<close>, of "\<^bold>|w\<^bold>| div k", unfolded dvd_div_mult_self[OF \<open>k dvd \<^bold>|w\<^bold>|\<close>] take_self, OF , OF order_refl].
+
+lemma per_pref': assumes "u \<noteq> \<epsilon>" and "period v k" and  "u \<le>p v" shows "period u k"
 proof-
   { assume "k \<le> \<^bold>|u\<^bold>|"
     have "take k v = take k u"
       using  pref_share_take[OF \<open>u \<le>p v\<close> \<open>k \<le> \<^bold>|u\<^bold>|\<close>]  by auto
     hence "take k v \<noteq> \<epsilon>"
-      using \<open>periodN v k\<close> by auto
+      using \<open>period v k\<close> by auto
     hence "take k u \<noteq> \<epsilon>"
       by (simp add: \<open>take k v = take k u\<close>)
     have "u \<le>p take k u \<cdot> v"
-      using  \<open>periodN v k\<close>
-      unfolding periodN_def period_root_def \<open>take k v = take k u\<close>
+      using  \<open>period v k\<close>
+      unfolding period_def period_root_def \<open>take k v = take k u\<close>
       using pref_trans[OF \<open>u \<le>p v\<close>, of "take k u \<cdot> v"]
       by blast
     hence "u \<le>p take k u \<cdot> u"
       using \<open>u \<le>p v\<close> pref_prod_pref by blast
     hence ?thesis
-      using \<open>take k u \<noteq> \<epsilon>\<close> periodN_def by fast
+      using \<open>take k u \<noteq> \<epsilon>\<close> period_def by blast
   }
   thus ?thesis
     using \<open>u \<noteq> \<epsilon>\<close> all_long_pers nat_le_linear by blast
 qed
 
 subsection "Period: overview"
 notepad
 begin
   fix w r::"'a list"
   fix n::nat
   assume "w \<noteq> \<epsilon>" "r \<noteq> \<epsilon>" "n > 0"
   have "\<not> w \<le>p \<epsilon>\<^sup>\<omega>"
     by simp
   have "\<not> \<epsilon> \<le>p \<epsilon>\<^sup>\<omega>"
     by simp
   have "\<epsilon> \<le>p r\<^sup>\<omega>"
     by (simp add: \<open>r \<noteq> \<epsilon>\<close>)
-  have "\<not> periodN w 0"
+  have "\<not> period w 0"
     by simp
-  have "\<not> periodN \<epsilon> 0"
+  have "\<not> period \<epsilon> 0"
     by simp
-  have "\<not> periodN \<epsilon> n"
+  have "\<not> period \<epsilon> n"
     by simp
 end
 
 subsection \<open>Singleton and its power\<close>
 
+primrec letter_pref_exp :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
+  "letter_pref_exp \<epsilon> a = 0" |
+  "letter_pref_exp (b # xs) a = (if b \<noteq> a then 0 else Suc (letter_pref_exp xs a))"
+
+definition letter_suf_exp :: "'a list \<Rightarrow> 'a \<Rightarrow> nat" where
+  "letter_suf_exp w a = letter_pref_exp (rev w) a"
+
 lemma concat_len_one: assumes "\<^bold>|us\<^bold>| = 1" shows "concat us = hd us"
   using concat_sing[OF sing_word[OF \<open>\<^bold>|us\<^bold>| = 1\<close>, symmetric]].
 
 lemma sing_pow_hd_tl: "c # w \<in> [a]* \<longleftrightarrow> c = a \<and> w \<in> [a]*"
 proof
   assume "c = a \<and> w \<in> [a]*"
   thus "c # w \<in> [a]*"
     unfolding  hd_word[of _ w]  using add_root[of "[c]" w] by simp
 next
   assume "c # w \<in> [a]*"
   then obtain k where "[a]\<^sup>@k = c # w" unfolding root_def by blast
   thus "c = a \<and> w \<in> [a]*"
   proof (cases "k = 0", simp)
     assume "[a] \<^sup>@ k = c # w" and "k \<noteq> 0"
-    from eqd_equal[of "[a]", OF this(1)[unfolded hd_word[of _ w] pop_pow_one[OF \<open>k \<noteq> 0\<close>]]]
+    from eqd_eq[of "[a]", OF this(1)[unfolded hd_word[of _ w] pop_pow_one[OF \<open>k \<noteq> 0\<close>]]]
     show ?thesis
       unfolding root_def by auto
   qed
 qed
 
-lemma pref_sing_power: assumes "w \<le>p [a]\<^sup>@m" shows "w = [a]\<^sup>@(\<^bold>|w\<^bold>|)"
+lemma pref_sing_pow: assumes "w \<le>p [a]\<^sup>@m" shows "w = [a]\<^sup>@(\<^bold>|w\<^bold>|)"
 proof-
   have  "[a]\<^sup>@m = [a]\<^sup>@(\<^bold>|w\<^bold>|)\<cdot>[a]\<^sup>@(m-\<^bold>|w\<^bold>|)"
     using pop_pow[OF prefix_length_le[OF assms, unfolded sing_pow_len], of "[a]", symmetric].
   show ?thesis
-    using  conjunct1[OF eqd_equal[of w "w\<inverse>\<^sup>>[a]\<^sup>@m" "[a]\<^sup>@(\<^bold>|w\<^bold>|)""[a]\<^sup>@(m-\<^bold>|w\<^bold>|)",
+    using  conjunct1[OF eqd_eq[of w "w\<inverse>\<^sup>>[a]\<^sup>@m" "[a]\<^sup>@(\<^bold>|w\<^bold>|)""[a]\<^sup>@(m-\<^bold>|w\<^bold>|)",
           unfolded lq_pref[OF assms] sing_pow_len,
           OF \<open>[a]\<^sup>@m = [a]\<^sup>@(\<^bold>|w\<^bold>|)\<cdot>[a]\<^sup>@(m-\<^bold>|w\<^bold>|)\<close> refl]].
 qed
 
 lemma sing_pow_palindrom: assumes "w = [a]\<^sup>@k" shows "rev w = w"
   using rev_pow[of "[a]" "\<^bold>|w\<^bold>|", unfolded rev_sing]
-  unfolding pref_sing_power[of w a k, unfolded assms[unfolded root_def, symmetric], OF self_pref, symmetric].
+  unfolding pref_sing_pow[of w a k, unfolded assms[unfolded root_def, symmetric], OF self_pref, symmetric].
 
 lemma suf_sing_power: assumes "w \<le>s [a]\<^sup>@m" shows "w \<in> [a]*"
   using sing_pow_palindrom[of "rev w" a "\<^bold>|rev w\<^bold>|", unfolded rev_rev_ident]
-    pref_sing_power[of "rev w" a m, OF \<open>w \<le>s [a]\<^sup>@m\<close>[unfolded suffix_to_prefix rev_pow rev_rev_ident rev_sing]]
+    pref_sing_pow[of "rev w" a m, OF \<open>w \<le>s [a]\<^sup>@m\<close>[unfolded suffix_to_prefix rev_pow rev_rev_ident rev_sing]]
     rootI[of "[a]" "\<^bold>|rev w\<^bold>|"]  by auto
 
 lemma sing_fac_pow: assumes "w \<in> [a]*" and  "v \<le>f w" shows "v \<in> [a]*"
 proof-
   obtain k where "w = [a]\<^sup>@k" using \<open>w \<in> [a]*\<close>[unfolded root_def] by blast
   obtain p where "p \<le>p w" and "v \<le>s p"
     using fac_pref_suf[OF \<open> v \<le>f w\<close>] by blast
   hence "v \<le>s [a]\<^sup>@ \<^bold>|p\<^bold>|"
-     using pref_sing_power[OF \<open>p \<le>p w\<close>[unfolded \<open>w = [a]\<^sup>@k\<close>]] by argo
+    using pref_sing_pow[OF \<open>p \<le>p w\<close>[unfolded \<open>w = [a]\<^sup>@k\<close>]] by argo
   from suf_sing_power[OF this]
   show ?thesis.
 qed
 
 lemma sing_pow_fac': assumes "a \<noteq> b" and  "w \<in> [a]*" shows "\<not> ([b] \<le>f w)"
   using sing_fac_pow[OF \<open> w \<in> [a]*\<close>, of "[b]"] unfolding sing_pow_hd_tl[of b \<epsilon>]
   using \<open>a \<noteq> b\<close> by auto
 
 lemma all_set_sing_pow: "(\<forall> b. b \<in> set w \<longrightarrow> b = a) \<longleftrightarrow> w \<in> [a]*" (is "?All \<longleftrightarrow> _")
 proof
   assume ?All
   then show "w \<in> [a]*"
   proof (induct w, simp)
     case (Cons c w)
     then show ?case
       by (simp add: sing_pow_hd_tl)
   qed
-  next
+next
   assume "w \<in> [a]*"
   then show ?All
   proof (induct w, simp)
     case (Cons c w)
     then show ?case
       unfolding sing_pow_hd_tl by simp
   qed
 qed
 
-lemma sing_pow_set: "u \<in> [a]* \<Longrightarrow> u \<noteq> \<epsilon> \<Longrightarrow> set u = {a}"
+lemma sing_fac_set: "[a] \<le>f x \<Longrightarrow> a \<in> set x"
+  by fastforce
+
+lemma set_sing_pow_hd: assumes "k \<noteq> 0" shows "a \<in> set ([a]\<^sup>@k \<cdot> u)" 
+  unfolding set_append 
+proof-
+  have "set ([a] \<^sup>@ k) = set ([a] \<cdot> [a]\<^sup>@(k-1))"
+    unfolding Suc_minus[OF \<open>k \<noteq> 0\<close>] pow_Suc[symmetric]..
+  thus "a \<in> set ([a] \<^sup>@ k) \<union> set u" by force 
+qed 
+
+lemma neq_set_not_root: "a \<noteq> b \<Longrightarrow> b \<in> set x \<Longrightarrow> x \<notin> [a]*"
+  using all_set_sing_pow by metis 
+
+lemma sing_pow_set_Suc[simp]: "set ([a]\<^sup>@Suc k) = {a}"  
+  by (induct k, simp_all)
+
+lemma sing_pow_set_sub: "set ([a]\<^sup>@k) \<subseteq> {a}"
+  by (induct k, simp_all) 
+
+lemma unique_letter_fac_expE: assumes "w \<le>f [a]\<^sup>@k"
+  obtains m where "w = [a]\<^sup>@m"
+  using unique_letter_wordE''[OF subset_trans[OF set_mono_sublist[OF assms] sing_pow_set_sub]] by blast
+
+lemma sing_pow_set: assumes "k \<noteq> 0" shows "set ([a]\<^sup>@k) = {a}"
+  using sing_pow_set_Suc[of a "k - 1", unfolded Suc_minus[OF \<open>k \<noteq> 0\<close>]].
+
+lemma neq_in_set_not_pow: "a \<noteq> b \<Longrightarrow> b \<in> set x \<Longrightarrow> x \<noteq> [a]\<^sup>@k"
+  by (cases "k = 0", force) (use sing_pow_set singleton_iff in metis)
+
+lemma sing_pow_card_set_Suc: assumes "c = [a]\<^sup>@Suc k" shows "card(set c) = 1" 
+proof-
+  have "card {a} = 1" by simp
+  from this[folded sing_pow_set_Suc[of a k]] 
+  show "card(set c) = 1" 
+    unfolding assms.
+qed
+
+lemma sing_pow_card_set:  assumes "k \<noteq> 0" and "c = [a]\<^sup>@k" shows "card(set c) = 1"
+  using sing_pow_card_set_Suc[of c a "k - 1", unfolded Suc_minus[OF \<open>k \<noteq> 0\<close>], OF \<open>c = [a]\<^sup>@k\<close>]. 
+
+lemma sing_pow_set': "u \<in> [a]* \<Longrightarrow> u \<noteq> \<epsilon> \<Longrightarrow> set u = {a}"
   unfolding all_set_sing_pow[symmetric]
-  using hd_in_set[of u] is_singletonI'[unfolded is_singleton_the_elem, of "set u"]
-     singleton_iff[of a "the_elem (set u)"]
+  using lists_hd_in_set[of u] is_singletonI'[unfolded is_singleton_the_elem, of "set u"]
+    singleton_iff[of a "the_elem (set u)"]
   by auto
 
+lemma root_sing_set_iff: "u \<in> [a]* \<longleftrightarrow> set u \<subseteq> {a}"
+  by (rule, use sing_pow_set'[of u a, folded set_empty2] in force, use all_set_sing_pow[of u a] in force) 
+
+lemma letter_pref_exp_hd: "u \<noteq> \<epsilon> \<Longrightarrow> hd u = a \<Longrightarrow> letter_pref_exp u a \<noteq> 0"
+  by (induct u, auto)
+
+(* lemma hd_pref_exp_pos: "u \<noteq> \<epsilon> \<Longrightarrow> hd u = a \<Longrightarrow> letter_pref_exp u a \<noteq> 0" *)
+(* by (induct u, auto) *)
+
+lemma letter_pref_exp_pref: "[a]\<^sup>@(letter_pref_exp w a) \<le>p w "
+  by(induct w, simp, simp)
+
+lemma letter_pref_exp_Suc: "\<not> [a]\<^sup>@(Suc (letter_pref_exp w a)) \<le>p w "
+  by (induct w, simp_all add: prefix_def)
+
+lemma takeWhile_letter_pref_exp: "takeWhile (\<lambda>x. x = a) w =[a]\<^sup>@(letter_pref_exp w a)"
+  by (induct w, simp, simp)
+
+lemma concat_takeWhile_sing: "concat (takeWhile (\<lambda> x. x = u) ws) = u\<^sup>@\<^bold>|takeWhile (\<lambda> x. x = u) ws\<^bold>|"
+  unfolding takeWhile_letter_pref_exp  concat_sing_pow  sing_pow_len ..
+
+lemma dropWhile_distinct: assumes "w \<noteq> [a]\<^sup>@(letter_pref_exp w a)" 
+  shows "[a]\<^sup>@(letter_pref_exp w a)\<cdot>[hd (dropWhile (\<lambda>x. x = a) w)] \<le>p w"
+proof-
+  have nemp: "dropWhile (\<lambda>x. x = a) w \<noteq> \<epsilon>"
+    using takeWhile_dropWhile_id[of "\<lambda>x. x = a" w, unfolded  takeWhile_letter_pref_exp] \<open>w \<noteq> [a]\<^sup>@(letter_pref_exp w a)\<close>
+    by force
+  from takeWhile_dropWhile_id[of "\<lambda>x. x = a" w, unfolded takeWhile_letter_pref_exp] 
+  have "[a]\<^sup>@(letter_pref_exp w a)\<cdot>[hd (dropWhile (\<lambda>x. x = a) w)]\<cdot> tl (dropWhile (\<lambda>x. x = a) w) = w"
+    unfolding hd_tl[OF nemp].
+  thus ?thesis
+    unfolding lassoc using triv_pref by blast
+qed
+
 lemma takeWhile_sing_root: "takeWhile (\<lambda> x. x = a) w \<in> [a]*"
   unfolding all_set_sing_pow[symmetric] using set_takeWhileD[of _ "\<lambda> x. x = a" w] by blast
 
 lemma takeWhile_sing_pow: "takeWhile (\<lambda> x. x = a) w = w \<longleftrightarrow> w = [a]\<^sup>@\<^bold>|w\<^bold>|"
   by(induct w,  auto)
 
 lemma dropWhile_sing_pow: "dropWhile (\<lambda> x. x = a) w = \<epsilon> \<longleftrightarrow> w = [a]\<^sup>@\<^bold>|w\<^bold>|"
   by(induct w,  auto)
 
-lemma distinct_letter_in: assumes "\<not> w \<in> [a]*"
+lemma distinct_letter_in: assumes "w \<notin> [a]*"
   obtains m b q where "[a]\<^sup>@m \<cdot> [b] \<cdot> q = w" and "b \<noteq> a"
 proof-
   have "dropWhile (\<lambda> x. x = a) w \<noteq> \<epsilon>"
     unfolding dropWhile_sing_pow using assms rootI[of "[a]" "\<^bold>|w\<^bold>|"] by auto
   hence eq: "takeWhile (\<lambda> x. x = a) w \<cdot> [hd (dropWhile (\<lambda> x. x = a) w)] \<cdot> tl (dropWhile (\<lambda> x. x = a) w) = w"
     by simp
   have root:"takeWhile (\<lambda> x. x = a) w \<in> [a]*"
     by (simp add: takeWhile_sing_root)
   have  "hd (dropWhile (\<lambda> x. x = a) w) \<noteq> a"
     using hd_dropWhile[OF \<open>dropWhile (\<lambda>x. x = a) w \<noteq> \<epsilon>\<close>].
   from that[OF _  this]
   show thesis
     using eq root unfolding root_def by metis
 qed
 
-lemma distinct_letter_in_hd: assumes "\<not> w \<in>  [hd w]*"
+lemma distinct_letter_in_hd: assumes "w \<notin> [hd w]*"
   obtains m b q where  "[hd w]\<^sup>@m \<cdot> [b] \<cdot> q = w" and "b \<noteq> hd w" and "m \<noteq> 0"
 proof-
   obtain m b q where a1: "[hd w]\<^sup>@m \<cdot> [b] \<cdot> q = w" and a2: "b \<noteq> hd w"
     using distinct_letter_in[OF assms].
-  hence "m \<noteq> 0"
-    using power_eq_if[of "[hd w]" m] list.sel(1) by fastforce
-  from that a1 a2 this
-  show thesis by blast
-qed
-
-lemma distinct_letter_in_suf: assumes "\<not> w \<in>  [a]*" shows "\<exists> m b. [b] \<cdot> [a]\<^sup>@m  \<le>s w \<and> b \<noteq> a"
-proof-
-  have  "\<not> rev w \<in>  [a]*"
-    using rev_pow[of "[a]"] unfolding  rev_sing using assms root_def rev_rev_ident[of w]
-    by metis
-  obtain m b q where "[a]\<^sup>@m \<cdot> [b] \<cdot> q = rev w" and "b \<noteq> a"
-    using distinct_letter_in[OF \<open>\<not> rev w \<in>  [a]*\<close>]  by blast
-  have eq: "rev ([b] \<cdot> [a]\<^sup>@m) = [a]\<^sup>@m \<cdot> [b]"
-    by (simp add: rev_pow)
-  have "[b] \<cdot> [a]\<^sup>@m \<le>s w"
-    using  \<open>[a]\<^sup>@m \<cdot> [b] \<cdot> q = rev w\<close> unfolding suf_rev_pref_iff eq lassoc
-    using prefI by blast
-  thus ?thesis
-    using \<open>b \<noteq> a\<close> by blast
-qed
+  have "m \<noteq> 0"
+  proof (rule notI)
+    assume "m = 0"
+    note a1[unfolded this pow_zero clean_emp, folded hd_word]
+    thus False using a2 by force
+  qed
+  from that[OF a1 a2 this]
+  show thesis.
+qed
+
+lemma distinct_letter_in_hd': assumes "w \<notin> [hd w]*"
+  obtains m b q where  "[hd w]\<^sup>@Suc m \<cdot> [b] \<cdot> q = w" and "b \<noteq> hd w"
+using distinct_letter_in_hd[OF assms] Suc_minus by metis
+
+lemma distinct_letter_in_suf: assumes "w \<notin> [a]*"
+  obtains m b where "[b] \<cdot> [a]\<^sup>@m  \<le>s w" and "b \<noteq> a"
+  using distinct_letter_in[reversed, unfolded rassoc, OF assms]
+  unfolding suf_def by metis
 
 lemma sing_pow_exp: assumes "w \<in> [a]*" shows "w = [a]\<^sup>@\<^bold>|w\<^bold>|"
 proof-
   obtain k where "[a] \<^sup>@ k = w"
     using rootE[OF assms].
   from this[folded  sing_pow_len[of a k, folded this, unfolded this], symmetric]
   show ?thesis.
 qed
 
 lemma sing_power': assumes "w \<in> [a]*" and "i < \<^bold>|w\<^bold>|" shows "w ! i = a"
-  using  sing_pow[OF \<open>i < \<^bold>|w\<^bold>|\<close>, of a, folded sing_pow_exp[OF \<open>w \<in> [a]*\<close>]].
+  using  sing_pow_nth[OF \<open>i < \<^bold>|w\<^bold>|\<close>, of a, folded sing_pow_exp[OF \<open>w \<in> [a]*\<close>]].
 
 lemma rev_sing_power: "x \<in> [a]* \<Longrightarrow> rev x = x"
   unfolding root_def using rev_pow rev_singleton_conv  by metis
 
 lemma lcp_letter_power:
   assumes "w \<noteq> \<epsilon>" and "w \<in> [a]*" and "[a]\<^sup>@m \<cdot> [b] \<le>p z" and  "a \<noteq> b"
   shows "w \<cdot> z \<and>\<^sub>p z \<cdot> w = [a]\<^sup>@m"
 proof-
   obtain k z' where "w = [a]\<^sup>@k" "z = [a]\<^sup>@m \<cdot> [b] \<cdot> z'" "k \<noteq> 0"
     using \<open>w \<in> [a]*\<close> \<open>[a]\<^sup>@m \<cdot> [b] \<le>p z\<close> \<open>w \<noteq> \<epsilon>\<close> nemp_pow[of "[a]"]
     unfolding root_def
-    by auto
+    by (auto simp add: prefix_def)
   hence eq1: "w \<cdot> z = [a]\<^sup>@m \<cdot> ([a]\<^sup>@k \<cdot> [b] \<cdot> z')" and eq2: "z \<cdot> w = [a]\<^sup>@m \<cdot> ([b] \<cdot> z'\<cdot> [a]\<^sup>@k)"
-    by (simp add: \<open>w = [a]\<^sup>@k\<close> \<open>z = [a]\<^sup>@m \<cdot> [b] \<cdot> z'\<close> pow_comm)+
+    by (simp add: \<open>w = [a]\<^sup>@k\<close> \<open>z = [a]\<^sup>@m \<cdot> [b] \<cdot> z'\<close> pows_comm)+
   have "hd ([a]\<^sup>@k \<cdot> [b] \<cdot> z') = a"
     using hd_append2[OF \<open>w \<noteq> \<epsilon>\<close>, of "[b]\<cdot>z'",
-        unfolded \<open>w = (a # \<epsilon>)\<^sup>@k\<close> hd_sing_power[OF \<open>k \<noteq> 0\<close>, of a]].
+        unfolded \<open>w = (a # \<epsilon>)\<^sup>@k\<close> hd_sing_pow[OF \<open>k \<noteq> 0\<close>, of a]].
   moreover have "hd([b] \<cdot> z'\<cdot> [a]\<^sup>@k) = b"
     by simp
   ultimately have "[a]\<^sup>@k \<cdot> [b] \<cdot> z' \<and>\<^sub>p [b] \<cdot> z'\<cdot> [a]\<^sup>@k = \<epsilon>"
     by (simp add: \<open>a \<noteq> b\<close> lcp_distinct_hd)
   thus ?thesis using eq1 eq2 lcp_ext_left[of "[a]\<^sup>@m" "[a]\<^sup>@k \<cdot> [b] \<cdot> z'" "[b] \<cdot> z'\<cdot> [a]\<^sup>@k"]
     by simp
 qed
 
 lemma per_one: assumes "w \<le>p [a]\<^sup>\<omega>" shows "w \<in> [a]*"
 proof-
   have "w \<le>p (a # \<epsilon>) \<^sup>@ n \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> w \<in> [a]*" for n
-    using pref_sing_power[of w a] rootI[of "[a]" "\<^bold>|w\<^bold>|"] by auto
+    using pref_sing_pow[of w a] rootI[of "[a]" "\<^bold>|w\<^bold>|"] by auto
   with per_pref_ex[OF \<open>w \<le>p [a]\<^sup>\<omega>\<close>]
   show ?thesis by auto
 qed
 
 lemma per_one': "w \<in> [a]* \<Longrightarrow> w \<le>p [a]\<^sup>\<omega>"
   by (metis append_Nil2 not_Cons_self2 per_pref prefI root_def)
 
-lemma per_sing_one: assumes "w \<noteq> \<epsilon>" "w \<le>p [a]\<^sup>\<omega>" shows "periodN w 1"
-  using root_periodN[OF \<open>w \<noteq> \<epsilon>\<close> \<open>w \<le>p [a]\<^sup>\<omega>\<close>] unfolding sing_len[of a].
+lemma per_sing_one: assumes "w \<noteq> \<epsilon>" "w \<le>p [a]\<^sup>\<omega>" shows "period w 1"
+  using root_period[OF \<open>w \<noteq> \<epsilon>\<close> \<open>w \<le>p [a]\<^sup>\<omega>\<close>] unfolding sing_len[of a].
 
 section "Border"
 
 text\<open>A non-empty word  $x \neq w$ is a \emph{border} of a word $w$ if it is both its prefix and suffix. This elementary property captures how much the word $w$ overlaps
 with itself, and it is in the obvious way related to a period of $w$. However, in many cases it is much easier to reason about borders than about periods.\<close>
 
 definition border :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" ("_ \<le>b _" [51,51] 60 )
   where [simp]: "border x w = (x \<le>p w \<and> x \<le>s w \<and> x \<noteq> w \<and> x \<noteq> \<epsilon>)"
 
 definition bordered :: "'a list \<Rightarrow> bool"
   where [simp]: "bordered w = (\<exists>b. b \<le>b w)"
 
 lemma borderI[intro]: "x \<le>p w \<Longrightarrow> x \<le>s w \<Longrightarrow> x \<noteq> w \<Longrightarrow> x \<noteq> \<epsilon> \<Longrightarrow> x \<le>b w"
   unfolding border_def by blast
 
 lemma borderD_pref: "x \<le>b w \<Longrightarrow> x \<le>p w"
   unfolding border_def by blast
 
 lemma borderD_spref: "x \<le>b w \<Longrightarrow> x <p w"
   unfolding border_def  by simp
 
 lemma borderD_suf: "x \<le>b w \<Longrightarrow> x \<le>s w"
   unfolding border_def by blast
 
 lemma borderD_ssuf: "x \<le>b w \<Longrightarrow> x <s w"
   unfolding border_def by blast
 
 lemma borderD_nemp: "x \<le>b w \<Longrightarrow> x \<noteq> \<epsilon>"
   using border_def by blast
 
 lemma borderD_neq: "x \<le>b w \<Longrightarrow> x \<noteq> w"
   unfolding border_def by blast
 
+lemma borderedI: "u \<le>b w \<Longrightarrow> bordered w"
+  unfolding bordered_def by fast
+
 lemma border_lq_nemp: assumes "x \<le>b w" shows "x\<inverse>\<^sup>>w \<noteq> \<epsilon>"
   using assms borderD_spref lq_spref by blast
 
 lemma border_rq_nemp: assumes "x \<le>b w" shows "w\<^sup><\<inverse>x \<noteq> \<epsilon>"
   using assms borderD_ssuf rq_ssuf by blast
 
 lemma border_trans[trans]: assumes "t \<le>b x" "x \<le>b w"
   shows "t \<le>b w"
   using assms unfolding border_def
   using suffix_order.antisym pref_trans[of t x w] suf_trans[of t x w] by blast
 
 lemma border_rev_conv[reversal_rule]: "rev x \<le>b rev w \<longleftrightarrow> x \<le>b w"
   unfolding border_def
   using rev_is_Nil_conv[of x] rev_swap[of w] rev_swap[of x]
     suf_rev_pref_iff[of x w] pref_rev_suf_iff[of x w]
   by fastforce
 
 lemma border_lq_comp: "x \<le>b w \<Longrightarrow> (w\<^sup><\<inverse>x) \<bowtie> x"
-  unfolding border_def using rq_suf ruler by blast
+  unfolding border_def using rq_suf_suf ruler' by metis 
 
 lemmas border_lq_suf_comp = border_lq_comp[reversed]
 
 subsection "The shortest border"
 
 lemma border_len:  assumes "x \<le>b w"
   shows "1 < \<^bold>|w\<^bold>|" and "0 < \<^bold>|x\<^bold>|" and "\<^bold>|x\<^bold>| < \<^bold>|w\<^bold>|"
 proof-
   show "\<^bold>|x\<^bold>| < \<^bold>|w\<^bold>|"
     using assms prefix_length_less unfolding border_def strict_prefix_def
     by blast
   show "0 < \<^bold>|x\<^bold>|"
     using assms unfolding border_def by blast
   thus "1 < \<^bold>|w\<^bold>|"
     using assms \<open>\<^bold>|x\<^bold>| < \<^bold>|w\<^bold>|\<close> unfolding border_def
     by linarith
 qed
 
 lemma borders_compare: assumes "x \<le>b w" and "x' \<le>b w" and "\<^bold>|x'\<^bold>| < \<^bold>|x\<^bold>|"
   shows "x' \<le>b x"
   using ruler_le[OF borderD_pref[OF \<open>x' \<le>b w\<close>] borderD_pref[OF \<open>x \<le>b w\<close>] less_imp_le_nat[OF \<open>\<^bold>|x'\<^bold>| < \<^bold>|x\<^bold>|\<close>]]
     suf_ruler_le[OF borderD_suf[OF \<open>x' \<le>b w\<close>] borderD_suf[OF \<open>x \<le>b w\<close>] less_imp_le_nat[OF \<open>\<^bold>|x'\<^bold>| < \<^bold>|x\<^bold>|\<close>]]
     borderD_nemp[OF \<open>x' \<le>b w\<close>] \<open>\<^bold>|x'\<^bold>| < \<^bold>|x\<^bold>|\<close>
     borderI by blast
 
 lemma unbordered_border:
   "bordered w \<Longrightarrow>  \<exists> x. x \<le>b w \<and> \<not> bordered x"
 proof (induction "\<^bold>|w\<^bold>|" arbitrary: w rule: less_induct)
   case less
   obtain x' where "x' \<le>b w"
     using bordered_def less.prems by blast
   show ?case
   proof (cases "bordered x'")
     assume "\<not> bordered x'"
     thus ?case
       using \<open>x' \<le>b w\<close> by blast
   next
     assume "bordered x'"
     from less.hyps[OF border_len(3)[OF \<open>x' \<le>b w\<close>] this]
     show ?case
       using  border_trans[of _ x' w] \<open>x' \<le>b w\<close> by blast
   qed
 qed
 
 lemma unbordered_border_shortest: "x \<le>b w \<Longrightarrow> \<not> bordered x \<Longrightarrow>  y \<le>b w \<Longrightarrow> \<^bold>|x\<^bold>| \<le> \<^bold>|y\<^bold>|"
   using bordered_def[of x] borders_compare[of x w y] not_le_imp_less[of "\<^bold>|x\<^bold>|" "\<^bold>|y\<^bold>|"] by blast
 
 lemma long_border_bordered: assumes long: "\<^bold>|w\<^bold>| < \<^bold>|x\<^bold>| + \<^bold>|x\<^bold>|" and border: "x \<le>b w"
   shows "(w\<^sup><\<inverse>x)\<inverse>\<^sup>>x \<le>b x"
 proof-
   define p s where "p = w\<^sup><\<inverse>x" and "s = x\<inverse>\<^sup>>w"
   hence eq: "p\<cdot>x = x\<cdot>s"
     using assms unfolding border_def using lq_pref[of x w] rq_suf[of x w]  by simp
   have "\<^bold>|p\<^bold>| < \<^bold>|x\<^bold>|"
     using p_def long[folded rq_len[OF borderD_suf[OF border]]] by simp
   have px: "p \<cdot> p\<inverse>\<^sup>>x = x" and sx: "p\<inverse>\<^sup>>x \<cdot> s = x"
     using eqd_pref[OF eq less_imp_le, OF \<open>\<^bold>|p\<^bold>| < \<^bold>|x\<^bold>|\<close>] by blast+
   have "p\<inverse>\<^sup>>x \<noteq> \<epsilon>"
     using \<open>\<^bold>|p\<^bold>| < \<^bold>|x\<^bold>|\<close> px by fastforce
   have "p \<noteq> \<epsilon>"
     using border_rq_nemp[OF border] p_def
     by presburger
   have "p\<inverse>\<^sup>>x \<noteq> x"
     using \<open>p \<noteq> \<epsilon>\<close> px by force
   have "(p\<inverse>\<^sup>>x) \<le>b x"
     unfolding border_def
     using eqd_pref[OF eq less_imp_le, OF \<open>\<^bold>|p\<^bold>| < \<^bold>|x\<^bold>|\<close>] \<open>p\<inverse>\<^sup>>x \<noteq> \<epsilon>\<close> \<open>p\<inverse>\<^sup>>x \<noteq> x\<close> by blast
   thus ?thesis
     unfolding p_def.
 qed
 
 thm long_border_bordered[reversed]
 
 lemma border_short_dec: assumes border: "x \<le>b w" and short: "\<^bold>|x\<^bold>| + \<^bold>|x\<^bold>| \<le> \<^bold>|w\<^bold>|"
   shows "x \<cdot> x\<inverse>\<^sup>>(w\<^sup><\<inverse>x) \<cdot> x = w"
 proof-
   have eq: "x\<cdot>x\<inverse>\<^sup>>w = w\<^sup><\<inverse>x\<cdot>x"
     using lq_pref[OF borderD_pref[OF border]] rq_suf[OF borderD_suf[OF border]] by simp
   have "\<^bold>|x\<^bold>| \<le> \<^bold>|w\<^sup><\<inverse>x\<^bold>|"
     using short[folded rq_len[OF borderD_suf[OF border]]] by simp
   from  lq_pref[of x w, OF borderD_pref[OF border], folded conjunct2[OF eqd_pref[OF eq this]]]
   show ?thesis.
 qed
 
 lemma bordered_dec: assumes "bordered w"
   obtains u v where "u\<cdot>v\<cdot>u = w" and "u \<noteq> \<epsilon>"
 proof-
   obtain u where "u \<le>b w" and "\<not> bordered u"
     using unbordered_border[OF assms] by blast
   have "\<^bold>|u\<^bold>| + \<^bold>|u\<^bold>| \<le> \<^bold>|w\<^bold>|"
     using long_border_bordered[OF _ \<open>u \<le>b w\<close>] \<open>\<not> bordered u\<close> bordered_def leI by blast
   from border_short_dec[OF \<open>u \<le>b w\<close> this, THEN that, OF borderD_nemp[OF \<open>u \<le>b w\<close>]]
   show thesis.
 qed
 
+lemma emp_not_bordered: "\<not> bordered \<epsilon>"
+  by simp
+
+lemma bordered_nemp: "bordered w \<Longrightarrow> w \<noteq> \<epsilon>"
+  using emp_not_bordered by blast
+
+lemma sing_not_bordered: "\<not> bordered [a]"
+  using bordered_dec[of "[a]" False] append_eq_Cons_conv[of _ _ a \<epsilon>] suf_nemp by fast
+
 subsection "Relation to period and conjugation"
 
 lemma border_conjug_eq: "x \<le>b w \<Longrightarrow> (w\<^sup><\<inverse>x) \<cdot> w = w \<cdot> (x\<inverse>\<^sup>>w)"
   using lq_rq_reassoc_suf[OF borderD_pref borderD_suf, symmetric] by blast
 
 lemma border_per_root: "x \<le>b w \<Longrightarrow> w \<le>p (w\<^sup><\<inverse>x) \<cdot> w"
   using border_conjug_eq by blast
 
 lemma per_root_border: assumes "\<^bold>|r\<^bold>| < \<^bold>|w\<^bold>|" and "r \<noteq> \<epsilon>" and "w \<le>p r \<cdot> w"
   shows "r\<inverse>\<^sup>>w \<le>b w"
 proof
   have "\<^bold>|r\<^bold>| \<le> \<^bold>|w\<^bold>|" and "r \<le>p w"
     using less_imp_le[OF \<open>\<^bold>|r\<^bold>| < \<^bold>|w\<^bold>|\<close>] pref_prod_long[OF \<open>w \<le>p r \<cdot> w\<close>] by blast+
   show "r\<inverse>\<^sup>>w \<le>p w"
     using pref_lq[OF \<open>r \<le>p w\<close> \<open>w \<le>p r \<cdot> w\<close>] unfolding lq_triv.
   show "r\<inverse>\<^sup>>w \<le>s w"
-    using \<open>r \<le>p w\<close> by auto
+    using \<open>r \<le>p w\<close> by (auto simp add: prefix_def)
   show "r\<inverse>\<^sup>>w \<noteq> w"
-    using \<open>r \<le>p w\<close> \<open>r \<noteq> \<epsilon>\<close> by force
+    using \<open>r \<le>p w\<close> \<open>r \<noteq> \<epsilon>\<close> unfolding prefix_def  by fastforce 
   show "r\<inverse>\<^sup>>w \<noteq> \<epsilon>"
     using lq_pref[OF \<open>r \<le>p w\<close>] \<open>\<^bold>|r\<^bold>| < \<^bold>|w\<^bold>|\<close> by force
 qed
 
-lemma border_per: assumes "x \<le>b w" shows "periodN w (\<^bold>|w\<^bold>|-\<^bold>|x\<^bold>|)"
+lemma pref_suf_neq_per: assumes "x \<le>p w" and "x \<le>s w" and "x \<noteq> w" shows "period w (\<^bold>|w\<^bold>|-\<^bold>|x\<^bold>|)"
 proof-
-  have "w = (w\<^sup><\<inverse>x)\<cdot>x"
-    using rq_suf[OF borderD_suf[OF assms]] by simp
-  have "w = x\<cdot>(x\<inverse>\<^sup>>w)"
-    using lq_pref[OF borderD_pref[OF assms]] by simp
-  have take: "take (\<^bold>|w\<^bold>|-\<^bold>|x\<^bold>|) w = w\<^sup><\<inverse>x"
-    using borderD_suf[OF assms] by auto
+  have "(w\<^sup><\<inverse>x)\<cdot>x = w"
+    using  rq_suf[OF \<open>x \<le>s w\<close>].
+  have "x\<cdot>(x\<inverse>\<^sup>>w) = w"
+    using  lq_pref[OF \<open>x \<le>p w\<close>].
+  have take: "w\<^sup><\<inverse>x = take (\<^bold>|w\<^bold>|-\<^bold>|x\<^bold>|) w"
+    using rq_take[OF \<open>x \<le>s w\<close>].
   have nemp: "take (\<^bold>|w\<^bold>|-\<^bold>|x\<^bold>|) w \<noteq> \<epsilon>"
-    using assms by auto
+    using \<open>x \<le>p w\<close> \<open>x \<noteq> w\<close> unfolding prefix_def by auto
   have "w \<le>p take (\<^bold>|w\<^bold>|-\<^bold>|x\<^bold>|) w \<cdot> w"
-    unfolding take  lassoc[of "w\<^sup><\<inverse>x" x "x\<inverse>\<^sup>>w", folded \<open>w = x \<cdot> x\<inverse>\<^sup>>w\<close> \<open>w = w\<^sup><\<inverse>x \<cdot> x\<close>]
-    using  triv_pref[of w "x\<inverse>\<^sup>>w"].
-  thus "periodN w (\<^bold>|w\<^bold>|-\<^bold>|x\<^bold>|)"
-    unfolding periodN_def period_root_def using nemp by blast
-qed
-
-lemma per_border: assumes "n < \<^bold>|w\<^bold>|" and "periodN w n"
+    using triv_pref[of w "x\<inverse>\<^sup>>w"] 
+    unfolding lassoc[of "w\<^sup><\<inverse>x" x "x\<inverse>\<^sup>>w", unfolded \<open>x \<cdot> x\<inverse>\<^sup>>w = w\<close> \<open>w\<^sup><\<inverse>x \<cdot> x = w\<close>, symmetric] take.  
+  thus "period w (\<^bold>|w\<^bold>|-\<^bold>|x\<^bold>|)"
+    unfolding period_def period_root_def using nemp by blast
+qed
+
+lemma border_per: "x \<le>b w \<Longrightarrow> period w (\<^bold>|w\<^bold>|-\<^bold>|x\<^bold>|)"
+  unfolding  border_def using pref_suf_neq_per by blast
+
+lemma per_border: assumes "n < \<^bold>|w\<^bold>|" and "period w n"
   shows "take (\<^bold>|w\<^bold>| - n) w  \<le>b w"
 proof-
   have eq: "take (\<^bold>|w\<^bold>| - n) w = drop n w"
-    using pref_take[OF \<open>periodN w n\<close>[unfolded per_shift[OF periodN_D1[OF \<open>periodN w n\<close>] per_positive[OF \<open>periodN w n\<close>]]], unfolded length_drop].
+    using pref_take[OF \<open>period w n\<close>[unfolded per_shift[OF period_D1[OF \<open>period w n\<close>] per_positive[OF \<open>period w n\<close>]]], unfolded length_drop].
   have "take (\<^bold>|w\<^bold>| - n) w \<noteq> \<epsilon>"
     using \<open>n < \<^bold>|w\<^bold>|\<close> take_eq_Nil by fastforce
   moreover have "take (\<^bold>|w\<^bold>| - n) w \<noteq> w"
-    using  periodN_D2[OF \<open>periodN w n\<close>] \<open>n < \<^bold>|w\<^bold>|\<close> unfolding take_all_iff[of "\<^bold>|w\<^bold>|-n" w] by fastforce
+    using  period_D2[OF \<open>period w n\<close>] \<open>n < \<^bold>|w\<^bold>|\<close> unfolding take_all_iff[of "\<^bold>|w\<^bold>|-n" w] by fastforce
   ultimately show ?thesis
     unfolding border_def using take_is_prefix[of "\<^bold>|w\<^bold>|-n" w] suffix_drop[of n w, folded eq] by blast
 qed
 
+section \<open>The longest border and the shortest period\<close>
+
+subsection \<open>The longest border\<close>
+
+definition max_borderP :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" where
+  "max_borderP u w = (u \<le>p w \<and> u \<le>s w \<and> (u = w \<longrightarrow> w = \<epsilon>) \<and> (\<forall> v. v \<le>b w \<longrightarrow>  v \<le>p u))"
+
+lemma max_borderP_emp_emp: "max_borderP \<epsilon> \<epsilon>" 
+  unfolding max_borderP_def by simp 
+
+lemma max_borderP_exE: obtains u where "max_borderP u w"
+proof-
+  define P where "P = (\<lambda> x. x \<le>p w \<and> x \<le>s w \<and> (x = w \<longrightarrow> w = \<epsilon>))"
+  have "P \<epsilon>" 
+    unfolding P_def by blast
+  obtain v where "v \<le>p w" and "P v" and "(\<And>y. y \<le>p w \<Longrightarrow> P y \<Longrightarrow> y \<le>p v)"
+    using max_pref[of \<epsilon> w P thesis, OF prefix_bot.extremum \<open>P \<epsilon>\<close>] by blast
+  hence "max_borderP v w"
+    unfolding  max_borderP_def border_def P_def by presburger
+  from that[OF this]
+  show thesis.
+qed
+
+lemma max_borderP_of_nemp: "max_borderP u \<epsilon> \<Longrightarrow> u = \<epsilon>"
+  by (metis max_borderP_def suffix_bot.extremum_unique)
+
+lemma max_borderP_D_neq: "w \<noteq> \<epsilon> \<Longrightarrow> max_borderP u w \<Longrightarrow> u \<noteq> w"
+  by (simp add: max_borderP_def)
+
+lemma max_borderP_D_pref: "max_borderP u w \<Longrightarrow> u \<le>p w"
+  by (simp add: max_borderP_def)
+
+lemma max_borderP_D_suf: "max_borderP u w \<Longrightarrow> u \<le>s w"
+  by (simp add: max_borderP_def)
+
+lemma max_borderP_D_max: "max_borderP u w \<Longrightarrow> v \<le>b w \<Longrightarrow>  v \<le>p u"
+  by (simp add: max_borderP_def)
+
+lemma  max_borderP_D_max': "max_borderP u w \<Longrightarrow> v \<le>b w \<Longrightarrow> v \<le>s u"
+  unfolding max_borderP_def using borderD_suf  suf_pref_eq suffix_same_cases by metis
+
+lemma unbordered_max_border_emp:  "\<not> bordered w \<Longrightarrow> max_borderP u w \<Longrightarrow> u = \<epsilon>"
+  unfolding max_borderP_def bordered_def border_def by blast
+
+lemma bordered_max_border_nemp:  "bordered w \<Longrightarrow> max_borderP u w \<Longrightarrow> u \<noteq> \<epsilon>"
+  unfolding max_borderP_def bordered_def border_def using prefix_Nil by blast
+
+lemma max_borderP_border: "max_borderP u w \<Longrightarrow> u \<noteq> \<epsilon> \<Longrightarrow> u \<le>b w"
+  unfolding max_borderP_def border_def by blast
+
+lemma max_borderP_rev: "max_borderP (rev u) (rev w) \<Longrightarrow> max_borderP u w"
+proof-
+  assume "max_borderP (rev u) (rev w)"
+  from this[unfolded max_borderP_def rev_is_rev_conv, folded pref_rev_suf_iff suf_rev_pref_iff]
+  have "u = w \<longrightarrow> w = \<epsilon>" and "u \<le>p w" and "u \<le>s w" and allv: "v \<le>b rev w \<Longrightarrow> v \<le>p rev u" for v
+    by blast+
+  show "max_borderP u w"
+  proof (unfold max_borderP_def, intro conjI, simp_all only: \<open>u \<le>p w\<close> \<open>u \<le>s w\<close>)
+    show "u = w \<longrightarrow> w = \<epsilon>" by fact
+    show "\<forall>v. v \<le>b w \<longrightarrow> v \<le>p u"
+    proof (rule allI, rule impI)
+      fix v assume "v \<le>b w"
+      show "v \<le>p u"
+        using \<open>max_borderP (rev u) (rev w)\<close> \<open>v \<le>b w\<close> border_rev_conv max_borderP_D_max' pref_rev_suf_iff by metis
+    qed
+  qed
+qed
+
+lemma max_borderP_rev_conv: "max_borderP (rev u) (rev w) \<longleftrightarrow> max_borderP u w"
+  using max_borderP_rev max_borderP_rev[of "rev u" "rev w", unfolded rev_rev_ident] by blast
+
+definition max_border :: "'a list \<Rightarrow> 'a list" where
+  "max_border w = (THE u. (max_borderP u w))"
+
+lemma max_border_ex: "max_borderP (max_border w) w"
+proof-
+  obtain u where "max_borderP u w"
+    using max_borderP_exE.
+  show "max_borderP (max_border w) w"
+  proof (unfold max_border_def, rule theI[of "\<lambda> x. max_borderP x w", OF \<open>max_borderP u w\<close>])
+    fix v assume "max_borderP v w"
+    show "v = u"
+    proof (cases "bordered w")
+      assume "bordered w"
+      hence "u \<noteq> \<epsilon>" and "v \<noteq> \<epsilon>"
+        using \<open>max_borderP u w\<close> \<open>max_borderP v w\<close>  bordered_max_border_nemp by blast+
+      then show ?thesis
+        using \<open>max_borderP u w\<close> \<open>max_borderP v w\<close> unfolding max_borderP_def border_def
+        using prefix_order.eq_iff by blast
+    next
+      assume "\<not> bordered w"
+      then show "v = u"
+        using \<open>max_borderP u w\<close> \<open>max_borderP v w\<close> unbordered_max_border_emp by blast
+    qed
+  qed
+qed
+
+lemma max_borderP_max_border: assumes  "max_borderP u w" shows "max_border w = u"
+proof (cases "bordered w")
+  assume "bordered w"
+  from bordered_max_border_nemp[OF this \<open>max_borderP u w\<close>] bordered_max_border_nemp[OF this max_border_ex]
+  have "u \<noteq> \<epsilon>" and "max_border w \<noteq> \<epsilon>" by blast+
+  from max_borderP_border[OF \<open>max_borderP u w\<close> \<open>u \<noteq> \<epsilon>\<close>] max_borderP_border[OF max_border_ex \<open>max_border w \<noteq> \<epsilon>\<close>]
+  have "u \<le>b w" and "max_border w \<le>b w" by blast+
+  from max_borderP_D_max[OF \<open>max_borderP u w\<close> \<open>max_border w \<le>b w\<close>] max_borderP_D_max[OF max_border_ex \<open>u \<le>b w\<close>]
+  have "max_border w \<le>p u" and "u \<le>p max_border w" by blast+
+  thus "max_border w = u" 
+    by force
+next
+  assume "\<not> bordered w"
+  from unbordered_max_border_emp[OF this \<open>max_borderP u w\<close>] unbordered_max_border_emp[OF this max_border_ex]
+  show "max_border w = u"
+    by simp
+qed  
+
+lemma max_border_len_rev: "\<^bold>|max_border u\<^bold>| =  \<^bold>|max_border (rev u)\<^bold>|"
+  by (cases "u = \<epsilon>", simp, metis length_rev max_borderP_max_border max_borderP_rev_conv max_border_ex)
+
+lemma max_border_border: assumes "bordered w" shows "max_border w \<le>b w"
+  using max_border_ex bordered_max_border_nemp[OF assms, of "max_border w"]
+  unfolding max_borderP_def border_def by blast
+
+theorem max_border_border':  "max_border w \<noteq> \<epsilon> \<Longrightarrow> max_border w \<le>b w"
+  using max_borderP_border max_border_ex  by blast 
+
+lemma max_border_sing_emp: "max_border [a] = \<epsilon>"
+  using max_border_ex[THEN unbordered_max_border_emp[OF sing_not_bordered]] by fast
+
+lemma max_border_suf: "max_border w \<le>s w"
+  using max_borderP_D_suf max_border_ex by auto
+
+lemma max_border_nemp_neq: "w \<noteq> \<epsilon> \<Longrightarrow> max_border w \<noteq> w"
+  by (simp add: max_borderP_D_neq max_border_ex) 
+
+lemma max_borderI: assumes "u \<noteq> w" and "u \<le>p w" and "u \<le>s w" and "\<forall> v. v \<le>b w \<longrightarrow> v \<le>p u"
+  shows "max_border w = u"
+  using assms max_border_ex 
+  by (intro max_borderP_max_border, unfold max_borderP_def border_def, blast)
+
+lemma max_border_less_len: assumes "w \<noteq> \<epsilon>" shows "\<^bold>|max_border w\<^bold>| < \<^bold>|w\<^bold>|"
+  using assms border_len(3) leI list.size(3) max_border_border' npos_len by metis
+
+theorem max_border_max_pref: assumes "u \<le>b w" shows "u \<le>p max_border w"
+  using  max_borderP_D_max[OF max_border_ex \<open>u \<le>b w\<close>]. 
+
+theorem max_border_max_suf: assumes "u \<le>b w" shows "u \<le>s max_border w"
+  using  max_borderP_D_max'[OF max_border_ex \<open>u \<le>b w\<close>]. 
+
+lemma bordered_max_bord_nemp_conv[code]: "bordered w \<longleftrightarrow> max_border w \<noteq> \<epsilon>"
+  using bordered_max_border_nemp max_border_ex unbordered_max_border_emp by blast
+
+lemma max_bord_take: "max_border w = take \<^bold>|max_border w\<^bold>| w"
+proof (cases "bordered w")
+  assume "bordered w"
+  from borderD_pref[OF max_border_border[OF this]]
+  show "max_border w = take \<^bold>|max_border w\<^bold>| w"
+    by (simp add: pref_take)
+next 
+  assume "\<not> bordered w"
+  hence "max_border w = \<epsilon>"
+    using bordered_max_bord_nemp_conv by blast
+  thus "max_border w = take \<^bold>|max_border w\<^bold>| w"
+    by simp
+qed
+
+
+subsection \<open>The shortest period\<close>
+
+fun min_period_root :: "'a list \<Rightarrow> 'a list" ("\<pi>") where
+  "min_period_root w = take (LEAST n. period w n) w"
+
+definition min_period :: "'a list \<Rightarrow> nat" where
+  "min_period w = \<^bold>|\<pi> w\<^bold>|"
+
+lemma min_per_emp[simp]: "\<pi> \<epsilon> = \<epsilon>"
+  by simp
+
+lemma min_per_zero[simp]: "min_period \<epsilon> = 0"
+  by (simp add: min_period_def)
+
+
+lemma min_per_per: "w \<noteq> \<epsilon> \<Longrightarrow> period w (min_period w)"
+  unfolding min_period_def min_period_root.simps 
+  using len_is_per LeastI_ex period_def root_period by metis 
+
+lemma min_per_pos: "w \<noteq> \<epsilon> \<Longrightarrow> 0 < min_period w"
+  using min_per_per by auto
+
+lemma min_per_len:  "min_period w \<le> \<^bold>|w\<^bold>|"
+  unfolding min_period_def  using len_is_per Least_le by simp 
+
+lemmas min_per_root_len = min_per_len[unfolded min_period_def] 
+
+lemma min_per_sing: "min_period [a] = 1"
+  using min_per_pos[of "[a]"] min_per_len[of "[a]"] by simp
+
+lemma min_per_root_per_root: assumes "w \<noteq> \<epsilon>" shows "w \<le>p (\<pi> w)\<^sup>\<omega>"
+  using LeastI_ex assms len_is_per min_period_root.elims period_def by metis
+
+lemma min_per_pref: "\<pi> w \<le>p w"
+  unfolding  min_period_root.simps using take_is_prefix by blast
+
+lemma min_per_nemp: "w \<noteq> \<epsilon> \<Longrightarrow> \<pi> w \<noteq> \<epsilon>"
+  using min_per_root_per_root per_eq by blast
+
+lemma min_per_min: assumes "w \<le>p r\<^sup>\<omega>" shows "\<pi> w \<le>p r"
+proof (cases "w = \<epsilon>", simp)
+  assume "w \<noteq> \<epsilon>"
+  have "period w \<^bold>|\<pi> w\<^bold>|"
+    using \<open>w \<noteq> \<epsilon>\<close> min_per_root_per_root root_period by blast
+  have "period w \<^bold>|r\<^bold>|"
+    using \<open>w \<noteq> \<epsilon>\<close> assms root_period by blast
+  from Least_le[of "\<lambda> n. period w n", OF this]
+  have "\<^bold>|\<pi> w\<^bold>| \<le> \<^bold>|r\<^bold>|"
+    unfolding  min_period_root.simps using dual_order.trans len_take1 by metis 
+  with pref_trans[OF  min_per_pref per_rootD[OF \<open>w \<le>p r\<^sup>\<omega>\<close>]] 
+  show "\<pi> w \<le>p r" 
+    using pref_prod_le by blast
+qed
+
+lemma lq_min_per_pref:  "\<pi> w\<inverse>\<^sup>>w \<le>p w"
+  unfolding same_prefix_prefix[of "\<pi> w" _ w, symmetric]  lq_pref[OF min_per_pref] using per_rootD[OF min_per_root_per_root] 
+  by (cases "w = \<epsilon>", simp)
+
+lemma max_bord_emp: "max_border \<epsilon> = \<epsilon>"
+  by (simp add: max_borderP_of_nemp max_border_ex)
+
+theorem min_per_max_border: "\<pi> w \<cdot> max_border w = w"
+proof (cases "w = \<epsilon>", simp add:  max_bord_emp)
+  assume "w \<noteq> \<epsilon>"
+  have "max_border w = (\<pi> w)\<inverse>\<^sup>>w"      
+  proof (intro max_borderI)
+    show "\<pi> w\<inverse>\<^sup>>w \<noteq> w" 
+      using  min_per_nemp[OF \<open>w \<noteq> \<epsilon>\<close>]  lq_pref[OF min_per_pref]  append_self_conv2 by metis 
+    show "\<pi> w\<inverse>\<^sup>>w \<le>s w"
+      using lq_suf_suf[OF min_per_pref].
+    show "\<pi> w\<inverse>\<^sup>>w \<le>p w"
+      using lq_min_per_pref by blast 
+    show "\<forall>v. v \<le>b w \<longrightarrow> v \<le>p \<pi> w\<inverse>\<^sup>>w"
+    proof (rule allI, rule impI)                     
+      fix v assume "v \<le>b w"
+      have "w \<le>p (w\<^sup><\<inverse>v)\<^sup>\<omega>"
+        using per_border \<open>v \<le>b w\<close> border_per_root[OF \<open>v \<le>b w\<close>] border_rq_nemp[OF \<open>v \<le>b w\<close>] period_root_def by blast
+      from min_per_min[OF this]
+      have "\<pi> w \<le>p w\<^sup><\<inverse>v".  
+      from pref_rq_suf_lq[OF borderD_suf[OF \<open>v \<le>b w\<close>] this]
+      have "v \<le>s \<pi> w\<inverse>\<^sup>>w".
+      from  suf_pref_eq[OF this] ruler[OF borderD_pref[OF \<open>v \<le>b w\<close>] \<open>\<pi> w\<inverse>\<^sup>>w \<le>p w\<close>]
+      show "v \<le>p \<pi> w\<inverse>\<^sup>>w" 
+        by blast
+    qed
+  qed
+  thus ?thesis
+    using lq_pref[OF min_per_pref, of w] by simp 
+qed
+
+lemma min_per_len_diff: "min_period w = \<^bold>|w\<^bold>| - \<^bold>|max_border w\<^bold>|"
+  unfolding min_period_def  using lenarg[OF min_per_max_border,unfolded lenmorph,of w] by linarith 
+
+lemma min_per_root_take [code]: "\<pi> w = take (\<^bold>|w\<^bold>| - \<^bold>|max_border w\<^bold>|) w"
+  using cancel_right max_border_suf min_per_max_border suffix_take by metis
 
 section \<open>Primitive words\<close>
 
 text\<open>If a word $w$ is not a non-trivial power of some other word, we say it is primitive.\<close>
 
 definition primitive :: "'a list \<Rightarrow> bool"
   where  "primitive u = (\<forall> r k. r\<^sup>@k = u \<longrightarrow> k = 1)"
 
-lemma primI: "(\<And> r k. r\<^sup>@k = u \<Longrightarrow> k = 1) \<Longrightarrow> primitive u"
+lemma primI[intro]: "(\<And> r k. r\<^sup>@k = u \<Longrightarrow> k = 1) \<Longrightarrow> primitive u"
   by (simp add: primitive_def)
 
 lemma prim_nemp: "primitive u \<Longrightarrow> u \<noteq> \<epsilon>"
 proof-
   have "u = \<epsilon> \<Longrightarrow> \<epsilon>\<^sup>@0 = u" by simp
   thus "primitive u \<Longrightarrow> u \<noteq> \<epsilon>"
     using primitive_def zero_neq_one by blast
 qed
 
+lemma emp_not_prim[simp]: "\<not> primitive \<epsilon>"
+  using prim_nemp by blast
+
 lemma prim_exp_one: "primitive u \<Longrightarrow> r\<^sup>@k = u \<Longrightarrow> k = 1"
   using primitive_def by blast
 
+lemma pow_nemp_imprim[intro]: "2 \<le> k  \<Longrightarrow> \<not> primitive (u\<^sup>@k)"
+  using prim_exp_one by fastforce
+
+lemma pow_not_prim: "\<not> primitive (u\<^sup>@Suc(Suc k))" 
+  using prim_exp_one by fastforce
+
+lemma pow_non_prim: "k \<noteq> 1 \<Longrightarrow> \<not> primitive (w\<^sup>@k)"
+  using prim_exp_one
+  by auto
+
 lemma prim_exp_eq: "primitive u \<Longrightarrow> r\<^sup>@k = u \<Longrightarrow> u = r"
   using prim_exp_one power_one_right by blast
 
+lemma prim_per_div: assumes "primitive v" and "n \<noteq> 0" and "n \<le> \<^bold>|v\<^bold>|" and "period v (gcd \<^bold>|v\<^bold>| n)"
+  shows "n = \<^bold>|v\<^bold>|"
+proof-
+  have "gcd \<^bold>|v\<^bold>| n dvd \<^bold>|v\<^bold>|"
+    by simp
+  from  prim_exp_eq[OF \<open>primitive v\<close> per_div[OF this \<open>period v (gcd \<^bold>|v\<^bold>| n)\<close>]]
+  have "gcd \<^bold>|v\<^bold>| n = \<^bold>|v\<^bold>|"
+    using take_len[OF le_trans[OF gcd_le2_nat[OF \<open>n \<noteq> 0\<close>] \<open>n \<le> \<^bold>|v\<^bold>|\<close>], of "\<^bold>|v\<^bold>|"]  by presburger
+  from gcd_le2_nat[OF \<open>n \<noteq> 0\<close>, of "\<^bold>|v\<^bold>|", unfolded this] \<open>n \<le> \<^bold>|v\<^bold>|\<close>
+  show "n = \<^bold>|v\<^bold>|" by force
+qed
+
 lemma prim_triv_root: "primitive u \<Longrightarrow> u \<in> t* \<Longrightarrow> t = u"
   using prim_exp_eq unfolding root_def
   unfolding primitive_def root_def by fastforce
 
-lemma prim_comm_exp[elim]: assumes "primitive v" and "v\<cdot>u = u\<cdot>v" obtains k where "u = v\<^sup>@k"
-  using \<open>v\<cdot>u = u\<cdot>v\<close>[unfolded comm] prim_exp_eq[OF \<open>primitive v\<close>] by metis
-
-lemma pow_non_prim: "1 < k \<Longrightarrow> \<not> primitive (w\<^sup>@k)"
-  using prim_exp_one by auto
-
-lemma comm_non_prim: assumes "u \<noteq> \<epsilon>" "v \<noteq> \<epsilon>" "u\<cdot>v = v\<cdot>u" shows "\<not> primitive (u\<cdot>v)"
+lemma prim_comm_root: assumes "primitive r" and "u\<cdot>r = r\<cdot>u" shows "u \<in> r*"
+  using \<open>u\<cdot>r = r\<cdot>u\<close>[unfolded comm] prim_exp_eq[OF \<open>primitive r\<close>] rootI by metis
+
+lemma prim_comm_exp[elim]: assumes "primitive r" and "u\<cdot>r = r\<cdot>u" obtains k where "r\<^sup>@k = u"
+  using rootE[OF prim_comm_root[OF assms]].
+
+lemma comm_rootE: assumes  "x \<cdot> y = y \<cdot> x"
+  obtains  t where "x \<in>  t*" and "y \<in> t*"
+  using assms[unfolded comm_root] by blast
+
+lemma pow_prim_root: assumes "w\<^sup>@k = r\<^sup>@Suc q" and "primitive r"
+  shows "w \<in> r*"
+  using pow_comm_comm[OF \<open>w\<^sup>@k = r\<^sup>@Suc q\<close>[symmetric] Suc_not_Zero] prim_comm_root[OF \<open>primitive r\<close>] by force
+
+lemma prim_root_drop_exp: assumes "k \<noteq> 0" and  "primitive r" and  "u\<^sup>@k \<in> r*"
+  shows "u \<in> r*"
+  using pow_comm_comm[of u k r, OF _ \<open>k \<noteq> 0\<close>, THEN  prim_comm_root[OF \<open>primitive r\<close>]]
+    \<open>u\<^sup>@k \<in> r*\<close>[unfolded root_def] unfolding root_def by metis
+
+lemma prim_card_set: assumes "primitive u" and "\<^bold>|u\<^bold>| \<noteq> 1" shows "1 < card (set u)"
+  using \<open>\<^bold>|u\<^bold>| \<noteq> 1\<close> \<open>primitive u\<close> pow_non_prim[OF \<open>\<^bold>|u\<^bold>| \<noteq> 1\<close>, of "[hd u]"]
+  by (elim not_le_imp_less[OF contrapos_nn] card_set_le_1_imp_hd_pow[elim_format]) simp
+
+lemma comm_not_prim: assumes "u \<noteq> \<epsilon>" "v \<noteq> \<epsilon>" "u\<cdot>v = v\<cdot>u" shows "\<not> primitive (u\<cdot>v)"
 proof-
   obtain t k m where "u = t\<^sup>@k"  "v = t\<^sup>@m"
     using \<open>u\<cdot>v = v\<cdot>u\<close>[unfolded comm] by blast
   show ?thesis using pow_non_prim[of "k+m" "t"]
-    unfolding \<open>u = t\<^sup>@k\<close> \<open>v = t\<^sup>@m\<close> pow_add_list[of t k m]
+    unfolding \<open>u = t\<^sup>@k\<close> \<open>v = t\<^sup>@m\<close> add_exps[of t k m]
     using nemp_pow[OF \<open>u \<noteq> \<epsilon>\<close>[unfolded \<open>u = t\<^sup>@k\<close>]] nemp_pow[OF \<open>v \<noteq> \<epsilon>\<close>[unfolded \<open>v = t\<^sup>@m\<close>]]
     by linarith
 qed
 
 lemma prim_rotate_conv: "primitive w \<longleftrightarrow> primitive (rotate n w)"
 proof
   assume "primitive w" show "primitive (rotate n w)"
   proof (rule primI)
-  fix r k assume "r\<^sup>@k = rotate n w"
-  obtain l where "(rotate l r)\<^sup>@k = w"
-    using rotate_back[of n w, folded \<open>r\<^sup>@k = rotate n w\<close>, unfolded rotate_pow_comm] by blast
-  from prim_exp_one[OF \<open>primitive w\<close> this]
-  show "k = 1".
-qed
+    fix r k assume "r\<^sup>@k = rotate n w"
+    obtain l where "(rotate l r)\<^sup>@k = w"
+      using rotate_back[of n w, folded \<open>r\<^sup>@k = rotate n w\<close>, unfolded rotate_pow_comm] by blast
+    from prim_exp_one[OF \<open>primitive w\<close> this]
+    show "k = 1".
+  qed
 next
   assume "primitive (rotate n w)"  show "primitive w"
-   proof (rule primI)
-     fix r k assume "r\<^sup>@k = w"
-     from prim_exp_one[OF \<open>primitive (rotate n w)\<close>, OF rotate_pow_comm[of n r k, unfolded this, symmetric]]
-     show "k = 1".
-   qed
- qed
+  proof (rule primI)
+    fix r k assume "r\<^sup>@k = w"
+    from prim_exp_one[OF \<open>primitive (rotate n w)\<close>, OF rotate_pow_comm[of n r k, unfolded this, symmetric]]
+    show "k = 1".
+  qed
+qed
 
 lemma non_prim: assumes "\<not> primitive w" and "w \<noteq> \<epsilon>"
   obtains r k where "r \<noteq> \<epsilon>" and "1 < k" and "r\<^sup>@k = w" and "w \<noteq> r"
 proof-
   from \<open>\<not> primitive w\<close>[unfolded primitive_def]
   obtain r k where "k \<noteq> 1" and "r\<^sup>@k = w"  by blast
   have "r \<noteq> \<epsilon>"
     using \<open>w \<noteq> \<epsilon>\<close> \<open>r\<^sup>@k = w\<close> emp_pow by blast
   have "k \<noteq> 0"
     using \<open>w \<noteq> \<epsilon>\<close> \<open>r\<^sup>@k = w\<close> pow_zero[of r] by meson
   have "w \<noteq> r"
     using \<open>k \<noteq> 1\<close>[folded eq_pow_exp[OF \<open>r \<noteq> \<epsilon>\<close>, of k 1, unfolded \<open>r \<^sup>@ k = w\<close>]] by simp
   show thesis
     using that[OF \<open>r \<noteq> \<epsilon>\<close> _ \<open>r\<^sup>@k = w\<close> \<open>w \<noteq> r\<close>] \<open>k \<noteq> 0\<close> \<open>k \<noteq> 1\<close> less_linear by blast
 qed
 
 lemma prim_no_rotate: assumes "primitive w" and "0 < n" and "n < \<^bold>|w\<^bold>|"
   shows "rotate n w \<noteq> w"
 proof
   assume "rotate n w = w"
   have "take n w \<cdot> drop n w = drop n w \<cdot> take n w"
     using rotate_append[of "take n w" "drop n w"]
     unfolding take_len[OF less_imp_le_nat[OF \<open>n < \<^bold>|w\<^bold>|\<close>]] append_take_drop_id \<open>rotate n w = w\<close>.
   have "take n w \<noteq> \<epsilon>" "drop n w \<noteq> \<epsilon>"
     using \<open>0 < n\<close> \<open>n < \<^bold>|w\<^bold>|\<close> by auto+
   from \<open>primitive w\<close> show False
-    using comm_non_prim[OF \<open>take n w \<noteq> \<epsilon>\<close> \<open>drop n w \<noteq> \<epsilon>\<close> \<open>take n w \<cdot> drop n w = drop n w \<cdot> take n w\<close>, unfolded append_take_drop_id]
+    using comm_not_prim[OF \<open>take n w \<noteq> \<epsilon>\<close> \<open>drop n w \<noteq> \<epsilon>\<close> \<open>take n w \<cdot> drop n w = drop n w \<cdot> take n w\<close>, unfolded append_take_drop_id]
     by simp
 qed
 
 lemma no_rotate_prim: assumes  "w \<noteq> \<epsilon>" and "\<And> n. 0 < n \<Longrightarrow> n < \<^bold>|w\<^bold>| \<Longrightarrow> rotate n w \<noteq> w"
   shows "primitive w"
 proof (rule ccontr)
   assume "\<not> primitive w"
   from non_prim[OF this \<open>w \<noteq> \<epsilon>\<close>]
-    obtain r l where "r \<noteq> \<epsilon>" and "1 < l" and "r\<^sup>@l = w" and "w \<noteq> r" by blast
-    have "rotate \<^bold>|r\<^bold>| w = w"
-      using rotate_root_self[of r l, unfolded \<open>r\<^sup>@l = w\<close>].
-    moreover have "0 < \<^bold>|r\<^bold>|"
-      by (simp add: \<open>r \<noteq> \<epsilon>\<close>)
-    moreover have "\<^bold>|r\<^bold>| < \<^bold>|w\<^bold>|"
-      unfolding pow_len[of r l, unfolded \<open>r\<^sup>@l = w\<close>]  using  \<open>1 < l\<close> \<open>0 < \<^bold>|r\<^bold>|\<close>  by auto
-   ultimately show False
-     using assms(2) by blast
+  obtain r l where "r \<noteq> \<epsilon>" and "1 < l" and "r\<^sup>@l = w" and "w \<noteq> r" by blast
+  have "rotate \<^bold>|r\<^bold>| w = w"
+    using rotate_root_self[of r l, unfolded \<open>r\<^sup>@l = w\<close>].
+  moreover have "0 < \<^bold>|r\<^bold>|"
+    by (simp add: \<open>r \<noteq> \<epsilon>\<close>)
+  moreover have "\<^bold>|r\<^bold>| < \<^bold>|w\<^bold>|"
+    unfolding pow_len[of r l, unfolded \<open>r\<^sup>@l = w\<close>]  using  \<open>1 < l\<close> \<open>0 < \<^bold>|r\<^bold>|\<close>  by auto
+  ultimately show False
+    using assms(2) by blast
 qed
 
 corollary prim_iff_rotate: assumes "w \<noteq> \<epsilon>" shows
-   "primitive w \<longleftrightarrow> (\<forall> n. 0 < n \<and> n < \<^bold>|w\<^bold>| \<longrightarrow> rotate n w \<noteq> w)"
+  "primitive w \<longleftrightarrow> (\<forall> n. 0 < n \<and> n < \<^bold>|w\<^bold>| \<longrightarrow> rotate n w \<noteq> w)"
   using no_rotate_prim[OF \<open>w \<noteq> \<epsilon>\<close>] prim_no_rotate by blast
 
 lemma prim_sing: "primitive [a]"
   using prim_iff_rotate[of "[a]"] by fastforce
 
+lemma sing_pow_conv [simp]: "[u] = t\<^sup>@k \<longleftrightarrow> t = [u] \<and> k = 1"
+  using pow_non_prim pow_one' prim_sing by metis 
+
 lemma prim_rev_iff[reversal_rule]: "primitive (rev u) \<longleftrightarrow> primitive u"
   unfolding primitive_def[reversed] using primitive_def..
 
+lemma prim_map_prim: "primitive (map f ws) \<Longrightarrow> primitive ws"
+  unfolding primitive_def using map_pow  by metis
+
+lemma inj_map_prim: assumes "inj_on f A" and "u \<in> lists A" and
+  "primitive u"         
+shows "primitive (map f u)"
+  using prim_map_prim[of "the_inv_into A f" "map f u", folded inj_map_inv[OF assms(1-2)], OF assms(3)].
+
+lemma prim_map_iff [reversal_rule]:
+  assumes "inj f" shows "primitive (map f ws) = primitive (ws)"
+  using inj_map_prim[of _ UNIV, unfolded lists_UNIV, OF \<open>inj f\<close> UNIV_I]
+    prim_map_prim by (intro iffI)
+
+lemma prim_concat_prim: "primitive (concat ws) \<Longrightarrow> primitive ws" 
+  unfolding primitive_def using concat_pow by metis
+
 section \<open>Primitive root\<close>
 
 text\<open>Given a non-empty word $w$ which is not primitive, it is natural to look for the shortest $u$ such that $w = u^k$.
 Such a word is primitive, and it is the primitive root of $w$.\<close>
 
 definition primitive_rootP :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" ("_ \<in>\<^sub>p _ *" [51,51] 60)
   where  "primitive_rootP x r = (x \<noteq> \<epsilon> \<and> x \<in> r* \<and> primitive r)"
 
-lemma prim_rootD [dest]: "x \<in>\<^sub>p r* \<Longrightarrow> x \<in> r*"
+lemma primrootD [dest]: "x \<in>\<^sub>p r* \<Longrightarrow> x \<in> r*"
   unfolding primitive_rootP_def by (elim conjE)
 
-lemma prim_rootI [intro]: "u \<noteq> \<epsilon> \<Longrightarrow>  u \<in> r* \<Longrightarrow> primitive r \<Longrightarrow> u \<in>\<^sub>p r*"
+lemma primrootD_nemp [dest]: "x \<in>\<^sub>p r* \<Longrightarrow> x \<noteq> \<epsilon>"
+  unfolding primitive_rootP_def by (elim conjE)
+
+lemma primrootD_prim [dest]: "x \<in>\<^sub>p r* \<Longrightarrow> primitive r"
+  unfolding primitive_rootP_def by (elim conjE)
+
+lemma primrootI [intro]: "u \<noteq> \<epsilon> \<Longrightarrow>  u \<in> r* \<Longrightarrow> primitive r \<Longrightarrow> u \<in>\<^sub>p r*"
   unfolding primitive_rootP_def by (intro conjI)
 
-lemma prim_root_rev_conv [reversal_rule]: "rev x \<in>\<^sub>p rev r* \<longleftrightarrow>  x \<in>\<^sub>p r*"
+lemma primroot_rev_conv [reversal_rule]: "rev x \<in>\<^sub>p rev r* \<longleftrightarrow>  x \<in>\<^sub>p r*"
   unfolding primitive_rootP_def[reversed] using primitive_rootP_def..
 
-fun primitive_root :: "'a list \<Rightarrow> 'a list" ("\<rho>") where "primitive_root x = (THE r. x \<in>\<^sub>p r*)"
+definition primitive_root :: "'a list \<Rightarrow> 'a list" ("\<rho>") where "primitive_root x = (THE r. x \<in>\<^sub>p r*)"
+definition primitive_root_exp :: "'a list \<Rightarrow> nat" ("e\<^sub>\<rho>") where "primitive_root_exp x = (THE k. x = (\<rho> x)\<^sup>@k)"
 
 lemma primrootE: assumes "x \<in>\<^sub>p r*"
   obtains k where "k \<noteq> 0" and "r\<^sup>@k = x"
   using assms  unfolding primitive_rootP_def root_def using nemp_pow[of r] by auto
 
 lemma primroot_of_root: "\<lbrakk> x \<noteq> \<epsilon>; x \<in> u*; u \<in>\<^sub>p r*\<rbrakk> \<Longrightarrow> x \<in>\<^sub>p r*"
   unfolding primitive_rootP_def using root_trans by blast
 
 lemma comm_prim: assumes "primitive r" and  "primitive s" and "r\<cdot>s = s\<cdot>r"
-      shows "r = s"
+  shows "r = s"
   using \<open>r\<cdot>s = s\<cdot>r\<close>[unfolded comm] assms[unfolded primitive_def, rule_format] by metis
 
 lemma primroot_ex: assumes "x \<noteq> \<epsilon>" shows "\<exists> r k.  x \<in>\<^sub>p r* \<and> k \<noteq> 0 \<and> x = r\<^sup>@k"
   using \<open>x \<noteq> \<epsilon>\<close>
 proof(induction "\<^bold>|x\<^bold>|" arbitrary: x rule: less_induct)
   case less
   then show "\<exists> r k.  x \<in>\<^sub>p r* \<and> k \<noteq> 0 \<and> x = r\<^sup>@k"
   proof (cases "primitive x")
     assume "\<not> primitive x"
     from non_prim[OF this \<open>x \<noteq> \<epsilon>\<close>]
     obtain r l where "r \<noteq> \<epsilon>" and "1 < l" and "r\<^sup>@l = x" and "x \<noteq> r" by blast
     then obtain pr k where "r \<in>\<^sub>p pr*" "k \<noteq> 0" "r = pr\<^sup>@k"
       using \<open>x \<noteq> \<epsilon>\<close> less.hyps rootI root_shorter by blast
     hence "x \<in>\<^sub>p pr*"
       using \<open>r \<^sup>@ l = x\<close> less.prems primroot_of_root rootI by blast
     show "\<exists> r k.  x \<in>\<^sub>p r* \<and> k \<noteq> 0 \<and> x = r\<^sup>@k"
       using  \<open>x \<in>\<^sub>p pr*\<close>[unfolded primitive_rootP_def root_def]
-        \<open>x \<in>\<^sub>p pr *\<close> nemp_pow by blast
+        \<open>x \<in>\<^sub>p pr *\<close> nemp_pow by metis
   next
     assume "primitive x"
     have "x \<in>\<^sub>p x*"
-      by (simp add: \<open>primitive x\<close> less.prems prim_rootI self_root)
+      by (simp add: \<open>primitive x\<close> less.prems primrootI self_root)
     thus "\<exists> r k.  x \<in>\<^sub>p r* \<and> k \<noteq> 0 \<and> x = r\<^sup>@k"
       by force
   qed
 qed
 
 lemma primroot_exE: assumes"x \<noteq> \<epsilon>"
   obtains r k where "primitive r" and "k \<noteq> 0" and "x = r\<^sup>@k"
   using assms primitive_rootP_def primroot_ex[OF \<open> x \<noteq> \<epsilon>\<close>] by blast
 
 text\<open>Uniqueness of the primitive root follows from the following lemma\<close>
 
 lemma primroot_unique: assumes "u \<in>\<^sub>p r*" shows "\<rho> u = r"
 proof-
   obtain kr where "kr \<noteq> 0" and "r\<^sup>@kr = u"
     using primrootE[OF \<open>u \<in>\<^sub>p r*\<close>].
   have "u \<in>\<^sub>p s* \<Longrightarrow> s = r" for s
   proof-
-   fix s assume "u \<in>\<^sub>p s*"
+    fix s assume "u \<in>\<^sub>p s*"
     obtain ks where "ks \<noteq> 0" and "s\<^sup>@ks = u"
       using primrootE[OF \<open>u \<in>\<^sub>p s*\<close>].
     obtain t where "s \<in> t*" and "r \<in> t*"
       using comm_rootE[OF pow_comm_comm[of r kr s ks, OF _ \<open>kr \<noteq> 0\<close>, unfolded \<open>r\<^sup>@kr = u\<close> \<open>s\<^sup>@ks = u\<close>, OF refl]].
     have "primitive r" and "primitive s"
       using \<open>u \<in>\<^sub>p r *\<close> \<open>u \<in>\<^sub>p s *\<close> primitive_rootP_def by blast+
     from prim_exp_eq[OF \<open>primitive r\<close>, of t] prim_exp_eq[OF \<open>primitive s\<close>, of t]
     show "s = r"
       using rootE[OF \<open>s \<in> t*\<close>, of "s=r"] rootE[OF \<open>r \<in> t*\<close>, of "r = t"] by fastforce
   qed
   from the_equality[of "\<lambda> r. u \<in>\<^sub>p r*",OF \<open>u \<in>\<^sub>p r*\<close> this]
   show "\<rho> u = r"
-    by auto
-qed
-
-lemma prim_self_root: "primitive x \<Longrightarrow> \<rho> x  = x"
-  using prim_nemp prim_rootI primroot_unique self_root by blast
-
-text\<open>Existence and uniqueness of the primitive root justifies the function @{term "\<rho>"}: it indeed yields the primitive root of a nonempty word.\<close>
+     unfolding primitive_root_def by auto
+qed
+
+lemma prim_self_root[intro]: "primitive x \<Longrightarrow> \<rho> x  = x"
+  using prim_nemp primrootI primroot_unique self_root by metis
+
+lemma primroot_exp_unique: assumes "u \<noteq> \<epsilon>" and "(\<rho> u)\<^sup>@k = u" shows "e\<^sub>\<rho> u = k"
+  unfolding primitive_root_exp_def 
+proof (rule the_equality)
+  show "u = (\<rho> u)\<^sup>@k" using \<open>(\<rho> u)\<^sup>@k = u\<close>[symmetric].
+  have "\<rho> u \<noteq> \<epsilon>"
+    using assms by force
+  show "ka = k" if "u = \<rho> u \<^sup>@ ka" for ka
+    using eq_pow_exp[OF \<open>\<rho> u \<noteq> \<epsilon>\<close>, of k ka, folded \<open>u = (\<rho> u)\<^sup>@k\<close> that] by blast   
+qed
+
+text\<open>Existence and uniqueness of the primitive root justifies the function @{term primitive_root}: it indeed yields the primitive root of a nonempty word.\<close>
 
 lemma primroot_is_primroot[intro]: assumes "x \<noteq> \<epsilon>" shows "x \<in>\<^sub>p (\<rho> x)*"
   using primroot_ex[OF \<open>x \<noteq> \<epsilon>\<close>] primroot_unique[of x]
   by force
 
 lemma primroot_is_root[intro]: "x \<noteq> \<epsilon> \<Longrightarrow> x \<in> (\<rho> x)*"
   using primroot_is_primroot by auto
 
-lemma primrootI [intro]: assumes "x \<noteq> \<epsilon>" shows primroot_prim: "primitive (\<rho> x)" and primroot_nemp: "\<rho> x \<noteq> \<epsilon>"
-  using assms prim_nemp primitive_rootP_def by blast+
-
-lemma primroot_root: assumes "u \<noteq> \<epsilon>" "u \<in> q*" shows "\<rho> q = \<rho> u"
+lemma primroot_expE[elim]: assumes "x \<noteq> \<epsilon>" obtains k where "(\<rho> x)\<^sup>@Suc k = x"
+  using primroot_is_root[OF \<open>x \<noteq> \<epsilon>\<close>, unfolded root_def] pow_zero assms not0_implies_Suc by metis 
+
+lemma primroot_expE': obtains k where "(\<rho> x)\<^sup>@k = x"
+  using primroot_expE pow_zero by metis
+
+lemma primroot_exp_eq: "u \<noteq> \<epsilon> \<Longrightarrow> (\<rho> u)\<^sup>@(e\<^sub>\<rho> u) = u"
+  using primroot_expE'[of u "\<rho> u \<^sup>@ e\<^sub>\<rho> u = u"] primroot_exp_unique by blast 
+
+lemma primroot_exp_nemp: "u \<noteq> \<epsilon> \<Longrightarrow> e\<^sub>\<rho> u \<noteq> 0"
+  using  primroot_exp_eq nemp_pow by metis 
+
+(* lemma prim_root_power [elim]: assumes "x \<noteq> \<epsilon>" obtains i where "(\<rho> x)\<^sup>@(Suc i) = x" *)
+(* using primrootD[OF primroot_is_primroot[OF \<open>x \<noteq> \<epsilon>\<close>], unfolded root_def] assms pow_zero[of "\<rho> x"] not0_implies_Suc *)
+(* by metis *)
+
+(* lemma primrootI[intro]: assumes "x \<noteq> \<epsilon>" shows primroot_prim: "primitive (\<rho> x)" and primroot_nemp: "\<rho> x \<noteq> \<epsilon>" *)
+
+lemma primroot_prim[intro]:  "x \<noteq> \<epsilon> \<Longrightarrow> primitive (\<rho> x)" 
+  using primitive_rootP_def by blast
+
+lemma primroot_nemp[intro!]: "x \<noteq> \<epsilon> \<Longrightarrow> \<rho> x \<noteq> \<epsilon>" 
+  using prim_nemp by blast
+
+lemma primroot_idemp[simp]: "x \<noteq> \<epsilon> \<Longrightarrow> \<rho> (\<rho> x) = \<rho> x"
+  using prim_self_root by blast
+
+lemma prim_primroot_conv: assumes "w \<noteq> \<epsilon>" shows "primitive w \<longleftrightarrow> \<rho> w = w"
+  using assms prim_self_root primroot_prim[OF \<open>w \<noteq> \<epsilon>\<close>] by fastforce
+
+lemma not_prim_primroot_expE: assumes "\<not> primitive w" and "w \<noteq> \<epsilon>"
+  obtains k where "\<rho> w \<^sup>@Suc (Suc k) = w"
+proof-
+  obtain k' where "(\<rho> w)\<^sup>@Suc k' = w"
+    using primroot_expE[OF \<open>w \<noteq> \<epsilon>\<close>] by blast
+  hence "k' \<noteq> 0"
+    using \<open>\<not> primitive w\<close>[unfolded prim_primroot_conv[OF \<open>w \<noteq> \<epsilon>\<close>]] pow_one by metis 
+  then obtain k where "Suc k = k'"
+    using not0_implies_Suc by auto  
+  from that[OF \<open>(\<rho> w)\<^sup>@Suc k' = w\<close>[folded \<open>Suc k = k'\<close>]]
+  show thesis.
+qed
+
+lemma not_prim_primroot_expE': assumes "\<not> primitive x" and "x \<noteq> \<epsilon>"
+  obtains k where "\<rho> x\<^sup>@k = x" and "2 \<le> k" 
+  using not_prim_primroot_expE[OF assms] Suc_le_mono numeral_2_eq_2 zero_le by metis 
+
+lemma not_prim_expE: assumes "\<not> primitive x" and "x \<noteq> \<epsilon>"
+  obtains r k where "primitive r" and "2 \<le> k" and "r\<^sup>@k = x"
+  using not_prim_primroot_expE'[OF assms] primroot_prim[OF \<open>x \<noteq> \<epsilon>\<close>] by metis    
+
+lemma not_prim_pow: assumes "\<not> primitive u" obtains k r where  "r\<^sup>@k = u" and "2 \<le> k"
+  using assms 
+proof (cases)
+  assume "u \<noteq> \<epsilon>" 
+  from not_prim_primroot_expE'[OF assms this that]
+  show thesis.
+qed (simp add: that[of \<epsilon> 2])
+
+lemma not_prim_pow': assumes "\<not> primitive u" obtains k r where  "r\<^sup>@Suc (Suc k) = u"
+proof (cases)
+  assume "u \<noteq> \<epsilon>" 
+  from not_prim_primroot_expE[OF assms this that]
+  show thesis. 
+qed (simp add: that[of \<epsilon> 2])
+
+lemma primroot_root: assumes "u \<noteq> \<epsilon>" and "u \<in> q*" shows "\<rho> q = \<rho> u"
   using primroot_unique[OF primroot_of_root[OF \<open>u \<noteq> \<epsilon>\<close> \<open>u \<in> q*\<close> primroot_is_primroot, OF root_nemp[OF \<open>u \<noteq> \<epsilon>\<close> \<open>u \<in> q*\<close>]], symmetric].
 
-lemma primroot_len_mult: assumes "u \<noteq> \<epsilon>" "u \<in> q*" obtains k where "\<^bold>|q\<^bold>| = k*\<^bold>|\<rho> u\<^bold>|"
+lemma pow_prim_primroot: "w \<noteq> \<epsilon> \<Longrightarrow> primitive r \<Longrightarrow> w = r\<^sup>@k \<Longrightarrow> \<rho> w = r"
+  using prim_self_root primroot_root rootI by metis
+
+lemma primroot_len_mult: assumes "u \<noteq> \<epsilon>" and "u \<in> q*"
+  obtains k where "\<^bold>|q\<^bold>| = k*\<^bold>|\<rho> u\<^bold>|"
   using primroot_is_primroot[OF root_nemp[OF \<open>u \<noteq> \<epsilon>\<close> \<open>u \<in> q*\<close>], unfolded primroot_root[OF \<open>u \<noteq> \<epsilon>\<close> \<open>u \<in> q*\<close>]
       primitive_rootP_def] root_len[of q "\<rho> u"] by blast
 
-lemma primroot_shorter_root: assumes "u \<noteq> \<epsilon>" "u \<in> q*" shows "\<^bold>|\<rho> u\<^bold>| \<le> \<^bold>|q\<^bold>|"
-  using quotient_smaller[OF root_nemp[OF \<open>u \<noteq> \<epsilon>\<close> \<open>u \<in> q*\<close>, folded length_0_conv], of _ "\<^bold>|\<rho> u\<^bold>|"]
-    primroot_len_mult[OF \<open>u \<noteq> \<epsilon>\<close> \<open>u \<in> q*\<close>] by blast
-
+lemma primroot_shorter_root: assumes "u \<noteq> \<epsilon>" and "u \<in> q*" shows "\<^bold>|\<rho> u\<^bold>| \<le> \<^bold>|q\<^bold>|"
+  unfolding primroot_root[OF assms, symmetric] using root_shorter_eq root_nemp[OF assms]
+  by blast 
+  
 lemma primroot_shortest_root: assumes "u \<noteq> \<epsilon>" shows "\<^bold>|\<rho> u\<^bold>| = (LEAST d. (\<exists> r. (u \<in> r*) \<and> \<^bold>|r\<^bold>| = d))"
   using  Least_equality[of "\<lambda> k. (\<exists> r. (u \<in> r*) \<and> \<^bold>|r\<^bold>| = k)" "\<^bold>|\<rho> u\<^bold>|"]
 proof
   show "\<exists>r. u \<in> r* \<and> \<^bold>|r\<^bold>| = \<^bold>|\<rho> u\<^bold>|"
     using assms primitive_rootP_def primroot_is_primroot by blast
   show "\<And>y. \<exists>r. u \<in> r* \<and> \<^bold>|r\<^bold>| = y \<Longrightarrow> \<^bold>|\<rho> u\<^bold>| \<le> y"
-    using assms primroot_shorter_root by fastforce
-qed
-
-lemma primroot_shorter_eq: "u \<noteq> \<epsilon> \<Longrightarrow> \<^bold>|\<rho> u\<^bold>| \<le> \<^bold>|u\<^bold>|"
+    using assms primroot_shorter_root by auto 
+qed
+
+lemma primroot_len_le: "u \<noteq> \<epsilon> \<Longrightarrow> \<^bold>|\<rho> u\<^bold>| \<le> \<^bold>|u\<^bold>|"
   using primroot_shorter_root self_root by auto
 
-
 lemma primroot_take: assumes "u \<noteq> \<epsilon>" shows "\<rho> u = (take ( \<^bold>|\<rho> u\<^bold>| ) u)"
 proof-
   obtain k where "(\<rho> u)\<^sup>@k = u" and "k \<noteq> 0"
-    using primrootE[OF primroot_is_primroot[OF \<open>u \<noteq> \<epsilon>\<close>]].
+    using primroot_expE[OF \<open>u \<noteq> \<epsilon>\<close>] by blast
   show "\<rho> u = (take ( \<^bold>|\<rho> u\<^bold>| ) u)"
     using take_root[of _ "(\<rho> u)", OF \<open>k \<noteq> 0\<close>, unfolded \<open>(\<rho> u)\<^sup>@k = u\<close>].
 qed
 
 lemma primroot_take_shortest: assumes "u \<noteq> \<epsilon>" shows "\<rho> u = (take (LEAST d. (\<exists> r. (u \<in> r*) \<and> \<^bold>|r\<^bold>| = d)) u)"
   using primroot_take[OF assms, unfolded primroot_shortest_root[OF assms]].
 
 lemma primroot_rotate_comm: assumes "w \<noteq> \<epsilon>" shows "\<rho> (rotate n w) = rotate n (\<rho> w)"
 proof-
-  obtain l where  "w = (\<rho> w)\<^sup>@l"
-    using pow_zero primrootE primroot_is_primroot by metis
+  obtain l where  "(\<rho> w)\<^sup>@l = w"
+    using primroot_expE[OF \<open>w \<noteq> \<epsilon>\<close>].
   hence "rotate n w \<in> (rotate n (\<rho> w))*"
     using rotate_pow_comm root_def by metis
   moreover have "rotate n w \<noteq> \<epsilon>"
     using assms by auto
   moreover have "primitive (rotate n (\<rho> w))"
     using assms prim_rotate_conv primitive_rootP_def primroot_is_primroot by blast
   ultimately have "rotate n w \<in>\<^sub>p (rotate n (\<rho> w))*"
     unfolding primitive_rootP_def  by blast
   thus  ?thesis
     using primroot_unique by blast
 qed
 
-lemma primrootI1 [intro]: assumes pow: "u = r\<^sup>@(Suc k)" and prim: "primitive r" shows "\<rho> u = r"
+lemma primroot_rotate: "\<rho> w = r \<longleftrightarrow> \<rho> (rotate (k*\<^bold>|r\<^bold>|) w) = r" (is "?L \<longleftrightarrow> ?R")
+proof(cases "w = \<epsilon>", simp add: rotate_is_Nil_conv[of "k*\<^bold>|r\<^bold>|" w])
+  case False
+  show ?thesis
+    unfolding primroot_rotate_comm[OF \<open>w \<noteq> \<epsilon>\<close>, of "k*\<^bold>|r\<^bold>|"]
+    using length_rotate[of "k*\<^bold>|r\<^bold>|" "\<rho> w"] mod_mult_self2_is_0[of k "\<^bold>|r\<^bold>|"]
+      rotate_id[of "k*\<^bold>|r\<^bold>|" "\<rho> w"]
+    by metis
+qed
+
+lemma primrootI1[intro]: assumes pow: "u = r\<^sup>@(Suc k)" and prim: "primitive r" shows "\<rho> u = r"
 proof-
   have "u \<noteq> \<epsilon>"
     using pow prim prim_nemp by auto
   have "u \<in> r*"
     using pow rootI by blast
   show "\<rho> u = r"
-    using primroot_unique[OF prim_rootI[OF \<open>u \<noteq> \<epsilon>\<close> \<open>u \<in> r*\<close> \<open>primitive r\<close>]].
-qed
-
-lemma prim_root_power [elim]: assumes "x \<noteq> \<epsilon>" obtains i where "(\<rho> x)\<^sup>@(Suc i) = x"
-  using prim_rootD[OF primroot_is_primroot[OF \<open>x \<noteq> \<epsilon>\<close>], unfolded root_def] assms pow_zero[of "\<rho> x"] not0_implies_Suc
-  by metis
-
-lemma prim_root_cases: obtains "u = \<epsilon>" | "primitive u" | "\<^bold>|\<rho> u\<^bold>| < \<^bold>|u\<^bold>|"
-  using primroot_is_primroot[THEN prim_rootD[of u "\<rho> u"]]
-        primroot_prim[of u] root_shorter[of u "\<rho> u"] by fastforce
+    using primroot_unique[OF primrootI[OF \<open>u \<noteq> \<epsilon>\<close> \<open>u \<in> r*\<close> \<open>primitive r\<close>]].
+qed
+
+lemma prim_primroot_cases: obtains "u = \<epsilon>" | "primitive u" | "\<^bold>|\<rho> u\<^bold>| < \<^bold>|u\<^bold>|"
+  using primroot_is_primroot[THEN primrootD[of u "\<rho> u"]]
+    primroot_prim[of u] root_shorter[of u "\<rho> u"] by fastforce
 
 text\<open>We also have the standard characterization of commutation for nonempty words.\<close>
 
-theorem comm_primroots: assumes "u \<noteq> \<epsilon>" "v \<noteq> \<epsilon>" shows "u \<cdot> v = v \<cdot> u \<longleftrightarrow> \<rho> u = \<rho> v"
+theorem comm_primroots: assumes "u \<noteq> \<epsilon>" and "v \<noteq> \<epsilon>" shows "u \<cdot> v = v \<cdot> u \<longleftrightarrow> \<rho> u = \<rho> v"
 proof
   assume "u \<cdot> v = v \<cdot> u"
   then obtain t where "u \<in> t*" and "v \<in> t*"
     using comm_root by blast
   show "\<rho> u = \<rho> v"
     using primroot_root[OF \<open>v \<noteq> \<epsilon>\<close> \<open>v \<in> t*\<close>, unfolded primroot_root[OF \<open>u \<noteq> \<epsilon>\<close> \<open>u \<in> t*\<close>]].
 next
   assume "\<rho> u = \<rho> v"
-  show "u \<cdot> v = v \<cdot> u"
+  then show "u \<cdot> v = v \<cdot> u"
     using primroot_is_primroot[OF \<open>u \<noteq> \<epsilon>\<close>, unfolded \<open>\<rho> u = \<rho> v\<close>] primroot_is_primroot[OF \<open>v \<noteq> \<epsilon>\<close>] unfolding primitive_rootP_def
-    comm_root  by blast
-qed
+      comm_root by blast
+qed
+
+lemma comm_primroots': "u \<noteq> \<epsilon> \<Longrightarrow> v \<noteq> \<epsilon> \<Longrightarrow> u \<cdot> v = v \<cdot> u \<Longrightarrow> \<rho> u = \<rho> v"
+  by (simp add: comm_primroots)
+
+lemma pow_primroot: assumes "x \<noteq> \<epsilon>" shows "\<rho> (x\<^sup>@Suc k) = \<rho> x"
+  using  comm_primroots'[OF nemp_Suc_pow_nemp, OF assms assms, of k, folded pow_Suc2 pow_Suc] by blast
+
+lemma comm_primroot_exp: assumes "v \<noteq> \<epsilon>" and "u \<cdot> v = v \<cdot> u"
+  obtains n where "(\<rho> v)\<^sup>@n = u"
+proof(cases)
+  assume "u = \<epsilon>" thus thesis using that power_0 by blast
+next
+  assume "u \<noteq> \<epsilon>" thus thesis using that[OF primroot_expE'] \<open>u \<cdot> v = v \<cdot> u\<close>[unfolded comm_primroots[OF \<open>u \<noteq> \<epsilon>\<close> \<open>v \<noteq> \<epsilon>\<close>]] by metis 
+qed
+
+lemma comm_primrootE: assumes  "x \<cdot> y = y \<cdot> x"
+  obtains  t where "x \<in>  t*" and "y \<in> t*" and "primitive t" 
+  using comm_primroots assms emp_all_roots prim_sing primroot_is_root primroot_prim by metis 
+
+lemma comm_primroot_conv: assumes "v \<noteq> \<epsilon>" shows "u \<cdot> v = v \<cdot> u \<longleftrightarrow> u \<cdot> \<rho> v = \<rho> v \<cdot> u"
+  using assms
+proof (cases "u = \<epsilon>", simp)
+  assume "u \<noteq> \<epsilon>"
+  from comm_primroots[of _ "\<rho> v", OF \<open>u \<noteq> \<epsilon>\<close>, unfolded primroot_idemp[OF \<open>v \<noteq> \<epsilon>\<close>], OF primroot_nemp[OF \<open>v \<noteq> \<epsilon>\<close>]]
+  show ?thesis
+    using comm_primroots[OF \<open>u \<noteq> \<epsilon>\<close> \<open>v \<noteq> \<epsilon>\<close>] by blast
+qed
+
+lemma comm_primroot [simp, intro]: "u \<cdot> \<rho> u = \<rho> u \<cdot> u"
+  using comm_primroot_conv by blast 
+
+lemma comp_primroot_conv': assumes "u \<noteq> \<epsilon>" and "v \<noteq> \<epsilon>" shows "u \<cdot> v = v \<cdot> u \<longleftrightarrow> \<rho> u \<cdot> \<rho> v = \<rho> v \<cdot> \<rho> u"
+  unfolding comm_primroot_conv[OF \<open>v \<noteq> \<epsilon>\<close>, symmetric] eq_commute[of "u \<cdot> v"] eq_commute[of "\<rho> u \<cdot> v"]
+  unfolding comm_primroot_conv[OF \<open>u \<noteq> \<epsilon>\<close>, symmetric]..
+
+lemma per_root_primroot: "w \<le>p r \<cdot> w \<Longrightarrow> r \<noteq> \<epsilon> \<Longrightarrow> w \<le>p \<rho> r \<cdot> w"
+  using comm_primroot_conv root_comm_root by metis
 
 lemma prim_comm_short_emp: assumes "primitive p" and "u\<cdot>p=p\<cdot>u" and "\<^bold>|u\<^bold>| < \<^bold>|p\<^bold>|"
   shows "u = \<epsilon>"
 proof (rule ccontr)
   assume "u \<noteq> \<epsilon>"
   from \<open>u \<cdot> p = p \<cdot> u\<close>
   have "\<rho> u = \<rho> p"
     unfolding comm_primroots[OF \<open>u \<noteq> \<epsilon>\<close> prim_nemp, OF \<open>primitive p\<close>].
   have "\<rho> u = p"
     using prim_self_root[OF \<open>primitive p\<close>, folded \<open>\<rho> u = \<rho> p\<close>].
   from \<open>\<^bold>|u\<^bold>| < \<^bold>|p\<^bold>|\<close>[folded this]
   show False
-    using primroot_shorter_eq[OF \<open>u \<noteq> \<epsilon>\<close>] by auto
+    using primroot_len_le[OF \<open>u \<noteq> \<epsilon>\<close>] by auto
+qed
+
+lemma primroot_pref: "x \<noteq> \<epsilon> \<Longrightarrow> \<rho> x \<le>p x"
+  using primroot_take take_is_prefix by metis
+
+lemma primroot_rev[reversal_rule]: "u \<noteq> \<epsilon> \<Longrightarrow> \<rho> (rev u) = rev (\<rho> u)"
+  using primroot_rev_conv primroot_is_primroot primroot_unique by metis 
+
+lemma primroot_suf: assumes "x \<noteq> \<epsilon>" shows "\<rho> x \<le>s x"
+  using primroot_pref[reversed, OF \<open>x \<noteq> \<epsilon>\<close>]  unfolding primroot_rev[OF \<open>x \<noteq> \<epsilon>\<close>] suf_rev_pref_iff.  
+
+lemma per_le_prim_iff:
+  assumes "u \<le>p p \<cdot> u" and "p \<noteq> \<epsilon>" and "2 * \<^bold>|p\<^bold>| \<le> \<^bold>|u\<^bold>|"
+  shows "primitive u \<longleftrightarrow> u \<cdot> p \<noteq> p \<cdot> u"
+proof
+  have "\<^bold>|p\<^bold>| < \<^bold>|u\<^bold>|" using  \<open>2 * \<^bold>|p\<^bold>| \<le> \<^bold>|u\<^bold>|\<close>
+      nemp_len[OF \<open>p \<noteq> \<epsilon>\<close>] by linarith
+  with \<open>p \<noteq> \<epsilon>\<close> 
+  show "primitive u \<Longrightarrow> u \<cdot> p \<noteq> p \<cdot> u"
+    by (intro notI, elim notE) (rule prim_comm_short_emp[OF _ sym])
+  show "u \<cdot> p \<noteq> p \<cdot> u \<Longrightarrow> primitive u"
+  proof (elim swap[of "_ = _"], elim not_prim_pow)
+    fix k z assume "2 \<le> k" and eq: "z \<^sup>@ k = u"
+    from this(1) lenarg[OF this(2)] \<open>2 * \<^bold>|p\<^bold>| \<le> \<^bold>|u\<^bold>|\<close>
+    have "\<^bold>|z\<^bold>| + \<^bold>|p\<^bold>| \<le> \<^bold>|u\<^bold>|"
+      by (elim at_least2_Suc) (simp only: power_Suc lenmorph[of z])
+    with \<open>u \<le>p p \<cdot> u\<close> have "z \<cdot> p = p \<cdot> z"
+      by (rule two_pers[rotated 1]) (simp flip: eq pow_comm)
+    from comm_add_exp[OF this, of k]
+    show "u \<cdot> p = p \<cdot> u" unfolding eq.
+  qed
+qed
+
+
+subsection \<open>Primitivity and the shortest period\<close>
+
+lemma min_per_primitive: assumes "w \<noteq> \<epsilon>" shows "primitive (\<pi> w)"
+proof-
+  have "\<rho>(\<pi> w) \<noteq> \<epsilon>"
+    using assms min_per_nemp primroot_nemp by blast 
+  obtain k where "\<pi> w = (\<rho> (\<pi> w))\<^sup>@k" 
+    using pow_zero primroot_expE by metis
+  from rootI[of "\<rho> (\<pi> w)" k, folded this]
+  have "w \<le>p (\<rho> (\<pi> w))\<^sup>\<omega>"
+    using  min_per_root_per_root[OF assms, THEN per_root_trans] by blast   
+  from pow_pref_root_one[OF _ \<open>\<rho>(\<pi> w) \<noteq> \<epsilon>\<close>, of k, folded  \<open>\<pi> w = (\<rho> (\<pi> w))\<^sup>@k\<close>, OF _ min_per_min[OF this]]  
+  have "k = 1"                                             
+    using  \<open>\<pi> w = (\<rho> (\<pi> w))\<^sup>@k\<close> min_per_nemp[OF \<open>w \<noteq> \<epsilon>\<close>] pow_zero[of "\<rho> (\<pi> w)"] by metis  
+  show "primitive (\<pi> w)"
+    using primroot_prim[OF \<open>\<rho> (\<pi> w) \<noteq> \<epsilon>\<close>, folded \<open>\<pi> w = (\<rho> (\<pi> w))\<^sup>@k\<close>[unfolded \<open>k = 1\<close> One_nat_def pow_one]].
+qed
+
+lemma min_per_short_primroot: assumes "w \<noteq> \<epsilon>" and "(\<rho> w)\<^sup>@k = w" and "k \<noteq> 1" 
+  shows "\<pi> w = \<rho> w"
+proof-
+  obtain k' where  "k = Suc (Suc k')"
+    using \<open>w \<noteq> \<epsilon>\<close> and \<open>(\<rho> w)\<^sup>@k = w\<close>  \<open>k \<noteq> 1\<close>[unfolded One_nat_def] nemp_pow not0_implies_Suc by metis  
+  have "w \<le>p (\<rho> w)\<^sup>\<omega>"
+    using assms(1) assms(2) per_drop_exp root_self by metis
+  have "w \<le>p (\<pi> w)\<^sup>\<omega>"         
+    using assms(1) min_per_root_per_root by blast
+  have "\<pi> w \<le>p \<rho> w"
+    using min_per_min[OF \<open>w \<le>p (\<rho> w)\<^sup>\<omega>\<close>].
+  from  prefix_length_le[OF this]
+  have "\<^bold>|\<pi> w\<^bold>| + \<^bold>|\<rho> w\<^bold>| \<le> \<^bold>|w\<^bold>|"
+    using lenarg[OF \<open>(\<rho> w)\<^sup>@k =w\<close>, unfolded pow_len] unfolding \<open>k = Suc (Suc k')\<close> by simp
+  from two_pers_root[OF \<open>w \<le>p (\<pi> w)\<^sup>\<omega>\<close> \<open>w \<le>p (\<rho> w)\<^sup>\<omega>\<close> this]
+  have "\<pi> w \<cdot> \<rho> w = \<rho> w \<cdot> \<pi> w".
+  from this[unfolded comm_primroots[OF per_rootD'[OF \<open>w \<le>p \<pi> w\<^sup>\<omega>\<close>] per_rootD'[OF \<open>w \<le>p \<rho> w\<^sup>\<omega>\<close>]]]
+  show "\<pi> w = \<rho> w"
+    unfolding prim_self_root[of "\<rho> w", OF primroot_prim[OF \<open>w \<noteq> \<epsilon>\<close>]]
+      prim_self_root[of "\<pi> w", OF min_per_primitive[OF \<open>w \<noteq> \<epsilon>\<close>]].
+qed
+
+
+lemma primitive_iff_per: "primitive w \<longleftrightarrow> w \<noteq> \<epsilon> \<and> (\<pi> w = w \<or> \<pi> w \<cdot> w \<noteq> w \<cdot> \<pi> w)"
+proof
+  assume "primitive w"
+  show "w \<noteq> \<epsilon> \<and> (\<pi> w = w \<or> \<pi> w \<cdot> w \<noteq> w \<cdot> \<pi> w)"
+  proof (standard, simp add: prim_nemp \<open>primitive w\<close>, intro verit_or_neg(1))
+    assume "\<pi> w \<cdot> w = w \<cdot> \<pi> w" 
+    from comm_prim[OF min_per_primitive[OF prim_nemp[OF \<open>primitive w\<close>]] \<open>primitive w\<close> this]
+    show "\<pi> w  = w".
+  qed
+next
+  assume asm: "w \<noteq> \<epsilon> \<and> (\<pi> w = w \<or> \<pi> w \<cdot> w \<noteq> w \<cdot> \<pi> w)"
+  have "w \<noteq> \<epsilon>" and imp: "\<pi> w \<cdot> w = w \<cdot> \<pi> w \<Longrightarrow> \<pi> w = w"
+    using asm by blast+
+  obtain k where "(\<rho> w)\<^sup>@Suc k = w" 
+    using primroot_expE[OF \<open>w \<noteq> \<epsilon>\<close>] by metis 
+  show "primitive w"
+  proof (cases "k = 0")
+    assume "k = 0"
+    from \<open>(\<rho> w)\<^sup>@Suc k = w\<close>[unfolded this, unfolded pow_one] \<open>w \<noteq> \<epsilon>\<close>
+    show "primitive w"
+      by (simp add: prim_primroot_conv)
+  next 
+    assume "k \<noteq> 0"
+    hence "Suc k \<noteq> 1" by simp
+    from imp[unfolded min_per_short_primroot[OF \<open>w \<noteq> \<epsilon>\<close> \<open>(\<rho> w)\<^sup>@Suc k = w\<close> this]] 
+    have "\<rho> w = w"
+      using power_commutes[symmetric, of "\<rho> w" "Suc k", unfolded \<open>\<rho> w \<^sup>@Suc k = w\<close>] by blast 
+    thus "primitive w"
+      using prim_primroot_conv[OF \<open>w \<noteq> \<epsilon>\<close>] by simp
+  qed
 qed
 
 section \<open>Conjugation\<close>
 
 text\<open>Two words $x$ and $y$ are conjugated if one is a rotation of the other.
 Or, equivalently, there exists $z$ such that
 \[
 xz = zy.
 \]
 \<close>
 
 definition conjugate ("_ \<sim> _" [50,50] 51) where "u \<sim> v \<equiv> \<exists>r s. r \<cdot> s = u \<and> s \<cdot> r = v"
 
-lemma conjug_rev_conv [reversal_rule]: "rev u \<sim> rev v \<longleftrightarrow> u \<sim> v"
-  unfolding conjugate_def[reversed] using conjugate_def by blast
-
-lemma conjug_rotate_iff: "u \<sim> v \<longleftrightarrow> (\<exists> n. v = rotate n u)"
-  unfolding conjugate_def
-  using rotate_drop_take[of _ u] takedrop[of _ u] rotate_append
-  by metis
-
-lemma conjugI [intro]: "r \<cdot> s = u \<Longrightarrow> s \<cdot> r = v \<Longrightarrow> u \<sim> v"
-  unfolding conjugate_def by (intro exI conjI)
-
-lemma conjugI' [intro!]: "r \<cdot> s \<sim> s \<cdot> r"
-  unfolding conjugate_def by (intro exI conjI, standard+)
 
 lemma conjugE [elim]:
   assumes "u \<sim> v"
   obtains r s where "r \<cdot> s = u" and "s \<cdot> r = v"
-  using assms unfolding conjugate_def by (elim exE conjE)
+  using assms unfolding conjugate_def  by (elim exE conjE)
+
+lemma conjugE_nemp[elim]:
+  assumes "u \<sim> v" and "u \<noteq> \<epsilon>"
+  obtains r s where "r \<cdot> s = u" and "s \<cdot> r = v" and "s \<noteq> \<epsilon>"
+  using assms unfolding conjugate_def  
+proof (cases "u = v", simp add: that[OF _ _ \<open>u \<noteq> \<epsilon>\<close>])
+  assume "u \<noteq> v"
+  obtain r s where "r \<cdot> s = u" and "s \<cdot> r = v" using conjugE[OF \<open>u \<sim> v\<close>].
+  hence "s \<noteq> \<epsilon>" using \<open>u \<noteq> v\<close> by force
+  thus thesis using that[OF \<open>r \<cdot> s = u\<close> \<open>s \<cdot> r = v\<close>] by blast
+qed
 
 lemma conjugE1 [elim]:
   assumes "u \<sim> v"
   obtains r where "u \<cdot> r = r \<cdot> v"
 proof -
   obtain r s where u: "r \<cdot> s = u" and v: "s \<cdot> r = v" using assms..
   have "u \<cdot> r = r \<cdot> v" unfolding u[symmetric] v[symmetric] using rassoc.
   then show thesis by fact
 qed
 
+lemma conjug_rev_conv [reversal_rule]: "rev u \<sim> rev v \<longleftrightarrow> u \<sim> v"
+  unfolding conjugate_def[reversed] using conjugate_def by blast
+
+lemma conjug_rotate_iff: "u \<sim> v \<longleftrightarrow> (\<exists> n. v = rotate n u)"
+  unfolding conjugate_def
+  using rotate_drop_take[of _ u] takedrop[of _ u] rotate_append
+  by metis
+
+lemma rotate_conjug: "w \<sim> rotate n w"
+  using conjug_rotate_iff by auto 
+
+lemma conjug_rotate_iff_le: 
+  shows "u \<sim> v \<longleftrightarrow> (\<exists> n \<le> \<^bold>|u\<^bold>| - 1. v = rotate n u)" 
+proof
+  show "\<exists>n \<le> \<^bold>|u\<^bold>| - 1 . v = rotate n u \<Longrightarrow> u \<sim> v"
+    using conjug_rotate_iff by auto
+next
+  assume "u \<sim> v"
+  thus "\<exists> n \<le> \<^bold>|u\<^bold>| - 1. v = rotate n u"
+  proof (cases "u = \<epsilon>", simp, blast)
+    assume "u \<noteq> \<epsilon>"
+    obtain r s where "r \<cdot> s = u" and  "s \<cdot> r = v" and "s \<noteq> \<epsilon>" 
+      using conjugE_nemp[OF \<open>u \<sim> v\<close> \<open>u \<noteq> \<epsilon>\<close>].
+    hence "v = rotate \<^bold>|r\<^bold>| u"
+      using rotate_append[of r s] by argo 
+    moreover have "\<^bold>|r\<^bold>| \<le> \<^bold>|u\<^bold>| - 1" 
+      using lenarg[OF \<open>r \<cdot> s = u\<close>, unfolded lenmorph] nemp_len[OF \<open>s \<noteq> \<epsilon>\<close>] by linarith
+    ultimately  show "\<exists>n \<le> \<^bold>|u\<^bold>| - 1. v = rotate n u"
+      by blast
+  qed
+qed
+
+lemma conjugI [intro]: "r \<cdot> s = u \<Longrightarrow> s \<cdot> r = v \<Longrightarrow> u \<sim> v"
+  unfolding conjugate_def by (intro exI conjI)
+
+lemma conjugI' [intro!]: "r \<cdot> s \<sim> s \<cdot> r"
+  unfolding conjugate_def by (intro exI conjI, standard+)
+
 lemma conjug_refl: "u \<sim> u"
   by standard+
 
-lemma conjug_sym [sym]: "u \<sim> v \<Longrightarrow> v \<sim> u"
-  by (elim conjugE, intro conjugI) assumption+
+lemma conjug_sym[sym]: "u \<sim> v \<Longrightarrow> v \<sim> u"
+  by (elim conjugE, intro conjugI) assumption
+
+lemma conjug_swap: "u \<sim> v \<longleftrightarrow> v \<sim> u" 
+  by blast
 
 lemma conjug_nemp_iff: "u \<sim> v \<Longrightarrow> u = \<epsilon> \<longleftrightarrow> v = \<epsilon>"
   by (elim conjugE1, intro iffI) simp+
 
 lemma conjug_len: "u \<sim> v  \<Longrightarrow> \<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|"
   by (elim conjugE, hypsubst, rule swap_len)
 
 lemma pow_conjug:
   assumes eq: "t\<^sup>@i \<cdot> r \<cdot> u = t\<^sup>@k" and t: "r \<cdot> s = t"
   shows "u \<cdot> t\<^sup>@i \<cdot> r = (s \<cdot> r)\<^sup>@k"
 proof -
-  have "t\<^sup>@i \<cdot> r \<cdot> u \<cdot> t\<^sup>@i \<cdot> r = t\<^sup>@i \<cdot> t\<^sup>@k \<cdot> r" unfolding eq[unfolded lassoc] lassoc append_same_eq pow_comm..
+  have "t\<^sup>@i \<cdot> r \<cdot> u \<cdot> t\<^sup>@i \<cdot> r = t\<^sup>@i \<cdot> t\<^sup>@k \<cdot> r" unfolding eq[unfolded lassoc] lassoc append_same_eq pows_comm..
   also have "\<dots>  = t\<^sup>@i \<cdot> r \<cdot> (s \<cdot> r)\<^sup>@k" unfolding conjug_pow[OF rassoc, symmetric] t..
   finally show "u \<cdot> t\<^sup>@i \<cdot> r = (s \<cdot> r)\<^sup>@k" unfolding same_append_eq.
 qed
 
+lemma conjug_set: assumes "u \<sim> v" shows "set u = set v" 
+  using conjugE[OF \<open>u \<sim> v\<close>] set_append Un_commute by metis
+
+lemma conjug_concat_conjug: "xs \<sim> ys \<Longrightarrow> concat xs \<sim> concat ys"
+  unfolding conjugate_def using concat_morph by metis
+
 text\<open>The solution of the equation
 \[
 xz = zy
 \]
 is given by the next lemma.
 \<close>
 
 lemma conjug_eqE [elim, consumes 2]:
   assumes eq: "x \<cdot> z = z \<cdot> y" and "x \<noteq> \<epsilon>"
   obtains u v k where "u \<cdot> v = x" and "v \<cdot> u = y" and "(u \<cdot> v)\<^sup>@k \<cdot> u = z" and "v \<noteq> \<epsilon>"
 proof -
   have "z \<le>p x \<cdot> z" using eq[symmetric]..
-  from this \<open>x \<noteq> \<epsilon>\<close> have "z \<le>p x\<^sup>\<omega>"..
+  from this and \<open>x \<noteq> \<epsilon>\<close> have "z \<le>p x\<^sup>\<omega>"..
   then obtain k u where "x\<^sup>@k \<cdot> u = z" and "u <p x"..
   from \<open>u <p x\<close> obtain v where x: "u \<cdot> v = x" and "v \<noteq> \<epsilon>"..
   have z: "(u\<cdot>v)\<^sup>@k \<cdot> u = z" unfolding x \<open>x\<^sup>@k \<cdot> u = z\<close>..
   have "z \<cdot> y = (u\<cdot>v) \<cdot> ((u\<cdot>v)\<^sup>@k \<cdot> u)" unfolding z unfolding x eq..
-  also have "\<dots> = (u\<cdot>v)\<^sup>@k \<cdot> u \<cdot> (v \<cdot> u)" unfolding lassoc pow_commutes_list[symmetric]..
+  also have "\<dots> = (u\<cdot>v)\<^sup>@k \<cdot> u \<cdot> (v \<cdot> u)" unfolding lassoc pow_comm[symmetric]..
   finally have y: "v \<cdot> u = y" unfolding z[symmetric] rassoc same_append_eq..
   from x y z \<open>v \<noteq> \<epsilon>\<close> show thesis..
 qed
 
 theorem conjugation: assumes "x\<cdot>z = z\<cdot>y" and "x \<noteq> \<epsilon>"
   shows "\<exists> u v k. u \<cdot> v = x \<and> v \<cdot> u  = y \<and> (u \<cdot> v)\<^sup>@k \<cdot> u = z"
   using assms by blast
 
-lemma conjug_eq_prim_rootE [elim, consumes 2]:
+lemma conjug_eq_primrootE [elim, consumes 2]:
   assumes eq: "x \<cdot> z = z \<cdot> y" and "x \<noteq> \<epsilon>"
   obtains r s i n where
     "(r \<cdot> s)\<^sup>@Suc i = x" and
     "(s \<cdot> r)\<^sup>@Suc i = y" and
     "(r \<cdot> s)\<^sup>@n \<cdot> r = z" and
     "s \<noteq> \<epsilon>" and "primitive (r \<cdot> s)"
 proof -
   from \<open>x \<noteq> \<epsilon>\<close> obtain i where "(\<rho> x)\<^sup>@(Suc i) = x"..
   also have "z \<le>p x\<^sup>\<omega>" using prefI[OF \<open>x \<cdot> z = z \<cdot> y\<close>[symmetric]] \<open>x \<noteq> \<epsilon>\<close>..
   finally have "z \<le>p (\<rho> x)\<^sup>\<omega>" by (elim per_drop_exp)
   then obtain n r where "(\<rho> x)\<^sup>@n \<cdot> r = z" and "r <p \<rho> x"..
   from \<open>r <p \<rho> x\<close> obtain s where "r \<cdot> s = \<rho> x" and "s \<noteq> \<epsilon>"..
   define j where "j = Suc i"
   have x: "(r\<cdot>s)\<^sup>@j = x" unfolding \<open>r \<cdot> s = \<rho> x\<close> \<open>j = Suc i\<close> \<open>(\<rho> x)\<^sup>@(Suc i) = x\<close>..
-  have z: "(r\<cdot>s)\<^sup>@n \<cdot> r = z" unfolding \<open>r \<cdot> s = \<rho> x\<close> \<open>(\<rho> x)\<^sup>@n \<cdot> r = z\<close>..
-  have "z \<cdot> y = ((r\<cdot>s)\<^sup>@j \<cdot> (r\<cdot>s)\<^sup>@n) \<cdot> r" using eq[symmetric] unfolding rassoc x z.
-  also have "(r\<cdot>s)\<^sup>@j \<cdot> (r\<cdot>s)\<^sup>@n = (r\<cdot>s)\<^sup>@n \<cdot> (r\<cdot>s)\<^sup>@j" using pow_comm.
-  also have "\<dots> \<cdot> r = (r\<cdot>s)\<^sup>@n \<cdot> r \<cdot> (s\<cdot>r)\<^sup>@j" unfolding rassoc unfolding shift_pow..
-  finally have y: "y = (s\<cdot>r)\<^sup>@j" unfolding z[symmetric] rassoc cancel.
+  have z: "(r\<cdot>s)\<^sup>@n \<cdot> r = z" unfolding \<open>r \<cdot> s = \<rho> x\<close> using  \<open>(\<rho> x)\<^sup>@n \<cdot> r = z\<close>.
+  have y: "y = (s\<cdot>r)\<^sup>@j"
+    using eq[symmetric, folded x z, unfolded lassoc pows_comm[of _ j], unfolded rassoc cancel,
+          unfolded shift_pow cancel]. 
   from \<open>x \<noteq> \<epsilon>\<close> have "primitive (r \<cdot> s)" unfolding \<open>r \<cdot> s = \<rho> x\<close>..
   with that x y z \<open>s \<noteq> \<epsilon>\<close>  show thesis unfolding \<open>j = Suc i\<close> by blast
 qed
 
-lemma conjug_eq_prim_root:
-  assumes "x \<cdot> z = z \<cdot> y" and "x \<noteq> \<epsilon>"
-  shows "\<exists> r s i n. (r \<cdot> s)\<^sup>@(Suc i) = x \<and> (s \<cdot> r)\<^sup>@(Suc i) = y \<and> (r \<cdot> s)\<^sup>@n \<cdot> r = z \<and> s \<noteq> \<epsilon> \<and> primitive (r \<cdot> s)"
-  using conjug_eq_prim_rootE[OF assms, of ?thesis] by blast
-
 lemma conjugI1 [intro]:
   assumes eq: "u \<cdot> r = r \<cdot> v"
   shows "u \<sim> v"
 proof (cases)
   assume "u = \<epsilon>"
   have "v = \<epsilon>" using eq unfolding \<open>u = \<epsilon>\<close> by simp
   show "u \<sim> v" unfolding \<open>u = \<epsilon>\<close> \<open>v = \<epsilon>\<close> using conjug_refl.
 next
   assume "u \<noteq> \<epsilon>"
   show "u \<sim> v" using eq \<open>u \<noteq> \<epsilon>\<close> by (cases rule: conjug_eqE, intro conjugI)
 qed
 
+lemma pow_conjug_conjug_conv: assumes "k \<noteq> 0" shows "u\<^sup>@k \<sim> v\<^sup>@k \<longleftrightarrow> u \<sim> v"
+proof 
+  assume "u \<^sup>@ k \<sim> v \<^sup>@ k"
+  obtain r s where "r \<cdot> s = u\<^sup>@k" and "s \<cdot> r = v\<^sup>@k" 
+    using conjugE[OF \<open>u\<^sup>@k \<sim> v\<^sup>@k\<close>].
+  hence "v\<^sup>@k = (rotate \<^bold>|r\<^bold>| u)\<^sup>@k"
+    using rotate_append rotate_pow_comm by metis 
+  hence "v = rotate \<^bold>|r\<^bold>| u"
+    using pow_eq_eq[OF _ \<open>k \<noteq> 0\<close>] by blast 
+  thus "u \<sim> v"
+    using rotate_conjug by blast
+next
+  assume "u \<sim> v"
+  obtain r s where "u = r \<cdot> s" and "v = s \<cdot> r" 
+    using conjugE[OF \<open>u \<sim> v\<close>] by metis
+  have "u\<^sup>@k \<cdot> r = r \<cdot> v\<^sup>@k"
+    unfolding \<open>u = r \<cdot> s\<close> \<open>v = s \<cdot> r\<close> shift_pow..
+  thus "u\<^sup>@k \<sim> v\<^sup>@k"   
+    using conjugI1 by blast 
+qed
+
 lemma conjug_trans [trans]:
   assumes uv: "u \<sim> v" and vw: "v \<sim> w"
-    shows "u \<sim> w"
+  shows "u \<sim> w"
   using assms  unfolding conjug_rotate_iff using rotate_rotate by blast
 
 lemma conjug_trans': assumes uv': "u \<cdot> r = r \<cdot> v" and vw': "v \<cdot> s = s \<cdot> w" shows "u \<cdot> (r \<cdot> s) = (r \<cdot> s) \<cdot> w"
 proof -
   have "u \<cdot> (r \<cdot> s) = (r \<cdot> v) \<cdot> s" unfolding uv'[symmetric] rassoc..
   also have "\<dots> = r \<cdot> (s \<cdot> w)" unfolding vw'[symmetric] rassoc..
   finally show "u \<cdot> (r \<cdot> s) = (r \<cdot> s) \<cdot> w" unfolding rassoc.
 qed
 
+lemma rotate_fac_pref: assumes "u \<le>f w"
+  obtains w' where "w' \<sim> w" and "u \<le>p w'"
+proof-
+  from facE[OF \<open>u \<le>f w\<close>]
+  obtain p s where "w = p \<cdot> u \<cdot> s".
+  from that[OF conjugI'[of "u \<cdot> s" p, unfolded rassoc, folded this] triv_pref]
+  show thesis.
+qed
+
+lemma rotate_into_pos_sq: assumes "s\<cdot>p \<le>f w\<cdot>w" and  "\<^bold>|s\<^bold>| \<le> \<^bold>|w\<^bold>|" and "\<^bold>|p\<^bold>| \<le> \<^bold>|w\<^bold>|"
+obtains w' where "w \<sim> w'" "p \<le>p w'" "s \<le>s w'"
+proof-
+  obtain pw where "pw\<cdot>s\<cdot>p \<le>p w\<cdot>w"
+    by (meson assms(1) fac_pref)
+  hence "pw \<cdot> s \<le>p w\<cdot> w"
+    unfolding lassoc prefix_def by force
+
+  hence "take \<^bold>|pw \<cdot> s\<^bold>| (w \<cdot> w) = pw \<cdot> s"
+    using pref_take by blast 
+
+  have "p \<le>p drop \<^bold>|pw \<cdot> s\<^bold>| (w \<cdot> w)"
+    using pref_drop[OF \<open>pw\<cdot>s\<cdot>p \<le>p w\<cdot>w\<close>[unfolded lassoc]] drop_pref  by metis
+
+  let ?w = "rotate \<^bold>|pw \<cdot> s\<^bold>| w"
+
+  have "\<^bold>|?w\<^bold>| = \<^bold>|w\<^bold>|" by auto 
+
+  have "rotate \<^bold>|pw \<cdot> s\<^bold>| (w \<cdot> w) = ?w \<cdot> ?w"
+    using rotate_pow_comm_two. 
+
+  hence eq: "?w \<cdot> ?w = (drop \<^bold>|pw \<cdot> s\<^bold>| (w \<cdot> w)) \<cdot> take \<^bold>|pw \<cdot> s\<^bold>| (w \<cdot> w)"
+    by (metis \<open>pw \<cdot> s \<le>p w \<cdot> w\<close> append_take_drop_id pref_take rotate_append) 
+
+  have "p \<le>p ?w" 
+    using pref_prod_le[OF _ \<open>\<^bold>|p\<^bold>| \<le> \<^bold>|w\<^bold>|\<close>[folded \<open>\<^bold>|?w\<^bold>| = \<^bold>|w\<^bold>|\<close>]]
+          prefix_prefix[OF \<open>p \<le>p drop \<^bold>|pw \<cdot> s\<^bold>| (w \<cdot> w)\<close>, of "take \<^bold>|pw \<cdot> s\<^bold>| (w \<cdot> w)", folded eq].
+     
+  have "s \<le>s ?w" 
+    using pref_prod_le[reversed, OF _ \<open>\<^bold>|s\<^bold>| \<le> \<^bold>|w\<^bold>|\<close>[folded \<open>\<^bold>|?w\<^bold>| = \<^bold>|w\<^bold>|\<close>], of ?w]
+    unfolding eq \<open>take \<^bold>|pw \<cdot> s\<^bold>| (w \<cdot> w) = pw \<cdot> s\<close> lassoc by blast 
+
+  show thesis
+    using that[OF rotate_conjug \<open>p \<le>p ?w\<close> \<open>s \<le>s ?w\<close>].
+qed
+
+lemma rotate_into_pref_sq: assumes "p \<le>f w\<cdot>w" and  "\<^bold>|p\<^bold>| \<le> \<^bold>|w\<^bold>|"
+obtains w' where "w \<sim> w'" "p \<le>p w'"
+  using rotate_into_pos_sq[of \<epsilon>, unfolded clean_emp, OF \<open>p \<le>f w\<cdot>w\<close> _ \<open>\<^bold>|p\<^bold>| \<le> \<^bold>|w\<^bold>|\<close>] by auto
+
+lemmas rotate_into_suf_sq = rotate_into_pref_sq[reversed]
+
+lemma rotate_into_pos: assumes "s\<cdot>p \<le>f w"
+  obtains w' where "w \<sim> w'" "p \<le>p w'" "s \<le>s w'"
+proof(rule rotate_into_pos_sq)
+  show "s\<cdot>p \<le>f w\<cdot>w"
+    using \<open>s \<cdot> p \<le>f w\<close> by blast
+  show "\<^bold>|s\<^bold>| \<le> \<^bold>|w\<^bold>|"    
+    using order.trans[OF pref_len' fac_len[OF \<open>s \<cdot> p \<le>f w\<close>] ].
+  show "\<^bold>|p\<^bold>| \<le> \<^bold>|w\<^bold>|"
+    using order.trans[OF suf_len' fac_len[OF \<open>s \<cdot> p \<le>f w\<close>]].
+qed
+
+lemma rotate_into_pos_conjug: assumes "w \<sim> v" and "s\<cdot>p \<le>f v"
+  obtains w' where "w \<sim> w'" "p \<le>p w'" "s \<le>s w'"
+  using assms conjug_trans rotate_into_pos by metis 
+
 lemma nconjug_neq: "\<not> u \<sim> v \<Longrightarrow> u \<noteq> v"
   by blast
 
 lemma prim_conjug:
   assumes prim: "primitive u" and conjug: "u \<sim> v"
   shows "primitive v"
 proof -
   have "v \<noteq> \<epsilon>" using prim_nemp[OF prim] unfolding conjug_nemp_iff[OF conjug].
   from conjug[symmetric] obtain t where "v \<cdot> t = t \<cdot> u"..
   from this \<open>v \<noteq> \<epsilon>\<close> obtain r s i where
     v: "(r \<cdot> s)\<^sup>@(Suc i) = v" and u: "(s \<cdot> r)\<^sup>@(Suc i) = u" and prim': "primitive (r \<cdot> s)"..
-  have "r \<cdot> s = v" using v unfolding prim_exp_one[OF prim u] pow_one_id.
+  have "r \<cdot> s = v" using v unfolding prim_exp_one[OF prim u] pow_one'.
   show "primitive v" using prim' unfolding \<open>r \<cdot> s = v\<close>.
 qed
 
+lemma conjug_prim_iff: assumes "u \<sim> v" shows "primitive u = primitive v"
+  using prim_conjug[OF _ \<open>u \<sim> v\<close>] prim_conjug[OF _ conjug_sym[OF \<open>u \<sim> v\<close>]]..
+
+lemmas conjug_concat_prim_iff = conjug_concat_conjug[THEN conjug_prim_iff]
+
 lemma root_conjug: "u \<le>p r \<cdot> u \<Longrightarrow> u\<inverse>\<^sup>>(r\<cdot>u) \<sim> r"
   using conjugI1 conjug_sym lq_pref by metis
 
-lemma conjug_prim_root:
-  assumes conjug: "u \<sim> v" and "u \<noteq> \<epsilon>"
-  shows "\<rho> u \<sim> \<rho> v"
+lemmas conjug_prim_iff_pref = conjug_prim_iff[OF root_conjug] 
+
+lemma conjug_primroot_word:
+  assumes conjug: "u \<cdot> t = t \<cdot> v" and "u \<noteq> \<epsilon>"
+  shows "(\<rho> u) \<cdot> t = t \<cdot> (\<rho> v)"
 proof -
-  from conjug obtain t where "u \<cdot> t = t \<cdot> v"..
-  from this \<open>u \<noteq> \<epsilon>\<close> obtain r s i where
-    u: "(r \<cdot> s)\<^sup>@(Suc i) = u" and v: "(s \<cdot> r)\<^sup>@(Suc i) = v" and prim: "primitive (r \<cdot> s)"..
+  from \<open>u \<cdot> t = t \<cdot> v\<close> \<open>u \<noteq> \<epsilon>\<close> obtain r s i n where
+    u: "(r \<cdot> s)\<^sup>@(Suc i) = u" and v: "(s \<cdot> r)\<^sup>@(Suc i) = v" and prim: "primitive (r \<cdot> s)"
+    and "(r \<cdot> s)\<^sup>@n \<cdot> r = t"..
   have rs: "\<rho> u = r \<cdot> s" and sr: "\<rho> v = s \<cdot> r"
     using prim prim_conjug u v by blast+
-  show "\<rho> u \<sim> \<rho> v" using conjugI' unfolding rs sr.
+  show ?thesis
+    unfolding \<open>(r \<cdot> s)\<^sup>@n \<cdot> r = t\<close>[symmetric] rs sr
+    by comparison
+qed
+
+lemma conjug_primroot:
+  assumes "u \<sim> v"
+  shows "\<rho> u \<sim> \<rho> v" 
+proof(cases)
+  assume "u = \<epsilon>" with \<open>u \<sim> v\<close> show "\<rho> u \<sim> \<rho> v"
+    using conjug_nemp_iff by blast 
+next
+  assume "u \<noteq> \<epsilon>"
+  from \<open>u \<sim> v\<close> obtain t where "u \<cdot> t = t \<cdot> v"..
+  from conjug_primroot_word[OF this \<open>u \<noteq> \<epsilon>\<close>]
+  show "\<rho> u \<sim> \<rho> v"
+    by (simp add: conjugI1)  
 qed
 
 lemma conjug_add_exp: "u \<sim> v \<Longrightarrow>  u\<^sup>@k \<sim> v\<^sup>@k"
- by (elim conjugE1, intro conjugI1, rule conjug_pow)
-
-lemma conjug_prim_root_iff:
+  by (elim conjugE1, intro conjugI1, rule conjug_pow)
+
+lemma conjug_primroot_iff:
   assumes nemp:"u \<noteq> \<epsilon>" and len: "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|"
   shows "\<rho> u  \<sim> \<rho> v \<longleftrightarrow> u \<sim> v"
 proof
-  show "u \<sim> v \<Longrightarrow> \<rho> u  \<sim> \<rho> v" using conjug_prim_root[OF _ nemp].
+  show "u \<sim> v \<Longrightarrow> \<rho> u  \<sim> \<rho> v" using conjug_primroot.
   assume conjug: "\<rho> u  \<sim> \<rho> v"
   have "v \<noteq> \<epsilon>" using nemp_len[OF nemp] unfolding len length_0_conv.
-  with nemp obtain k l where roots: "(\<rho> u)\<^sup>@k = u" "(\<rho> v)\<^sup>@l = v" by (elim prim_root_power)
+  with nemp obtain k l where roots: "(\<rho> u)\<^sup>@k = u" "(\<rho> v)\<^sup>@l = v"
+    using primrootE primroot_is_primroot by metis 
   have "\<^bold>|(\<rho> u)\<^sup>@k\<^bold>| = \<^bold>|(\<rho> v)\<^sup>@l\<^bold>|" using len unfolding roots.
   then have "k = l" using primroot_nemp[OF \<open>v \<noteq> \<epsilon>\<close>]
     unfolding pow_len conjug_len[OF conjug] by simp
   show "u \<sim> v" using conjug_add_exp[OF conjug, of l] unfolding roots[unfolded \<open>k = l\<close>].
 qed
 
 lemma fac_pow_pref_conjug:
   assumes "u \<le>f t\<^sup>@k"
   obtains t' where "t \<sim> t'" and "u \<le>p t'\<^sup>@k"
 proof (cases "u = \<epsilon>")
   assume "u \<noteq> \<epsilon>"
   obtain p q where eq: "p \<cdot> u \<cdot> q = t\<^sup>@k" using facE'[OF assms].
   obtain i r where "i < k" and "r <p t" and p: "t\<^sup>@i \<cdot> r = p"
     using pref_mod_power[OF sprefI1'[OF eq pref_nemp[OF \<open>u \<noteq> \<epsilon>\<close>]]].
   from \<open>r <p t\<close> obtain s where t: "r \<cdot> s = t"..
   have eq': "t\<^sup>@i \<cdot> r \<cdot> (u \<cdot> q) = t\<^sup>@k" using eq unfolding lassoc p.
   have  "u \<le>p (s \<cdot> r)\<^sup>@k" using pow_conjug[OF eq' t] unfolding rassoc..
   with conjugI'[of r s] show thesis unfolding t..
 qed blast
 
-lemma fac_pow_len_conjug: assumes  "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|" and "u \<le>f v\<^sup>@k" shows "v \<sim> u"
+lemmas fac_pow_suf_conjug = fac_pow_pref_conjug[reversed]
+
+lemma fac_pow_len_conjug[intro]: assumes  "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|" and "u \<le>f v\<^sup>@k" shows "v \<sim> u"
 proof-
   obtain t where "v \<sim> t" and "u \<le>p t\<^sup>@k"
     using fac_pow_pref_conjug assms by blast
   have "u = t"
     using pref_equal[OF pref_prod_root[OF \<open>u \<le>p t\<^sup>@k\<close>] conjug_len[OF \<open>v \<sim> t\<close>,folded \<open>\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|\<close>]].
   from \<open>v \<sim> t\<close>[folded this]
   show "v \<sim> u".
 qed
 
-lemma border_conjug: "x \<le>b w \<Longrightarrow> w\<^sup><\<inverse>x \<sim>  x\<inverse>\<^sup>>w"
+lemma conjug_fac_sq:
+  "u \<sim> v \<Longrightarrow> u \<le>f v \<cdot> v"
+  by (elim conjugE, unfold eq_commute[of "_ \<cdot> _"]) (intro facI', simp)
+
+lemma conjug_fac_pow_conv: assumes "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|" and "2 \<le> k"
+  shows "u \<sim> v \<longleftrightarrow> u \<le>f v\<^sup>@k"
+proof
+  assume "u \<sim> v"
+  have f:  "v \<cdot> v \<le>f v \<^sup>@k"
+    using \<open>2 \<le> k\<close>  unfolding pow_two[symmetric] using le_exps_pref by blast 
+  from fac_trans[OF conjug_fac_sq[OF \<open>u \<sim> v\<close>] this] 
+  show "u \<le>f v \<^sup>@ k".
+next
+  show " u \<le>f v \<^sup>@ k \<Longrightarrow> u \<sim> v"
+    using fac_pow_len_conjug[OF \<open>\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|\<close>, THEN conjug_sym].
+qed
+
+lemma fac_pow_conjug: assumes "u \<le>f v\<^sup>@k" and  "t \<sim> v" 
+  shows "u \<le>f t\<^sup>@Suc k"
+proof-
+  obtain r s where "v = r \<cdot> s" and "t = s \<cdot> r"
+    using \<open>t \<sim> v\<close> by blast
+  have "s \<cdot> v\<^sup>@k \<cdot> r = t\<^sup>@Suc k" 
+    unfolding \<open>v = r \<cdot> s\<close> \<open>t = s \<cdot> r\<close> shift_pow pow_Suc rassoc..
+  from facI[of "v\<^sup>@k" s r, unfolded this]
+  show "u \<le>f t\<^sup>@Suc k"
+    using \<open>u \<le>f v\<^sup>@k\<close> by blast 
+qed
+
+lemma border_conjug: "x \<le>b w \<Longrightarrow> w\<^sup><\<inverse>x \<sim> x\<inverse>\<^sup>>w"
   using border_conjug_eq conjugI1 by blast
 
-lemmas fac_pow_suf_conjug = fac_pow_pref_conjug[reversed]
+lemma count_list_conjug: assumes "u \<sim> v" shows "count_list u a = count_list v a"
+proof-
+  from  conjugE[OF \<open>u \<sim> v\<close>]
+  obtain r s where "r \<cdot> s = u" "s \<cdot> r = v".
+  show "count_list u a = count_list v a"
+    unfolding \<open>r \<cdot> s = u\<close>[symmetric] \<open>s \<cdot> r = v\<close>[symmetric] count_list_append by presburger 
+qed
+
+lemma conjug_in_lists: "us \<sim> vs \<Longrightarrow> vs \<in> lists A \<Longrightarrow> us \<in> lists A" 
+  unfolding conjugate_def  by auto
+
+lemma conjug_in_lists': "us \<sim> vs \<Longrightarrow> us \<in> lists A \<Longrightarrow> vs \<in> lists A" 
+  unfolding conjugate_def  by auto
+
+lemma conjug_in_lists_iff: "us \<sim> vs \<Longrightarrow> us \<in> lists A \<longleftrightarrow> vs \<in> lists A" 
+  unfolding conjugate_def  by auto
+
+lemma two_conjugs_imprim: assumes "u \<cdot> v = r \<cdot> s" and "v \<cdot> u = s \<cdot> r" and "u \<noteq> \<epsilon>" and "v \<noteq> \<epsilon>" and "u \<noteq> r"
+  shows "\<not> primitive (u \<cdot> v)"
+proof-
+  consider (u_pref_r) "u <p r" | (r_pref_u) "r <p u" 
+    using \<open>u \<noteq> r\<close> prefix_append \<open>u \<cdot> v = r \<cdot> s\<close> prefI  strict_prefixI by metis 
+  thus "\<not> primitive (u \<cdot> v)"
+  proof (cases)
+    case u_pref_r
+    hence "(u\<inverse>\<^sup>>r) \<cdot> (s \<cdot> u) = v \<cdot> u"
+      using  lq_pref_cancel[OF sprefD1 \<open>u \<cdot> v = r \<cdot> s\<close>[symmetric]]  by auto
+    have "(s \<cdot> u) \<cdot> (u\<inverse>\<^sup>>r) = v \<cdot> u"
+      unfolding rassoc
+      using \<open>v \<cdot> u = s \<cdot> r\<close> lq_pref sprefD[OF u_pref_r] by (auto simp add: prefix_def) 
+    from comm_not_prim[OF lq_spref[OF u_pref_r] _ \<open>(u\<inverse>\<^sup>>r) \<cdot> (s \<cdot> u) = v \<cdot> u\<close>[folded this]]
+    have "\<not> primitive (v \<cdot> u)"
+      unfolding \<open>(u\<inverse>\<^sup>>r) \<cdot> (s \<cdot> u) = v \<cdot> u\<close> using \<open>u \<noteq> \<epsilon>\<close> by blast 
+    thus "\<not> primitive (u \<cdot> v)"
+      using prim_conjug by auto 
+  next
+    case r_pref_u
+    hence "(r\<inverse>\<^sup>>u) \<cdot> (v \<cdot> r) = s \<cdot> r"
+      using \<open>u \<cdot> v = r \<cdot> s\<close> by (auto simp add: prefix_def)
+    have "(v \<cdot> r) \<cdot> (r\<inverse>\<^sup>>u) = s \<cdot> r"
+      unfolding rassoc
+      using \<open>v \<cdot> u = s \<cdot> r\<close> lq_pref sprefD[OF r_pref_u] by (auto simp add: prefix_def)
+    from comm_not_prim[OF lq_spref[OF r_pref_u] _ \<open>(r\<inverse>\<^sup>>u) \<cdot> (v \<cdot> r) = s \<cdot> r\<close>[folded this]]
+    have "\<not> primitive (v \<cdot> u)"
+      unfolding \<open>(r\<inverse>\<^sup>>u) \<cdot> (v \<cdot> r) = s \<cdot> r\<close> \<open>v \<cdot> u = s \<cdot> r\<close> using \<open>v \<noteq> \<epsilon>\<close> by blast 
+    thus "\<not> primitive (u \<cdot> v)"
+      using prim_conjug by auto 
+  qed
+qed
+
+lemma prim_conjugE:  assumes "(u \<cdot> v) \<cdot> z = z \<cdot> (v \<cdot> u)" and "primitive (u \<cdot> v)"
+  obtains k where "(u \<cdot> v)\<^sup>@k \<cdot> u = z" | "u \<noteq> \<epsilon>" and "v = \<epsilon>" and "z = \<epsilon>" 
+proof-
+  from conjug_eqE[OF assms(1) prim_nemp[OF assms(2)]]
+  obtain x y m where "x \<cdot> y = u \<cdot> v" and "y \<cdot> x = v \<cdot> u" and "(x \<cdot> y)\<^sup>@m \<cdot> x = z" and "y \<noteq> \<epsilon>". 
+  from two_conjugs_imprim[OF \<open>x \<cdot> y = u \<cdot> v\<close>[symmetric] \<open>y \<cdot> x = v \<cdot> u\<close>[symmetric] ] \<open>primitive (u \<cdot> v)\<close>
+  consider "u = \<epsilon>" | "v = \<epsilon>" | "u = x" by blast
+  thus thesis
+  proof (cases)
+    assume "u = \<epsilon>"
+    hence "v \<noteq> \<epsilon>" using \<open>primitive (u \<cdot> v)\<close> by fastforce
+    obtain k where "z = (u \<cdot> v)\<^sup>@k \<cdot> u"
+      using \<open>(u \<cdot> v) \<cdot> z = z \<cdot> (v \<cdot> u)\<close>[symmetric] \<open>primitive (u \<cdot> v)\<close>
+      unfolding \<open>u = \<epsilon>\<close> clean_emp using prim_comm_exp by blast
+    from that(1)[OF this[symmetric]]
+    show thesis.
+  next
+    assume "v = \<epsilon>"  
+    have "u \<noteq> \<epsilon>" and "primitive u" and "z \<cdot> u = u \<cdot> z" 
+      using \<open>primitive (u \<cdot> v)\<close> \<open>(u \<cdot> v) \<cdot> z = z \<cdot> (v \<cdot> u)\<close>[symmetric]
+      unfolding \<open>v = \<epsilon>\<close> clean_emp  by force+
+    show thesis
+    proof(cases "z = \<epsilon>", simp add: that(2) \<open>v = \<epsilon>\<close> \<open>u \<noteq> \<epsilon>\<close>)
+      assume "z \<noteq> \<epsilon>"
+      from  prim_comm_exp[OF \<open>primitive u\<close> \<open>z \<cdot> u = u \<cdot> z\<close>] 
+      obtain k where "u\<^sup>@k = z".
+      from nemp_pow_SucE[OF \<open>z \<noteq> \<epsilon>\<close> this[symmetric]]
+      obtain l where "z = (u \<cdot> v)\<^sup>@l \<cdot> u"
+        unfolding \<open>v = \<epsilon>\<close> clean_emp pow_Suc2[symmetric].
+      from that(1)[OF this[symmetric]]
+      show thesis.
+    qed
+  next
+    assume "u = x"
+    with \<open>x \<cdot> y = u \<cdot> v\<close>[unfolded this cancel, symmetric]
+      \<open>(x \<cdot> y)\<^sup>@m \<cdot> x = z\<close> that(1)
+    show thesis by blast
+  qed
+qed
+
+lemma fac_per_conjug: assumes "period w n" and  "v \<le>f w" and "\<^bold>|v\<^bold>| = n"
+  shows "v \<sim> take n w"
+proof-
+  have "\<^bold>|take n w\<^bold>| = \<^bold>|v\<^bold>|"
+    using fac_len[OF \<open>v \<le>f w\<close>] \<open>\<^bold>|v\<^bold>| = n\<close> take_len by blast 
+  from per_pref_ex[OF \<open>period w n\<close>[unfolded period_def]] 
+  obtain k where "w \<le>p take n w \<^sup>@ k".
+  from fac_pow_len_conjug[OF \<open>\<^bold>|take n w\<^bold>| = \<^bold>|v\<^bold>|\<close>[symmetric], THEN conjug_sym] 
+       fac_trans[OF  \<open>v \<le>f w\<close> pref_fac, OF this]
+  show ?thesis. 
+qed
+
+lemma fac_pers_conjug: assumes "period w n" and  "v \<le>f w" and "\<^bold>|v\<^bold>| = n" and "u \<le>f w" and "\<^bold>|u\<^bold>| = n"
+  shows "v \<sim> u"             
+  using  conjug_trans[OF fac_per_conjug[OF \<open>period w n\<close> \<open>v \<le>f w\<close> \<open>\<^bold>|v\<^bold>| = n\<close>]
+      conjug_sym[OF fac_per_conjug[OF \<open>period w n\<close> \<open>u \<le>f w\<close> \<open>\<^bold>|u\<^bold>| = n\<close>]]].
+
+lemma conjug_pow_powE: assumes "w \<sim> r\<^sup>@k" obtains s where "w = s\<^sup>@k" 
+proof-
+  obtain u v where "w = u \<cdot> v" and "v \<cdot> u = r\<^sup>@k"
+    using assms by blast 
+  have "w = (v\<inverse>\<^sup>>(r\<cdot>v))\<^sup>@k"
+    unfolding \<open>w = u \<cdot> v\<close> lq_conjug_pow[OF pref_prod_root, OF prefI[OF \<open>v \<cdot> u = r \<^sup>@ k\<close>], symmetric] \<open>v \<cdot> u = r \<^sup>@ k\<close>[symmetric]
+    by simp
+  from that[OF this]
+  show thesis.
+qed 
+
+lemma find_second_letter:  assumes "a \<noteq> b" and  "set ws = {a,b}" 
+  shows "dropWhile (\<lambda> c. c = a) ws \<noteq> \<epsilon>" and "hd (dropWhile (\<lambda> c. c = a) ws) = b" 
+proof-
+  let ?a = "(\<lambda> c. c = a)"
+
+  define wsb where "wsb = dropWhile ?a ws \<cdot> takeWhile ?a ws" 
+  have "wsb \<sim> ws" 
+    unfolding wsb_def using takeWhile_dropWhile_id[of ?a ws] conjugI' by blast 
+  hence "set wsb = {a,b}"
+    using \<open>set ws = {a,b}\<close> by (simp add: conjug_set)
+
+  have "takeWhile ?a ws \<noteq> ws"
+    unfolding takeWhile_eq_all_conv using \<open>set ws = {a,b}\<close> \<open>a \<noteq> b\<close> by simp
+  thus "dropWhile ?a ws \<noteq> \<epsilon>" by simp 
+  from hd_dropWhile[OF this] set_dropWhileD[OF hd_in_set[OF this], unfolded \<open>set ws = {a,b}\<close>]
+  show "hd (dropWhile ?a ws) = b"
+    by blast
+qed
+
+lemma fac_conjuq_sq:
+  assumes "u \<sim> v" and "\<^bold>|w\<^bold>| \<le> \<^bold>|u\<^bold>|" and "w \<le>f u \<cdot> u"
+  shows "w \<le>f v \<cdot> v"
+proof -
+  have assm_le: "w \<le>f s \<cdot> r \<cdot> s \<cdot> r"
+    if "p \<cdot> w \<cdot> q = r \<cdot> s \<cdot> r \<cdot> s" and "\<^bold>|r\<^bold>| \<le> \<^bold>|p\<^bold>|" for w s r p q :: "'a list"
+  proof -
+    obtain p' where "r \<cdot> p' = p"
+      using \<open>p \<cdot> w \<cdot> q = r \<cdot> s \<cdot> r \<cdot> s\<close> \<open>\<^bold>|r\<^bold>| \<le> \<^bold>|p\<^bold>|\<close> unfolding rassoc by (rule eqdE[OF sym])
+    show "w \<le>f s \<cdot> r \<cdot> s \<cdot> r"
+      using \<open>p \<cdot> w \<cdot> q = r \<cdot> s \<cdot> r \<cdot> s\<close>
+      by (intro facI'[of p' _ "q \<cdot> r"]) (simp flip: \<open>r \<cdot> p' = p\<close>)
+  qed
+  obtain r s where "r \<cdot> s = u" and "s \<cdot> r = v" using \<open>u \<sim> v\<close>..
+  obtain p q where "p \<cdot> w \<cdot> q = u \<cdot> u" using \<open>w \<le>f u \<cdot> u\<close> ..
+  from lenarg[OF this] \<open>\<^bold>|w\<^bold>| \<le> \<^bold>|u\<^bold>|\<close>
+  have "\<^bold>|r\<^bold>| \<le> \<^bold>|p\<^bold>| \<or> \<^bold>|s\<^bold>| \<le> \<^bold>|q\<^bold>|"
+    unfolding \<open>r \<cdot> s = u\<close>[symmetric] lenmorph by linarith
+  then show "w \<le>f v \<cdot> v"
+    using \<open>p \<cdot> w \<cdot> q = u \<cdot> u\<close> unfolding \<open>r \<cdot> s = u\<close>[symmetric] \<open>s \<cdot> r = v\<close>[symmetric]
+    by (elim disjE) (simp only: assm_le rassoc, simp only: assm_le[reversed] lassoc)
+qed
+
+lemma fac_conjuq_sq_iff:
+  assumes "u \<sim> v" shows "\<^bold>|w\<^bold>| \<le> \<^bold>|u\<^bold>| \<Longrightarrow> w \<le>f u \<cdot> u \<longleftrightarrow> w \<le>f v \<cdot> v"
+  using fac_conjuq_sq[OF \<open>u \<sim> v\<close>] fac_conjuq_sq[OF \<open>u \<sim> v\<close>[symmetric]]
+  unfolding conjug_len[OF \<open>u \<sim> v\<close>[symmetric]]..
+
+lemma map_conjug:
+  "u \<sim> v \<Longrightarrow> map f u \<sim> map f v"
+  by (elim conjugE, unfold eq_commute[of "_ \<cdot> _"]) auto
+
+lemma map_conjug_iff [reversal_rule]:
+  assumes "inj f" shows "map f u \<sim> map f v \<longleftrightarrow> u \<sim> v"
+  using map_conjug map_conjug[of "map f u" "map f v" "inv f"]
+  unfolding map_map inv_o_cancel[OF \<open>inj f\<close>] list.map_id by (intro iffI)
+
+lemma switch_fac: assumes "x \<noteq> y" and  "set ws = {x,y}" shows  "[x,y] \<le>f ws \<cdot> ws" 
+proof-
+  let ?y = "(\<lambda> a. a = y)" and ?x = "(\<lambda> a. a = x)"
+  have "ws \<noteq> \<epsilon>"
+    using \<open>set ws = {x,y}\<close> by force 
+
+  define wsx where "wsx = dropWhile ?y ws \<cdot> takeWhile ?y ws"
+  have "wsx \<sim> ws" 
+    unfolding wsx_def using takeWhile_dropWhile_id[of ?y ws] conjugI' by blast 
+  have "set wsx = {x,y}"
+    unfolding wsx_def using \<open>set ws = {x,y}\<close> conjugI' conjug_set takeWhile_dropWhile_id by metis 
+  from find_second_letter[OF  \<open>x \<noteq> y\<close>[symmetric] \<open>set ws = {x,y}\<close>[unfolded insert_commute[of x]]]
+  have  "dropWhile (\<lambda>c. c = y) ws \<noteq> \<epsilon>" and "hd wsx = x"
+    unfolding wsx_def using hd_append by simp_all
+  hence "takeWhile ?x wsx \<noteq> \<epsilon>"
+    unfolding wsx_def takeWhile_eq_Nil_iff by blast
+  from  nemp_pow_SucE[OF this, of "[x]"]
+  obtain k where "takeWhile ?x wsx = [x]\<^sup>@Suc k"
+    using takeWhile_sing_root[of x wsx] unfolding root_def fac_def by metis
+  note find_second_letter[OF \<open>x \<noteq> y\<close> \<open>set wsx = {x,y}\<close>]
+  have "wsx = [x]\<^sup>@k \<cdot> [x] \<cdot> [hd (dropWhile ?x wsx)] \<cdot> tl (dropWhile ?x wsx)"
+    unfolding lassoc pow_Suc2[symmetric] \<open>takeWhile ?x wsx = [x]\<^sup>@Suc k\<close>[symmetric]
+    unfolding rassoc hd_tl[OF \<open>dropWhile ?x wsx \<noteq> \<epsilon>\<close>] takeWhile_dropWhile_id.. 
+  from this[unfolded \<open>hd (dropWhile ?x wsx) = y\<close>]
+  have "[x,y] \<le>f wsx" by (auto simp add: fac_def)
+  thus "[x,y] \<le>f ws \<cdot> ws"
+    using fac_trans[OF _ conjug_fac_sq[OF \<open>wsx \<sim> ws\<close>]] by blast
+qed
+
+lemma imprim_ext_pref_comm: assumes "\<not> primitive (u \<cdot> v)" and "\<not> primitive (u \<cdot> v \<cdot> u)" 
+  shows "u \<cdot> v = v \<cdot> u"
+using \<open>\<not> primitive (u \<cdot> v)\<close> proof (elim not_prim_pow)
+  fix z n assume "z \<^sup>@ n = u \<cdot> v" and "2 \<le> n"
+  have "2 * \<^bold>|z\<^bold>| \<le> \<^bold>|u \<cdot> v \<cdot> u\<^bold>|"
+    by (simp add: pow_len \<open>2 \<le> n\<close> trans_le_add1 flip: \<open>z\<^sup>@n = u \<cdot> v\<close> rassoc)
+  moreover have "u \<cdot> v \<cdot> u \<le>p z \<cdot> u \<cdot> v \<cdot> u"
+    by (intro pref_prod_root[of _ _ "n + n"]) (simp add: \<open>z \<^sup>@ n = u \<cdot> v\<close> add_exps)
+  ultimately have "(u \<cdot> v \<cdot> u) \<cdot> z = z \<cdot> u \<cdot> v \<cdot> u"
+    using \<open>\<not> primitive (u \<cdot> v \<cdot> u)\<close>
+    by (cases "z = \<epsilon>") (unfold per_le_prim_iff, blast+)
+  from comm_add_exp[OF this[symmetric], of n]
+  show "u \<cdot> v = v \<cdot> u"
+    unfolding \<open>z \<^sup>@ n = u \<cdot> v\<close> by simp
+qed
+
+lemma imprim_ext_suf_comm:
+  "\<not> primitive (u \<cdot> v) \<Longrightarrow> \<not> primitive (u \<cdot> v \<cdot> v) \<Longrightarrow> u \<cdot> v = v \<cdot> u"
+  by (intro imprim_ext_pref_comm[symmetric])
+     (unfold conjug_prim_iff[OF conjugI', of v] rassoc)
+
+lemma prim_xyky: assumes "2 \<le> k" and "\<not> primitive ((x \<cdot> y)\<^sup>@k \<cdot> y)" shows "x \<cdot> y = y \<cdot> x"
+proof-
+  have "k \<noteq> 0" using \<open>2 \<le> k\<close> by simp 
+  have "(x \<cdot> y)\<^sup>@k = (x \<cdot> y)\<^sup>@(k - 1) \<cdot> x \<cdot> y"
+    unfolding rassoc pow_Suc2[symmetric] Suc_minus[OF \<open>k \<noteq> 0\<close>]..
+  have "(x \<cdot> y)\<^sup>@k \<cdot> y = ((x \<cdot> y)\<^sup>@(k -1) \<cdot> x) \<cdot> y \<cdot> y" 
+    unfolding lassoc cancel_right unfolding rassoc pow_Suc2[symmetric] Suc_minus[OF \<open>k \<noteq> 0\<close>]..
+  from imprim_ext_suf_comm[OF _ \<open>\<not> primitive ((x \<cdot> y)\<^sup>@k \<cdot> y)\<close>[unfolded this], 
+       unfolded rassoc pow_Suc2[symmetric] Suc_minus[OF \<open>k \<noteq> 0\<close>], OF pow_nemp_imprim[OF \<open>2 \<le> k\<close>]]
+  show "x \<cdot> y = y \<cdot> x" 
+    unfolding \<open>(x \<cdot> y)\<^sup>@k = (x \<cdot> y)\<^sup>@(k -1) \<cdot> x \<cdot> y\<close> shift_pow
+     pow_Suc2[of "x \<cdot> y", unfolded rassoc, symmetric] pow_Suc[of "y \<cdot> x", unfolded rassoc, symmetric]
+    using pow_eq_eq by blast
+qed    
+
+subsection \<open>Enumerating conjugates\<close>
+
+definition bounded_conjug 
+  where "bounded_conjug w' w k \<equiv> (\<exists> n \<le> k. w = rotate n w')"
+
+named_theorems bounded_conjug
+
+lemma[bounded_conjug]: "bounded_conjug w' w 0 \<longleftrightarrow> w = w'"
+  unfolding bounded_conjug_def by auto
+
+lemma[bounded_conjug]: "bounded_conjug w' w (Suc k) \<longleftrightarrow> bounded_conjug w' w k \<or> w = rotate (Suc k) w'"
+  unfolding bounded_conjug_def using le_SucE le_imp_less_Suc le_less by metis
+
+lemma[bounded_conjug]: "w' \<sim> w \<longleftrightarrow> bounded_conjug w w' (\<^bold>|w\<^bold>|-1)"
+  unfolding bounded_conjug_def conjug_swap[of w'] using conjug_rotate_iff_le.
+
+lemma "w \<sim> [a,b,c] \<longleftrightarrow> w = [a,b,c] \<or> w = [b,c,a] \<or> w = [c,a,b]"
+  by (simp add: bounded_conjug)
+
+section \<open>Element of lists: a method for testing if a word is in lists A\<close>
+
+lemma append_in_lists[simp, intro]: "u \<in> lists A \<Longrightarrow> v \<in> lists A \<Longrightarrow> u \<cdot> v \<in> lists A"
+  by simp
+
+lemma pref_in_lists: "u \<le>p v \<Longrightarrow> v \<in> lists A \<Longrightarrow> u \<in> lists A"
+  by (auto simp add: prefix_def)
+
+lemmas suf_in_lists = pref_in_lists[reversed]
+
+lemma lq_in_lists: "u \<le>p v \<Longrightarrow> v \<in> lists A \<Longrightarrow> u\<inverse>\<^sup>>v \<in> lists A"
+  by (auto simp add: prefix_def)
+
+lemmas rq_in_lists = lq_in_lists[reversed]
+
+lemma take_in_lists: "w \<in> lists A \<Longrightarrow> take j w \<in> lists A"
+  using pref_in_lists[OF take_is_prefix]. 
+
+lemma drop_in_lists: "w \<in> lists A \<Longrightarrow> drop j w \<in> lists A"
+  using suf_in_lists[OF suffix_drop].
+
+lemma lcp_in_lists: "u \<in> lists A \<Longrightarrow>  u \<and>\<^sub>p v \<in> lists A"
+  using pref_in_lists[OF lcp_pref].
+
+lemma lcp_in_lists': "v \<in> lists A \<Longrightarrow>  u \<and>\<^sub>p v \<in> lists A"
+  using pref_in_lists[OF lcp_pref'].
+
+lemma append_in_lists_dest: "u \<cdot> v \<in> lists A \<Longrightarrow> u \<in> lists A"
+  by simp
+
+lemma append_in_lists_dest': "u \<cdot> v \<in> lists A \<Longrightarrow> v \<in> lists A"
+  by simp
+
+lemma pow_in_lists: "u \<in> lists A \<Longrightarrow> u\<^sup>@k \<in> lists A"
+  by (induct k, simp, unfold pow_Suc, simp)
+
+lemma takeWhile_in_list: "u \<in> lists A \<Longrightarrow> takeWhile P u \<in> lists A"
+  using take_in_lists[of u _ "\<^bold>|takeWhile P u\<^bold>|", folded takeWhile_eq_take].
+
+lemma rev_in_lists: "u \<in> lists A \<Longrightarrow> rev u \<in> lists A"
+  by auto
+
+lemma append_in_lists_dest1: "u \<cdot> v = w \<Longrightarrow> w \<in> lists A \<Longrightarrow> u \<in> lists A" 
+  by auto
+
+lemma append_in_lists_dest2: "u \<cdot> v = w \<Longrightarrow> w \<in> lists A \<Longrightarrow> v \<in> lists A"
+  by auto
+
+lemma pow_in_lists_dest1: "u \<cdot> v = w\<^sup>@n \<Longrightarrow> w \<in> lists A \<Longrightarrow> u \<in> lists A"
+  using append_in_lists_dest pow_in_lists by metis
+
+lemma pow_in_lists_dest1_sym: "w\<^sup>@n = u \<cdot> v \<Longrightarrow> w \<in> lists A \<Longrightarrow> u \<in> lists A"
+  using append_in_lists_dest pow_in_lists by metis
+
+lemma pow_in_lists_dest2: "u \<cdot> v = w\<^sup>@n \<Longrightarrow> w \<in> lists A \<Longrightarrow> v \<in> lists A"
+  using append_in_lists_dest' pow_in_lists by metis
+
+lemma pow_in_lists_dest2_sym: "w\<^sup>@n = u \<cdot> v \<Longrightarrow> w \<in> lists A \<Longrightarrow> v \<in> lists A"
+  using append_in_lists_dest' pow_in_lists by metis
+
+lemma per_in_lists: "w \<le>p r \<cdot> w \<Longrightarrow> r \<noteq> \<epsilon> \<Longrightarrow> r \<in> lists A \<Longrightarrow> w \<in> lists A"
+  using per_pref[unfolded period_root_def] pow_in_lists[of r A] pref_in_lists by metis 
+
+method inlists =
+ (insert method_facts, use nothing in \<open>
+   ((elim suf_in_lists | elim pref_in_lists[elim_format] | rule lcp_in_lists | rule drop_in_lists |
+     rule take_in_lists | intro lq_in_lists |
+     rule append_in_lists | elim conjug_in_lists | rule pow_in_lists | rule takeWhile_in_list
+   | elim append_in_lists_dest1 | elim append_in_lists_dest2 
+   | elim pow_in_lists_dest2 | elim pow_in_lists_dest2_sym
+   | elim pow_in_lists_dest1 | elim pow_in_lists_dest1_sym)
+   | (simp | fact))+\<close>)
+
+section \<open>Reversed mappings\<close>
+
+definition rev_map :: "('a list \<Rightarrow> 'b list) \<Rightarrow> ('a list \<Rightarrow> 'b list)" where 
+  "rev_map f = rev \<circ> f \<circ> rev" 
+
+lemma rev_map_idemp[simp]: "rev_map (rev_map f) = f"
+  unfolding rev_map_def by auto
+
+lemma rev_map_arg: "rev_map f u = rev (f (rev u))"
+  by (simp add: rev_map_def)
+
+lemma rev_map_arg': "rev ((rev_map f) w) = f (rev w)"
+  by (simp add: rev_map_def)
+
+lemmas rev_map_arg_rev[reversal_rule] = rev_map_arg[reversed add: rev_rev_ident]
+
+lemma rev_map_sing: "rev_map f [a] =  rev (f [a])"
+  unfolding rev_map_def by simp
+
+lemma rev_maps_eq_iff: "rev_map g = rev_map h \<longleftrightarrow> g = h"
+  using arg_cong[of "rev_map g" "rev_map h" rev_map, unfolded rev_map_idemp] by fast
+
+section \<open>Overlapping powers, periods, prefixes and suffixes\<close>
+
+lemma pref_suf_overlapE: assumes "p \<le>p w" and "s \<le>s w" and "\<^bold>|w\<^bold>| \<le> \<^bold>|p\<^bold>| + \<^bold>|s\<^bold>|"
+  obtains p1 u s1 where "p1 \<cdot> u \<cdot> s1 = w" and "p1 \<cdot> u = p" and "u \<cdot> s1 = s"
+proof-
+  define u where "u = (w\<^sup><\<inverse>s)\<inverse>\<^sup>>p"
+  have "u \<le>s p"
+    unfolding u_def 
+    using assms add.commute add_le_imp_le_left eq_le_pref lq_suf_suf prefixE rq_len rq_suf by metis 
+  obtain p1 s1 where "p1 \<cdot> u = p" and "p \<cdot> s1 = w" 
+    using  suffixE[OF \<open>u \<le>s p\<close>] prefixE[OF \<open>p \<le>p w\<close>] by metis
+  note \<open>p \<cdot> s1 = w\<close>[folded \<open>p1 \<cdot> u = p\<close>, unfolded rassoc]
+
+  have "\<^bold>|s1\<^bold>| \<le> \<^bold>|s\<^bold>|"
+    using \<open>\<^bold>|w\<^bold>| \<le> \<^bold>|p\<^bold>| + \<^bold>|s\<^bold>|\<close>[folded \<open>p \<cdot> s1 = w\<close>, unfolded lenmorph] by force
+  hence "s1 \<le>s s"
+    using \<open>p \<cdot> s1 = w\<close> \<open>s \<le>s w\<close> suf_prod_long by blast
+
+  from rq_lq_assoc[OF rq_suf_suf[OF \<open>s \<le>s w\<close>], of s1] u_def[folded rqI[OF \<open>p \<cdot> s1 = w\<close>]]
+  have "u = s\<^sup><\<inverse>s1"
+    using suf_rq_lq_id[OF \<open>s \<le>s w\<close>] \<open>s1 \<le>s s\<close> by presburger 
+  hence "u \<cdot> s1 = s"
+    using  rq_suf[OF \<open>s1 \<le>s s\<close>] by blast
+
+  from that[OF \<open>p1 \<cdot> u \<cdot> s1 = w\<close> \<open>p1 \<cdot> u = p\<close> this]
+  show thesis.
+qed 
+
+lemma mid_sq: assumes "p\<cdot>x\<cdot>q=x\<cdot>x" shows "x\<cdot>p=p\<cdot>x" and "x\<cdot>q=q\<cdot>x"
+proof-
+  have "(x\<cdot>p)\<cdot>x\<cdot>q = (p\<cdot>x)\<cdot>q\<cdot>x" 
+    using assms by auto
+  from eqd_eq[OF this]
+  show "x\<cdot>p=p\<cdot>x" and "x\<cdot>q=q\<cdot>x"
+    by simp+
+qed
+
+lemma mid_sq': assumes "p\<cdot>x\<cdot>q=x\<cdot>x" shows "q \<cdot> p = x" and "p \<cdot> q = x"
+proof-
+  have "p\<cdot>q\<cdot>x = x\<cdot>x"
+    using assms[unfolded  mid_sq(2)[OF assms]].
+  thus "p\<cdot>q = x"  by auto
+  from assms[folded this] this
+  show "q\<cdot>p = x"  by auto 
+qed
+
+lemma mid_sq_pref: "p \<cdot> u \<le>p u \<cdot> u \<Longrightarrow> p \<cdot> u = u \<cdot> p" 
+  using mid_sq(1)[symmetric] unfolding prefix_def rassoc by metis
+
+lemmas mid_sq_suf = mid_sq_pref[reversed]
+
+lemma mid_sq_pref_suf: assumes "p\<cdot>x\<cdot>q=x\<cdot>x" shows "p \<le>p x" and "p \<le>s x" and "q \<le>p x" and "q \<le>s x"
+  using assms mid_sq'[OF assms] by blast+
+
+lemma mid_pow: assumes "p\<cdot>x\<^sup>@(Suc l)\<cdot>q = x\<^sup>@k"
+  shows "x\<cdot>p=p\<cdot>x" and "x\<cdot>q=q\<cdot>x"
+proof-
+  have "x\<cdot>p\<cdot>x\<^sup>@l\<cdot>x\<cdot>q = x\<cdot>(p\<cdot>x\<^sup>@Suc l \<cdot> q)"
+    by comparison
+  also have "... = (p\<cdot>x\<^sup>@Suc l \<cdot> q) \<cdot> x" 
+    unfolding rassoc assms  by comparison
+  also have "... =  p\<cdot>x\<cdot>x\<^sup>@l\<cdot>q\<cdot>x" by simp
+  finally have eq: "x\<cdot>p\<cdot>x\<^sup>@l\<cdot>x\<cdot>q = p\<cdot>x\<cdot>x\<^sup>@l\<cdot>q\<cdot>x".
+
+  have "(x\<cdot>p)\<cdot>x\<^sup>@l\<cdot>x\<cdot>q = (p\<cdot>x)\<cdot>x\<^sup>@l\<cdot>q\<cdot>x"
+    using eq unfolding rassoc.
+  from eqd_comp[OF this]
+  show "x\<cdot>p = p\<cdot>x"
+    using comm_ruler by blast
+
+  have "(x\<cdot>p\<cdot>x\<^sup>@l)\<cdot>(x\<cdot>q) = (x\<cdot>p\<cdot>x\<^sup>@l)\<cdot>(q\<cdot>x)"
+    using eq unfolding lassoc \<open>x\<cdot>p = p\<cdot>x\<close>.
+  from this[unfolded cancel]
+  show "x\<cdot>q = q\<cdot>x".
+qed
+
+lemma mid_long_pow: assumes eq: "y\<^sup>@m = u \<cdot> x\<^sup>@(Suc k) \<cdot> v" and "\<^bold>|y\<^bold>| \<le> \<^bold>|x\<^sup>@k\<^bold>|"
+  shows "(u \<cdot> v) \<cdot> y = y \<cdot> (u \<cdot> v)" and  "(u \<cdot> x\<^sup>@l \<cdot> v) \<cdot> y = y \<cdot> (u \<cdot> x\<^sup>@l \<cdot> v)" and "(u\<inverse>\<^sup>>(y\<cdot>u)) \<cdot> x = x \<cdot> (u\<inverse>\<^sup>>(y\<cdot>u))"
+proof-
+  have eq': "x\<cdot> x \<cdot>v \<cdot> u = u\<inverse>\<^sup>>(u\<cdot>x\<cdot>x\<cdot>v)\<cdot>u" by simp
+  let ?y = "u\<inverse>\<^sup>>(y\<cdot>u)"
+  have "u \<le>p y \<cdot> u"
+    using eq prefI pref_prod_root[of u y m,unfolded eq] by simp
+  hence "?y \<sim> y"
+    using root_conjug by blast
+  from conjug_len[OF this]
+  have "\<^bold>|?y\<^bold>| \<le> \<^bold>|x\<^sup>@k\<^bold>|"
+    using \<open>\<^bold>|y\<^bold>| \<le> \<^bold>|x\<^sup>@k\<^bold>|\<close> by simp 
+  from lq_conjug_pow[OF \<open>u \<le>p y \<cdot> u\<close>, of m]
+  have "?y\<^sup>@m = x\<^sup>@Suc k\<cdot>v\<cdot>u"
+    unfolding eq eq' by simp
+  hence "x\<^sup>@Suc k \<le>p ?y \<cdot> x\<^sup>@Suc k"
+    using mult_assoc prefI pref_prod_root[of "x\<^sup>@Suc k" ?y m] by blast
+  have "x \<^sup>@ Suc k \<le>p x \<cdot> x \<^sup>@ Suc k"
+    using pref_pow_ext' by blast 
+  have com: "?y \<cdot> x = x \<cdot> ?y"
+    using  \<open>\<^bold>|?y\<^bold>| \<le> \<^bold>|x\<^sup>@k\<^bold>|\<close> two_pers[OF \<open>x\<^sup>@Suc k \<le>p ?y \<cdot> x\<^sup>@Suc k\<close> \<open>x \<^sup>@ Suc k \<le>p x \<cdot> x \<^sup>@ Suc k\<close>]
+    unfolding power_Suc2 lenmorph by linarith
+  thus "?y \<cdot> x = x \<cdot> ?y"
+    by blast
+  have "?y \<cdot> x\<^sup>@Suc k = x\<^sup>@Suc k \<cdot> ?y"
+    using power_commuting_commutes[OF com[symmetric], symmetric].
+  from power_commutes[of ?y m, unfolded \<open>?y \<^sup>@ m = x\<^sup>@(Suc k) \<cdot> v \<cdot> u\<close>, unfolded lassoc this, unfolded rassoc]
+  have "x\<^sup>@Suc k \<cdot> v \<cdot> u \<cdot> ?y = x\<^sup>@Suc k \<cdot> ?y \<cdot> v \<cdot> u".
+  hence "u \<cdot> ?y \<cdot> v \<cdot> u = u \<cdot> v \<cdot> u \<cdot> ?y" by simp
+  thus "(u \<cdot> v) \<cdot>  y = y \<cdot> (u \<cdot> v)"
+    unfolding lassoc lq_pref[OF \<open>u \<le>p y \<cdot> u\<close>] by fastforce
+  have "u \<cdot> x\<^sup>@l \<cdot> v \<cdot>  u \<cdot> ?y =  u \<cdot> (?y \<cdot> x\<^sup>@l) \<cdot> v \<cdot> u"
+    unfolding power_commuting_commutes[OF com[symmetric], of l, symmetric] rassoc cancel
+    using \<open>u \<cdot> ?y \<cdot> v \<cdot> u = u \<cdot> v \<cdot> u \<cdot> ?y\<close>[unfolded cancel, symmetric].
+  thus "(u \<cdot> x\<^sup>@l \<cdot> v) \<cdot> y = y \<cdot> (u \<cdot> x\<^sup>@l \<cdot> v)"
+    unfolding lq_pref[OF \<open>u \<le>p y \<cdot> u\<close>] lassoc by blast
+qed
+
+lemma mid_pow_pref_suf': assumes  "s\<cdot>w\<^sup>@(Suc l)\<cdot>p \<le>f w\<^sup>@k" shows "p \<le>p w\<^sup>@k"  and "s \<le>s w\<^sup>@k"
+proof-
+  obtain v u where dec: "v \<cdot> s \<cdot>  w\<^sup>@(Suc l) \<cdot> p \<cdot> u = w\<^sup>@k"  
+    using facE'[OF assms, unfolded rassoc]. 
+  hence "(v \<cdot> s) \<cdot> w = w \<cdot> (v \<cdot> s)" and "w \<cdot> (p \<cdot> u) = (p \<cdot> u) \<cdot> w"
+    using mid_pow[of "v \<cdot> s" w l "p \<cdot> u" k] unfolding rassoc by presburger+
+  have "\<^bold>|p\<^bold>| \<le> \<^bold>|w\<^sup>@k\<^bold>|" and "\<^bold>|s\<^bold>| \<le> \<^bold>|w\<^sup>@k\<^bold>|"
+    using fac_len[OF assms] unfolding lenmorph by linarith+
+
+  from per_exp_pref[of "p \<cdot> u" w k, unfolded \<open>w \<cdot> (p \<cdot> u) = (p \<cdot> u) \<cdot> w\<close>, OF triv_pref] 
+  have "p \<le>p w\<^sup>@k \<cdot> (p \<cdot> u)" 
+    using   prefix_order.trans[OF triv_pref[of p u]] by blast
+  thus "p \<le>p w\<^sup>@k"
+    using \<open>\<^bold>|p\<^bold>| \<le> \<^bold>|w \<^sup>@ k\<^bold>|\<close> pref_prod_le by blast
+
+  from per_exp_suf[of "v \<cdot> s" w k, unfolded \<open>(v \<cdot> s) \<cdot> w = w \<cdot> (v \<cdot> s)\<close>, OF triv_suf]
+  have "s \<le>s (v \<cdot> s) \<cdot> w\<^sup>@k"
+    using  suffix_order.trans[OF triv_suf[of s v], of "(v \<cdot> s) \<cdot> w\<^sup>@k"] by blast
+  thus "s \<le>s w\<^sup>@k"
+    using \<open>\<^bold>|s\<^bold>| \<le> \<^bold>|w \<^sup>@ k\<^bold>|\<close> suf_prod_le by blast
+qed
+
+lemma mid_pow_pref_suf: assumes  "s\<cdot>w\<cdot>p \<le>f w\<^sup>@k" shows "p \<le>p w\<^sup>@k"  and "s \<le>s w\<^sup>@k"
+  using mid_pow_pref_suf'[of s w 0 p k, unfolded power_Suc0_right, OF assms]. 
+
+lemma fac_marker_pref: "y \<cdot> x \<le>f y\<^sup>@k \<Longrightarrow> x \<le>p y \<cdot> x"
+  using mid_pow_pref_suf(1)[of \<epsilon>, unfolded clean_emp, THEN pref_prod_root]. 
+
+lemmas fac_marker_suf = fac_marker_pref[reversed]
+
+lemma prim_overlap_sqE [consumes 2]:
+  assumes prim: "primitive r" and eq: "p \<cdot> r \<cdot> q = r \<cdot> r"
+  obtains (pref_emp) "p = \<epsilon>" | (suff_emp) "q = \<epsilon>"
+proof (cases "\<^bold>|p\<^bold>| = 0", blast)
+  assume "\<^bold>|p\<^bold>| \<noteq> 0" and qemp: "q = \<epsilon> \<Longrightarrow> thesis"
+  hence "\<^bold>|q\<^bold>| < \<^bold>|r\<^bold>|"
+    using lenarg[OF eq] unfolding lenmorph by linarith
+  have "q = \<epsilon>"
+    using prim_comm_short_emp[OF prim  mid_sq(2)[OF eq, symmetric] \<open>\<^bold>|q\<^bold>| < \<^bold>|r\<^bold>|\<close>].
+  from qemp[OF this]
+  show thesis.
+qed
+
+lemma prim_overlap_sqE' [consumes 2]:
+  assumes prim: "primitive r" and eq: "p \<cdot> r \<cdot> q = r \<cdot> r"
+  obtains (pref_emp) "p = \<epsilon>" | (suff_emp) "p = r"
+  using append_Nil2 eq mid_sq'(2) prim prim_overlap_sqE by metis
+   
+lemma prim_overlap_sq:
+  assumes prim: "primitive r" and eq: "p \<cdot> r \<cdot> q = r \<cdot> r"
+  shows "p = \<epsilon> \<or> q = \<epsilon>"
+  using prim_overlap_sqE[OF prim eq disjI1 disjI2].
+
+lemma prim_overlap_sq':
+  assumes prim: "primitive r" and pref: "p \<cdot> r \<le>p r \<cdot> r" and len: "\<^bold>|p\<^bold>| < \<^bold>|r\<^bold>|"
+  shows "p = \<epsilon>"
+  using mid_sq(1)[symmetric, THEN prim_comm_short_emp[OF prim _ len ]] pref
+   by (auto simp add: prefix_def) 
+
+lemma prim_overlap_pow:
+  assumes prim: "primitive r" and pref: "u \<cdot> r \<le>p r\<^sup>@k"
+  obtains i where "u = r\<^sup>@i" and "i < k"
+proof-
+  obtain q where eq: "u \<cdot> r \<^sup>@ Suc 0 \<cdot> q = r \<^sup>@ k"
+    using pref by (auto simp add: prefix_def)
+  from mid_pow(1)[OF this, symmetric]
+  have "u \<cdot> r = r \<cdot> u".
+  from prim_comm_exp[OF \<open>primitive r\<close> this]  
+  obtain i where "r\<^sup>@i = u". 
+  hence "\<^bold>|r \<^sup>@ Suc i\<^bold>| \<le> \<^bold>|r \<^sup>@ k\<^bold>|"
+    using pref by (auto simp add: prefix_def)
+  from mult_cancel_le[OF nemp_len[OF prim_nemp[OF prim]] this[unfolded pow_len]] 
+  have "i < k"  by auto 
+  from that[OF \<open>r\<^sup>@i = u\<close>[symmetric] this]
+  show thesis.
+qed
+
+lemma prim_overlap_pow':
+  assumes prim: "primitive r" and pref: "u \<cdot> r \<le>p r\<^sup>@k" and less: "\<^bold>|u\<^bold>| < \<^bold>|r\<^bold>|"
+  shows "u = \<epsilon>"
+proof-
+  obtain i where "u = r\<^sup>@i"
+    using prim_overlap_pow[OF prim pref] by fastforce
+  from less[unfolded pow_len[of r i, folded this]]
+  have "i = 0" by force
+  from \<open>u = r\<^sup>@i\<close>[unfolded this pow_zero]
+  show "u = \<epsilon>".
+qed
+
+lemma prim_sqs_overlap:
+  assumes prim: "primitive r" and comp: "u \<cdot> r \<cdot> r \<bowtie> v \<cdot> r \<cdot> r"
+    and len_u: "\<^bold>|u\<^bold>| < \<^bold>|v\<^bold>| + \<^bold>|r\<^bold>|" and len_v: "\<^bold>|v\<^bold>| < \<^bold>|u\<^bold>| + \<^bold>|r\<^bold>|"
+  shows "u = v"
+proof (cases rule: le_cases)
+  have wlog_le: "u = v" if comp: "u \<cdot> (r \<cdot> r) \<bowtie> v \<cdot> (r \<cdot> r)" and len_v: "\<^bold>|v\<^bold>| < \<^bold>|u\<^bold>| + \<^bold>|r\<^bold>|"
+    and "\<^bold>|u\<^bold>| \<le> \<^bold>|v\<^bold>|" for u v
+  proof -
+    obtain w where v: "u \<cdot> w = v" 
+      using comp_shorter[OF comp_prefs_comp[OF comp] \<open>\<^bold>|u\<^bold>| \<le> \<^bold>|v\<^bold>|\<close>] by (auto simp add: prefix_def)
+    have "\<^bold>|w\<^bold>| < \<^bold>|r\<^bold>|" using len_v unfolding v[symmetric] by simp
+    have comp': "r \<cdot> r \<bowtie> (w \<cdot> r) \<cdot> r" using comp unfolding v[symmetric] rassoc comp_cancel.
+    moreover have "\<^bold>|w \<cdot> r\<^bold>| \<le> \<^bold>|r \<cdot> r\<^bold>|" using less_imp_le_nat[OF \<open>\<^bold>|w\<^bold>| < \<^bold>|r\<^bold>|\<close>] by simp
+    ultimately have pref: "w \<cdot> r \<le>p r \<cdot> r" 
+      by (rule pref_comp_len_trans[OF triv_pref])
+    from this \<open>\<^bold>|w\<^bold>| < \<^bold>|r\<^bold>|\<close> have "w = \<epsilon>" by (rule prim_overlap_sq'[OF prim])
+    show "u = v" using v unfolding \<open>w = \<epsilon>\<close> append_Nil2.
+  qed
+  show "\<^bold>|u\<^bold>| \<le> \<^bold>|v\<^bold>| \<Longrightarrow> u = v" using wlog_le[OF comp len_v].
+  show "\<^bold>|v\<^bold>| \<le> \<^bold>|u\<^bold>| \<Longrightarrow> u = v" using wlog_le[OF comp[symmetric] len_u, symmetric].
+qed
+
+lemma drop_pref_prim: assumes "Suc n < \<^bold>|w\<^bold>|" and "w \<le>p drop (Suc n) (w \<cdot> w)" and "primitive w"
+  shows False
+  using assms
+proof (cases "w = \<epsilon>", simp)
+  assume "w \<noteq> \<epsilon>"  
+  obtain s where "drop (Suc n) (w \<cdot> w) = w \<cdot> s"
+    using prefD[OF \<open>w \<le>p drop (Suc n) (w \<cdot> w)\<close>] by blast
+  note takedrop[of "Suc n" "w \<cdot> w", unfolded this]  
+  from \<open>Suc n < \<^bold>|w\<^bold>|\<close> \<open>w \<noteq> \<epsilon>\<close> prim_overlap_sqE'[OF \<open>primitive w\<close> this]
+  show False by auto
+qed
+
+lemma root_suf_comm: assumes "x \<le>p r \<cdot> x" and  "r \<le>s r \<cdot> x" shows "r \<cdot> x = x \<cdot> r"
+proof-
+  have "r \<cdot> x = x \<cdot> x\<inverse>\<^sup>>(r \<cdot> x)"
+    using lq_pref[OF \<open>x \<le>p r \<cdot> x\<close>, symmetric].
+  from this and conj_len[OF this] 
+  have "r = x\<inverse>\<^sup>>(r \<cdot> x)"
+    using lq_pref[OF \<open>x \<le>p r \<cdot> x\<close>] suf_ruler_eq_len[OF \<open>r \<le>s r \<cdot> x\<close>, of "x\<inverse>\<^sup>>(r \<cdot> x)"] by blast
+  from \<open>r \<cdot> x = x \<cdot> x\<inverse>\<^sup>>(r \<cdot> x)\<close>[folded this]
+  show "r \<cdot> x = x \<cdot> r".
+qed
+
+lemma root_suf_comm': "x \<le>p r \<cdot> x \<Longrightarrow> r \<le>s x \<Longrightarrow> r \<cdot> x = x \<cdot> r"
+  using root_suf_comm suffix_appendI[of r x r] by blast
+
+lemma root_suf_conjug: assumes "primitive (s \<cdot> r)" and "y \<le>p (s \<cdot> r) \<cdot> y" and "y \<le>s y \<cdot> (r \<cdot> s)"
+               and "y \<noteq> \<epsilon>" and "\<^bold>|s \<cdot> r\<^bold>| \<le> \<^bold>|y\<^bold>|" 
+             obtains l where "y = (s \<cdot> r)\<^sup>@l \<cdot> s"
+proof-
+  have "r \<cdot> s \<le>s y"
+    using suf_prod_long[OF \<open>y \<le>s y \<cdot> (r \<cdot> s)\<close> \<open>\<^bold>|s \<cdot> r\<^bold>| \<le> \<^bold>|y\<^bold>|\<close>[unfolded swap_len]].
+  have "primitive (r \<cdot> s)"
+    using prim_conjug[OF \<open>primitive (s \<cdot> r)\<close> conjugI']. 
+  have "r \<cdot> y \<le>p (r \<cdot> s) \<cdot> (r \<cdot> y)" 
+    using \<open>y \<le>p (s \<cdot> r) \<cdot> y\<close> by auto  
+  from prim_comm_exp[OF \<open>primitive (r \<cdot> s)\<close> root_suf_comm'[OF this suf_ext[OF \<open>r \<cdot> s \<le>s y\<close>], symmetric]]
+  obtain k where [symmetric]: "(r \<cdot> s)\<^sup>@k = r \<cdot> y". 
+  from nemp_pow_SucE[OF _ this that, unfolded pow_Suc rassoc cancel shift_pow] \<open>y \<noteq> \<epsilon>\<close>
+  show thesis by simp
+qed
+
+lemma pref_suf_pows_comm: assumes "x \<le>p y\<^sup>@(Suc k)\<cdot>x\<^sup>@l" and  "y \<le>s y\<^sup>@m \<cdot> x\<^sup>@(Suc n)"
+  shows "x \<cdot> y = y \<cdot> x"
+  using root_suf_comm[OF per_root_drop_exp[OF \<open>x \<le>p y\<^sup>@(Suc k)\<cdot>x\<^sup>@l\<close>] per_root_drop_exp[reversed, OF \<open>y \<le>s y\<^sup>@m \<cdot> x\<^sup>@(Suc n)\<close>], symmetric].
+
+lemma root_suf_pow_comm: assumes "x \<le>p r \<cdot> x" and  "r \<le>s x\<^sup>@(Suc k)" shows "r \<cdot> x = x \<cdot> r"
+  using  root_suf_comm[OF \<open>x \<le>p r \<cdot> x\<close> suf_prod_root[OF \<open>r \<le>s x\<^sup>@(Suc k)\<close>]]. 
+
+lemma suf_pow_short_suf: "r \<le>s x\<^sup>@k \<Longrightarrow> \<^bold>|x\<^bold>| \<le> \<^bold>|r\<^bold>| \<Longrightarrow> x \<le>s r"
+  using suf_prod_root[THEN suf_prod_long].
+
+thm suf_pow_short_suf[reversed]
+
+lemma pref_marker: assumes "w \<le>p v \<cdot> w" and "u \<cdot> v \<le>p w"
+  shows "u \<cdot> v = v \<cdot> u"
+  using append_prefixD[OF \<open>u \<cdot> v \<le>p w\<close>] comm_ruler[OF \<open>u \<cdot> v \<le>p w\<close>, of "v \<cdot> w", unfolded same_prefix_prefix]
+    \<open>w \<le>p v \<cdot> w\<close> by blast
+
+lemma pref_marker_ext: assumes "\<^bold>|x\<^bold>| \<le> \<^bold>|y\<^bold>|" and "v \<noteq> \<epsilon>" and "y \<cdot> v \<le>p x \<cdot> v\<^sup>@k"
+  obtains n where "y = x \<cdot> (\<rho> v)\<^sup>@n"
+proof-
+  note pref_prod_long_ext[OF \<open>y \<cdot> v \<le>p x \<cdot> v\<^sup>@k\<close> \<open>\<^bold>|x\<^bold>| \<le> \<^bold>|y\<^bold>|\<close>]
+  have "x\<inverse>\<^sup>>y \<cdot> v \<le>p v\<^sup>@k"
+    using pref_cancel_lq_ext[OF \<open>y \<cdot> v \<le>p x \<cdot> v\<^sup>@k\<close> \<open>\<^bold>|x\<^bold>| \<le> \<^bold>|y\<^bold>|\<close>]. 
+  from pref_marker[OF _ this]
+  have "x\<inverse>\<^sup>>y \<cdot> v = v \<cdot> x\<inverse>\<^sup>>y" 
+    unfolding pow_comm[symmetric] by blast
+  then obtain n where "x\<inverse>\<^sup>>y = (\<rho> v)\<^sup>@n" 
+    using \<open>v \<noteq> \<epsilon>\<close>
+    using comm_primroots pow_zero primroot_expE' by metis 
+  hence "y = x \<cdot> (\<rho> v)\<^sup>@n" 
+    using \<open>x \<le>p y\<close> by (auto simp add: prefix_def)
+  from that[OF this] show thesis.
+qed
+
+lemma pref_marker_sq: "p \<cdot> x \<le>p x \<cdot> x \<Longrightarrow> p \<cdot> x = x \<cdot> p"
+  using pref_marker same_prefix_prefix triv_pref by metis
+
+lemmas suf_marker_sq = pref_marker_sq[reversed]
+
+lemma pref_marker_conjug: assumes "w \<noteq> \<epsilon>" and "w \<cdot> r \<cdot> s \<le>p s \<cdot> (r \<cdot> s)\<^sup>@m" and "primitive (r \<cdot> s)"
+  obtains n where "w = s \<cdot> (r \<cdot> s)\<^sup>@n" 
+proof-
+  have "(r \<cdot> w) \<cdot> r \<cdot> s \<le>p (r \<cdot> s)\<^sup>@Suc m"
+    using \<open>w \<cdot> r \<cdot> s \<le>p s \<cdot> (r \<cdot> s)\<^sup>@m\<close> by auto
+  from pref_marker[OF _ this, folded pow_comm, OF triv_pref]
+  have "(r \<cdot> w) \<cdot> r \<cdot> s = (r \<cdot> s) \<cdot> r \<cdot> w". 
+  from comm_primroots'[OF _ prim_nemp[OF \<open>primitive (r \<cdot> s)\<close>] this, unfolded prim_self_root[OF \<open>primitive (r \<cdot> s)\<close>]] 
+  have "\<rho> (r \<cdot> w) = r \<cdot> s"
+    using \<open>w \<noteq> \<epsilon>\<close> by blast
+  then obtain n where "r \<cdot> w = (r \<cdot> s)\<^sup>@Suc n"
+    using \<open>w \<noteq> \<epsilon>\<close> primroot_expE suf_nemp by metis 
+  thus thesis
+    using that by force
+qed
+
+lemmas pref_marker_reversed = pref_marker[reversed]
+
+lemma sq_short_per: assumes "\<^bold>|u\<^bold>| \<le> \<^bold>|v\<^bold>|" and "v\<cdot>v \<le>p u\<cdot>(v\<cdot>v)"
+  shows "u\<cdot>v = v\<cdot>u"
+  using 
+    pref_marker[of "v\<cdot>v", OF \<open>v\<cdot>v \<le>p u\<cdot>(v\<cdot>v)\<close> 
+    pref_prod_long[OF append_prefixD[OF \<open>v\<cdot>v \<le>p u\<cdot>(v\<cdot>v)\<close>] \<open>\<^bold>|u\<^bold>| \<le> \<^bold>|v\<^bold>|\<close>,
+      THEN pref_cancel'], symmetric].  
+ 
+lemma fac_marker: assumes "w \<le>p u\<cdot>w" and "u\<cdot>v\<cdot>u \<le>f w" 
+  shows "u \<cdot> v = v \<cdot> u"
+proof-
+  obtain p s where "w = p\<cdot>u\<cdot>v\<cdot>u\<cdot>s"
+    using \<open>u\<cdot>v\<cdot>u \<le>f w\<close>[unfolded fac_def]
+    by auto
+
+  hence "p\<cdot>u\<cdot>v\<cdot>u = u\<cdot>p\<cdot>u\<cdot>v"
+    using pref_marker[OF \<open>w \<le>p u\<cdot>w\<close>, unfolded \<open>w = p\<cdot>u\<cdot>v\<cdot>u\<cdot>s\<close>, of "p \<cdot> u \<cdot> v"]  
+    by force
+
+  thus "u\<cdot>v = v\<cdot>u"
+    using eqd_eq[of "p \<cdot> u" "v \<cdot> u" "u \<cdot> p" "u \<cdot> v", unfolded rassoc, OF _ swap_len]
+    by presburger
+qed
+
+lemma suf_marker_per_root: assumes "w \<le>p v \<cdot> w" and "p \<cdot> v \<cdot> u \<le>p w"
+  shows "u \<le>p v \<cdot> u"
+proof-
+  have "p \<cdot> v = v \<cdot> p"
+    using pref_marker[OF \<open>w \<le>p v \<cdot> w\<close>, of p] \<open>p \<cdot> v \<cdot> u \<le>p w\<close> by (auto simp add: prefix_def)
+  from pref_trans[OF \<open>p \<cdot> v \<cdot> u \<le>p w\<close>[unfolded lassoc this, unfolded rassoc] \<open>w \<le>p v \<cdot> w\<close>]
+  have "p \<cdot> u \<le>p w"
+    using pref_cancel by auto
+  from  ruler_le[OF this \<open>p \<cdot> v \<cdot> u \<le>p w\<close>]
+  have "p \<cdot> u \<le>p p \<cdot> v \<cdot> u" 
+    by force
+  thus ?thesis
+    using pref_cancel by fast
+qed
+
+lemma marker_fac_pref: assumes "u \<le>f r\<^sup>@k" and  "r \<le>p u" shows "u \<le>p r\<^sup>@k"
+  using assms
+proof (cases "r = \<epsilon>", simp)
+  assume "r \<noteq> \<epsilon>"
+  have "\<^bold>|u\<^bold>| \<le> \<^bold>|r\<^sup>@k\<^bold>|"
+    using \<open>u \<le>f r\<^sup>@k\<close> by force
+  obtain u' where "r \<cdot> u' = u"
+    using \<open>r \<le>p u\<close> by (auto simp add: prefix_def)
+  obtain p s where "p \<cdot> u \<cdot> s = r\<^sup>@k"
+    using \<open>u \<le>f r\<^sup>@k\<close> by blast
+  from suf_marker_per_root[of "r\<^sup>@k" r p "u' \<cdot> s", folded pow_comm, OF triv_pref] 
+  have "u' \<cdot> s \<le>p r \<cdot> (u' \<cdot> s)"
+    using \<open>p \<cdot> u \<cdot> s = r\<^sup>@k\<close>[folded \<open>r \<cdot> u' = u\<close>, unfolded rassoc] by fastforce
+  hence "u' \<cdot> s \<le>p r\<^sup>@k \<cdot> (u' \<cdot> s)"
+    using per_exp_pref by blast
+  hence "u \<le>p (r\<^sup>@k \<cdot> r) \<cdot> (u' \<cdot> s)"
+    unfolding \<open>r \<cdot> u' = u\<close>[symmetric] pow_Suc2[symmetric] pow_Suc rassoc 
+       by (auto simp add: prefix_def)
+  thus "u \<le>p r\<^sup>@k"
+    unfolding rassoc using \<open>\<^bold>|u\<^bold>| \<le> \<^bold>|r\<^sup>@k\<^bold>|\<close> by blast 
+qed
+
+lemma marker_fac_pref_len: assumes "u \<le>f r\<^sup>@k" and "t \<le>p u" and "\<^bold>|t\<^bold>| = \<^bold>|r\<^bold>|"
+  shows "u \<le>p t\<^sup>@k" 
+proof-
+  have "\<^bold>|u\<^bold>| \<le> \<^bold>|r\<^sup>@k\<^bold>|"
+    using \<open>u \<le>f r\<^sup>@k\<close> by fastforce
+  hence "\<^bold>|u\<^bold>| \<le> \<^bold>|t\<^sup>@k\<^bold>|"
+    unfolding pow_len \<open>\<^bold>|t\<^bold>| = \<^bold>|r\<^bold>|\<close>.
+  have "t \<le>f r\<^sup>@k"
+    using assms by blast
+  hence "t \<sim> r"
+    using \<open>\<^bold>|t\<^bold>| = \<^bold>|r\<^bold>|\<close> by (simp add: conjug_sym fac_pow_len_conjug) 
+  from fac_pow_conjug[OF \<open>u \<le>f r\<^sup>@k\<close> this]
+  have "u \<le>p t\<^sup>@Suc k"
+    using marker_fac_pref[OF _  \<open>t \<le>p u\<close>] by blast
+  thus "u \<le>p t\<^sup>@k"
+    using \<open>\<^bold>|u\<^bold>| \<le> \<^bold>|t\<^sup>@k\<^bold>|\<close> unfolding pow_Suc2 by blast
+qed
+
+lemma suf_marker_per_root': assumes "w \<le>p v \<cdot> w" and "p \<cdot> v \<cdot> u \<le>p w" and "v \<noteq> \<epsilon>"
+  shows "u \<le>p p \<cdot> u"
+proof-
+  have "p \<cdot> v = v \<cdot> p"
+    using pref_marker[OF \<open>w \<le>p v \<cdot> w\<close>, of p] \<open>p \<cdot> v \<cdot> u \<le>p w\<close> by (fastforce simp add: prefix_def)
+  from root_comm_root[OF suf_marker_per_root[OF \<open>w \<le>p v \<cdot> w\<close> \<open>p \<cdot> v \<cdot> u \<le>p w\<close>] this \<open>v \<noteq> \<epsilon>\<close>]
+  show "u \<le>p p \<cdot> u".
+qed
+
+lemma xyxy_conj_yxxy: assumes "x \<cdot> y \<cdot> x \<cdot> y \<sim> y \<cdot> x \<cdot> x \<cdot> y"
+  shows "x \<cdot> y = y \<cdot> x"
+proof-
+  from conjug_fac_sq[OF assms[symmetric]]
+  have "y \<cdot> x \<cdot> x \<cdot> y \<le>f (x \<cdot> y)\<^sup>@4"
+    unfolding power4_eq_xxxx rassoc.
+  from marker_fac_pref[reversed, 
+      OF this triv_suf[of "x\<cdot>y" "y\<cdot>x", unfolded rassoc]]
+  have "y \<cdot> x \<cdot> x \<cdot> y \<le>s (x \<cdot> y) \<^sup>@ 4".
+  hence "y \<cdot> x \<cdot> x \<cdot> y \<le>s (x\<cdot>y\<cdot>x\<cdot>y)\<cdot>x\<cdot>y\<cdot>x\<cdot>y"
+    unfolding power4_eq_xxxx rassoc.
+  from suf_prod_eq[OF this]
+  show "x \<cdot> y = y \<cdot> x"
+    by simp
+qed
+
+
+lemma per_glue: assumes "period u n" and "period v n" and "u \<le>p w" and "v \<le>s w" and
+              "\<^bold>|w\<^bold>| + n \<le> \<^bold>|u\<^bold>| + \<^bold>|v\<^bold>|"
+            shows "period w n"
+proof (rule indeces_period)
+  show  "w \<noteq> \<epsilon>"
+    using \<open>period u n\<close> \<open>u \<le>p w\<close> by force 
+  show "n \<noteq> 0"
+    using \<open>period u n\<close> zero_not_per by metis 
+  fix i assume "i + n < \<^bold>|w\<^bold>|"  
+  show "w ! i = w ! (i + n)"
+  proof (cases)
+    assume "i + n < \<^bold>|u\<^bold>|"
+    hence "w ! i = u ! i" and "w ! (i+n) = u ! (i+n)" 
+      using add_lessD1 \<open>u \<le>p w\<close> pref_index by metis+
+    thus "w ! i = w ! (i + n)"
+      unfolding \<open>w ! i = u ! i\<close> \<open>w ! (i+n) = u ! (i+n)\<close>
+      using period_indeces[OF \<open>period u n\<close> \<open>i + n < \<^bold>|u\<^bold>|\<close>]  by blast   
+  next
+    assume "\<not> i + n < \<^bold>|u\<^bold>|"     
+    obtain p where "w = p \<cdot> v"
+      using \<open>v \<le>s w\<close> by (auto simp add: suf_def)
+    have "\<not> i < \<^bold>|p\<^bold>|"
+      using  \<open>\<not> i + n < \<^bold>|u\<^bold>|\<close> \<open>\<^bold>|w\<^bold>| + n \<le> \<^bold>|u\<^bold>| + \<^bold>|v\<^bold>|\<close> unfolding lenarg[OF \<open>w = p \<cdot> v\<close>, unfolded lenmorph]
+      by auto
+    hence "w!i = v!(i - \<^bold>|p\<^bold>|)" and "w!(i+n) = v!((i - \<^bold>|p\<^bold>|) + n)"
+      unfolding \<open>w = p \<cdot> v\<close> nth_append by simp_all
+    have "i - \<^bold>|p\<^bold>| + n < \<^bold>|v\<^bold>|"
+      using \<open>\<not> i < \<^bold>|p\<^bold>|\<close> \<open>i + n < \<^bold>|w\<^bold>|\<close> \<open>w = p \<cdot> v\<close> by auto
+    from period_indeces[OF \<open>period v n\<close> this] 
+    show "w ! i = w ! (i + n)"
+      unfolding \<open>w!i = v!(i - \<^bold>|p\<^bold>|)\<close> \<open>w!(i+n) = v!(i - \<^bold>|p\<^bold>| + n)\<close>.
+  qed
+qed
+
+lemma per_glue_facs: assumes "u \<cdot> z \<le>f w\<^sup>@k" and "z \<cdot> v \<le>f w\<^sup>@m" and "\<^bold>|w\<^bold>| \<le> \<^bold>|z\<^bold>|" 
+  obtains l where "u \<cdot> z \<cdot> v \<le>f w\<^sup>@l"
+  using assms
+proof (cases "k = 0", simp)
+  assume "k \<noteq> 0" 
+  have "z \<le>f w\<^sup>@k"
+    using \<open>u \<cdot> z \<le>f w\<^sup>@k\<close> by blast
+  have "z \<le>f w\<^sup>@m"
+    using \<open>z \<cdot> v \<le>f w\<^sup>@m\<close> by blast
+  define t where "t = take \<^bold>|w\<^bold>| z"
+  have "\<^bold>|t\<^bold>| = \<^bold>|w\<^bold>|" and "t \<le>p z"
+    unfolding t_def using \<open>\<^bold>|w\<^bold>| \<le> \<^bold>|z\<^bold>|\<close> take_is_prefix by (force,blast)
+  hence "w \<sim> t"
+    using \<open>z \<le>f w\<^sup>@m\<close> by blast
+  from marker_fac_pref_len[OF \<open>z \<cdot> v \<le>f (w) \<^sup>@ m\<close> _ \<open>\<^bold>|t\<^bold>| = \<^bold>|w\<^bold>|\<close> ]
+  have "z \<cdot> v \<le>p t\<^sup>@m"
+    using  \<open>t \<le>p z\<close> by force
+  have "u \<cdot> z \<le>f t\<^sup>@Suc k"
+    using  fac_pow_conjug[OF \<open>u \<cdot> z \<le>f w\<^sup>@k\<close>  \<open>w \<sim> t\<close>[symmetric]]. 
+  with \<open>t \<le>p z\<close>
+  have "u \<le>s t\<^sup>@Suc k"
+    using mid_pow_pref_suf(2)[of u t "t\<inverse>\<^sup>>z" "Suc k"] lq_pref by metis 
+  have "(t\<^sup>@Suc k\<^sup><\<inverse>u)\<cdot> (u \<cdot> z \<cdot> v) \<cdot> (z \<cdot> v)\<inverse>\<^sup>>(t\<^sup>@m) = t\<^sup>@Suc k \<cdot> t\<^sup>@m" 
+    unfolding lassoc rq_suf[OF \<open>u \<le>s t\<^sup>@Suc k\<close>] unfolding rassoc cancel  using  lq_pref[OF \<open>z \<cdot> v \<le>p t\<^sup>@m\<close>] unfolding rassoc.
+  from facI[of "u \<cdot> z \<cdot> v" "t\<^sup>@Suc k\<^sup><\<inverse>u" "(z \<cdot> v)\<inverse>\<^sup>>(t\<^sup>@m)", unfolded this, folded add_exps]
+  obtain l where "u \<cdot> z \<cdot> v \<le>f t\<^sup>@l" 
+    by metis
+  from that[OF fac_pow_conjug[OF this \<open>w \<sim> t\<close>]]
+  show thesis.
+qed
+
+lemma per_fac_pow_fac: assumes "period w n" and "v \<le>f w" and "\<^bold>|v\<^bold>| = n"
+  obtains k where "w \<le>f v\<^sup>@k" 
+proof-
+  obtain m where "w \<le>f (take n w)\<^sup>@m"
+    using period_D3[OF \<open>period w n\<close>, THEN per_root_fac]  per_positive[OF \<open>period w n\<close>]  period_D1[OF \<open>period w n\<close>]
+      take_nemp by blast
+  obtain r s where "r \<cdot> s = v" and "s \<cdot> r = take n w"
+    using fac_per_conjug[OF assms, THEN conjugE]. 
+  hence "r \<cdot> (take n w)\<^sup>@m \<cdot> s = v\<^sup>@Suc m"
+    by (metis pow_slide)
+  from that[OF fac_trans, OF \<open>w \<le>f (take n w)\<^sup>@m\<close>] sublist_appendI[of "(take n w)\<^sup>@m" r s, unfolded this]
+  show thesis
+    by blast
+qed
+
+lemma refine_per: assumes "period w n" and "v \<le>f w" and "n \<le> \<^bold>|v\<^bold>|" and "period v k" and "k dvd n"
+  shows "period w k"
+proof-
+  have "n \<noteq> 0"
+    using \<open>period w n\<close> by auto
+  have "w \<noteq> \<epsilon>"
+    using \<open>period w n\<close> by auto
+  have "v \<noteq> \<epsilon>"
+    using \<open>period v k\<close> by auto
+  have "\<^bold>|take n w\<^bold>| = n"
+    using take_len[OF le_trans[OF \<open>n \<le> \<^bold>|v\<^bold>|\<close> fac_len[OF \<open>v \<le>f w\<close>]]]. 
+  have "\<^bold>|take n v\<^bold>| = n"
+    using take_len[OF \<open>n \<le> \<^bold>|v\<^bold>|\<close>]. 
+  have "period v n"
+    using  period_fac'[OF \<open>period w n\<close> \<open>v \<le>f w\<close> \<open>v \<noteq> \<epsilon>\<close>] by blast 
+  have "take n v \<le>f w"
+    using \<open>v \<le>f w\<close> \<open>n \<le> \<^bold>|v\<^bold>|\<close> sublist_order.dual_order.trans sublist_take by metis
+  have "period (take n v) k"
+    using \<open>period w n\<close> \<open>period v k\<close> per_positive per_pref' take_is_prefix take_nemp by metis
+  have "k \<le> n" 
+    using \<open>k dvd n\<close> \<open>n \<noteq> 0\<close> by auto
+  hence "take k (take n v) =  take k v"
+    using take_le_take by blast 
+  hence "(take k v)\<^sup>@(n div k) = take n v"
+    using  per_div[OF _ \<open>period (take n v) k\<close>, unfolded \<open>\<^bold>|take n v\<^bold>| = n\<close>, OF \<open>k dvd n\<close>] by presburger 
+  have "\<^bold>|take k v\<^bold>| = k"
+    using  order.trans[OF \<open>k \<le> n\<close> \<open>n \<le> \<^bold>|v\<^bold>|\<close>, THEN take_len].
+  obtain e where  "w \<le>f (take n v)\<^sup>@e"
+    using per_fac_pow_fac[OF \<open>period w n\<close> \<open>take n v \<le>f w\<close> \<open>\<^bold>|take n v\<^bold>| = n\<close>].
+  from per_fac[OF \<open>w \<noteq> \<epsilon>\<close> this[folded \<open>(take k v)\<^sup>@(n div k) = take n v\<close>, folded  power_mult]] 
+  show ?thesis 
+    unfolding \<open>\<^bold>|take k v\<^bold>| = k\<close>. 
+qed
+
+lemma xy_per_comp: assumes "x\<cdot>y \<le>p q\<cdot>x\<cdot>y"
+  and "q \<noteq> \<epsilon>" and "q \<bowtie> y"
+shows "x \<bowtie> y"
+proof(cases rule: pref_compE[OF \<open>q \<bowtie> y\<close>])
+  assume "q \<le>p y"
+  have "x\<cdot>q = q\<cdot>x"
+    using 
+      pref_cancel'[OF \<open>q \<le>p y\<close>, of x, THEN pref_trans, OF \<open>x \<cdot> y \<le>p q \<cdot> x \<cdot> y\<close>]
+    unfolding lassoc
+    using ruler_eq_len[OF _ triv_pref swap_len]
+    by blast
+  thus ?thesis
+    using assms(1) assms(2) pref_comp_sym root_comm_root
+      ruler_pref'' same_prefix_prefix by metis
+next
+  assume "y \<le>p q"
+  then show ?thesis
+    by (meson append_prefixD prefix_append ruler' assms)
+qed
+
+lemma prim_xyxyy: "x \<cdot> y \<noteq> y \<cdot> x \<Longrightarrow> primitive (x \<cdot> y \<cdot> x \<cdot> y \<cdot> y)"
+proof (rule prim_conjug)
+  show "y \<cdot> x \<cdot> y \<cdot> x \<cdot> y \<sim> x \<cdot> y \<cdot> x \<cdot> y \<cdot> y"
+    by (intro conjugI1) simp
+  show "x \<cdot> y \<noteq> y \<cdot> x \<Longrightarrow> primitive (y \<cdot> x \<cdot> y \<cdot> x \<cdot> y)"
+    by (intro iffD2[OF per_le_prim_iff[of _ "y \<cdot> x"]]) auto
+qed
+
+section \<open>Testing primitivity\<close>
+
+text\<open>This section defines a proof method used to prove that a word is primitive.\<close>
+
+lemma primitive_iff [code]: "primitive w \<longleftrightarrow> \<not> w \<le>f tl w \<cdot> butlast w"
+proof-
+  have "\<not> primitive w \<longleftrightarrow> w \<le>f tl w \<cdot> butlast w"
+  proof
+    assume "\<not> primitive w"
+    then obtain r k where "k \<noteq> 1" and "w = r\<^sup>@k"
+      unfolding primitive_def by blast
+    show "w \<le>f tl w \<cdot> butlast w"
+    proof (cases "w = \<epsilon>", simp)
+      assume "w \<noteq> \<epsilon>"
+      from this[unfolded \<open>w = r\<^sup>@k\<close>]
+      have  "k \<noteq> 0" 
+        using nemp_pow by blast
+      have "r \<noteq> \<epsilon>" 
+        using pow_zero \<open>r \<^sup>@ k \<noteq> \<epsilon>\<close> by force
+      have "r\<^sup>@(k-1) \<noteq> \<epsilon>" 
+        unfolding nemp_emp_pow[OF \<open>r \<noteq> \<epsilon>\<close>, of "k-1"]
+        using \<open>k \<noteq> 0\<close> \<open>k \<noteq> 1\<close> by force
+      have "r \<cdot> w \<cdot> r\<^sup>@(k-1) = w \<cdot> w"
+        unfolding \<open>w = r\<^sup>@k\<close> pows_comm[of r k "k - 1"]
+        unfolding lassoc cancel_right pop_pow_one[OF \<open>k \<noteq> 0\<close>]..
+      hence "[hd r] \<cdot> tl r \<cdot> w \<cdot> butlast (r\<^sup>@(k-1)) \<cdot> [last (r\<^sup>@(k-1))] = [hd w] \<cdot> tl w \<cdot> butlast w \<cdot> [last w]"
+        unfolding hd_tl[reversed, OF \<open>r\<^sup>@(k-1) \<noteq> \<epsilon>\<close>] hd_tl[reversed, OF \<open>w \<noteq> \<epsilon>\<close>]
+        unfolding lassoc hd_tl[OF \<open>r \<noteq> \<epsilon>\<close>] hd_tl[OF \<open>w \<noteq> \<epsilon>\<close>]. 
+      hence "tl r \<cdot> w \<cdot> butlast (r\<^sup>@(k-1)) = tl w \<cdot> butlast w"
+        by force
+      thus ?thesis
+        unfolding fac_def by metis
+    qed
+  next 
+    assume "w \<le>f tl w \<cdot> butlast w"
+    show "\<not> primitive w"
+    proof (cases "w = \<epsilon>", simp)
+      assume "w \<noteq> \<epsilon>"
+      from facE[OF \<open>w \<le>f tl w \<cdot> butlast w\<close>]
+      obtain p s where "tl w \<cdot> butlast w = p \<cdot> w \<cdot> s".
+      have "[hd w] \<cdot> (p \<cdot> w \<cdot> s) \<cdot> [last w] = w \<cdot> w" 
+        unfolding \<open>tl w \<cdot> butlast w = p \<cdot> w \<cdot> s\<close>[symmetric]
+        unfolding lassoc hd_tl[OF \<open>w \<noteq> \<epsilon>\<close>]
+        unfolding rassoc hd_tl[reversed, OF \<open>w \<noteq> \<epsilon>\<close>]..
+      from prim_overlap_sqE[of w "[hd w] \<cdot> p" "s \<cdot> [last w]" False, unfolded rassoc, OF _  this[unfolded rassoc]]
+      show "\<not> primitive w" 
+        by blast
+    qed
+  qed
+  thus ?thesis by blast
+qed
+
+method primitivity_inspection =  (insert method_facts, use nothing in 
+    \<open>simp add: primitive_iff pop_pow_one\<close>)
+
+(* Internal: Examples moved to ExamplesMethod.thy *)
+
+(* subsection Examples *)
+
+(* lemma "x \<noteq> y \<Longrightarrow> primitive [x,y,x,x,y,x,x,y,y,x,y,x,x,y,x,x,y,y,x]" *)
+  (* by primitivity_inspection *)
+
+(* lemma "\<not> primitive [x,y,x,y]" *)
+  (* by primitivity_inspection *)
+
+(* lemma "x \<noteq> y \<Longrightarrow> primitive (([x,y,x,y]\<^sup>@6)\<cdot>[x])" *)
+  (* by primitivity_inspection *)
+
+(* lemma "x \<noteq> y \<Longrightarrow> primitive ([x]\<cdot>([x,y,x,y]\<^sup>@6)\<cdot>[x])" *)
+  (* by primitivity_inspection *)
+
+(* lemma "x \<noteq> y \<Longrightarrow> n \<noteq> 0 \<Longrightarrow> primitive (([x,y,x,y]\<^sup>@n)\<cdot>[x])" *)
+  (* oops \<comment> \<open>this is out of scope of the method\<close> *)
 
 end
\ No newline at end of file
diff --git a/thys/Combinatorics_Words/Equations_Basic.thy b/thys/Combinatorics_Words/Equations_Basic.thy
new file mode 100644
--- /dev/null
+++ b/thys/Combinatorics_Words/Equations_Basic.thy
@@ -0,0 +1,1632 @@
+(*  Title:      CoW_Equations/Equations_Basic.thy
+    Author:     Štěpán Holub, Charles University
+    Author:     Martin Raška, Charles University
+    Author:     Štěpán Starosta, CTU in Prague
+
+Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/
+*)
+
+theory Equations_Basic
+  imports 
+    Periodicity_Lemma 
+    Lyndon_Schutzenberger 
+    Submonoids 
+    Binary_Code_Morphisms
+begin
+
+chapter "Equations on words - basics"
+
+text 
+\<open>Contains various nontrivial auxiliary or rudimentary facts related to equations. Often moderately advanced or even fairly advanced.
+ May change significantly in the future.\<close>
+
+section \<open>Factor interpretation\<close>
+
+definition factor_interpretation :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> 'a list list \<Rightarrow> bool" ("_ _ _ \<sim>\<^sub>\<I> _" [51,51,51,51] 60)
+  where "factor_interpretation p u s ws = (p <p hd ws \<and> s <s last ws \<and> p \<cdot> u \<cdot> s = concat ws)"
+
+lemma fac_interpret_nemp:  "u \<noteq> \<epsilon> \<Longrightarrow> p u s \<sim>\<^sub>\<I> ws \<Longrightarrow> ws \<noteq> \<epsilon>"
+  unfolding factor_interpretation_def by auto
+
+lemma fac_interpretE: assumes "p u s \<sim>\<^sub>\<I> ws"
+  shows "p <p hd ws" and "s <s last ws" and "p \<cdot> u \<cdot> s = concat ws"
+  using assms unfolding factor_interpretation_def by blast+ 
+
+lemma fac_interpretI: 
+  "p <p hd ws \<Longrightarrow> s <s last ws \<Longrightarrow> p \<cdot> u \<cdot> s = concat ws \<Longrightarrow> p u s \<sim>\<^sub>\<I> ws"
+  unfolding factor_interpretation_def by blast
+
+lemma obtain_fac_interpret: assumes  "pu \<cdot> u \<cdot> su = concat ws" and "u \<noteq> \<epsilon>" 
+  obtains ps ss p s vs where "p u s \<sim>\<^sub>\<I> vs" and "ps \<cdot> vs \<cdot> ss = ws" and "concat ps \<cdot> p = pu" and
+    "s \<cdot> concat ss = su"  
+  using assms
+proof (induction "\<^bold>|ws\<^bold>|" arbitrary: ws pu su thesis rule: less_induct)
+  case less
+  then show ?case
+  proof-
+    have "ws \<noteq> \<epsilon>"
+      using \<open>u \<noteq> \<epsilon>\<close> \<open>pu \<cdot> u \<cdot> su = concat ws\<close> by force
+    have "\<^bold>|tl ws\<^bold>| < \<^bold>|ws\<^bold>|" and "\<^bold>|butlast ws\<^bold>| < \<^bold>|ws\<^bold>|"
+      using \<open>ws \<noteq> \<epsilon>\<close> by force+
+    show thesis
+    proof (cases) 
+      assume "hd ws \<le>p pu \<or> last ws \<le>s su"
+      then show thesis
+      proof 
+        assume "hd ws \<le>p pu"
+        from prefixE[OF this]
+        obtain pu' where "pu = hd ws \<cdot> pu'".
+        from \<open>pu \<cdot> u \<cdot> su = concat ws\<close>[unfolded this, folded arg_cong[OF hd_tl[OF \<open>ws \<noteq> \<epsilon>\<close>], of concat]]
+        have "pu' \<cdot> u \<cdot> su = concat (tl ws)"
+          by force
+        from less.hyps[OF \<open>\<^bold>|tl ws\<^bold>| < \<^bold>|ws\<^bold>|\<close> _ \<open>pu' \<cdot> u \<cdot> su = concat (tl ws)\<close> \<open>u \<noteq> \<epsilon>\<close>] 
+        obtain p s vs ps' ss where "p u s \<sim>\<^sub>\<I> vs" and  "ps' \<cdot> vs \<cdot> ss = tl ws" and  "concat ps' \<cdot> p = pu'" 
+          and "s \<cdot> concat ss = su".
+        have "(hd ws # ps') \<cdot> vs \<cdot> ss = ws" 
+          using \<open>ws \<noteq> \<epsilon>\<close> \<open>ps' \<cdot> vs \<cdot> ss = tl ws\<close> by auto
+        have "concat (hd ws # ps') \<cdot> p = pu"
+          using \<open>concat ps' \<cdot> p = pu'\<close> unfolding \<open>pu = hd ws \<cdot> pu'\<close> by fastforce
+        from less.prems(1)[OF \<open>p u s \<sim>\<^sub>\<I> vs\<close> \<open>(hd ws # ps') \<cdot> vs \<cdot> ss = ws\<close> \<open>concat (hd ws # ps') \<cdot> p = pu\<close> \<open>s \<cdot> concat ss = su\<close>]
+        show thesis.
+      next
+        assume "last ws \<le>s su"
+        from suffixE[OF this]
+        obtain su' where "su = su' \<cdot> last ws".
+        from \<open>pu \<cdot> u \<cdot> su = concat ws\<close>[unfolded this, folded arg_cong[OF hd_tl[reversed, OF \<open>ws \<noteq> \<epsilon>\<close>], of concat]]
+        have "pu \<cdot> u \<cdot> su' = concat (butlast ws)"
+          by force
+        from less.hyps[OF \<open>\<^bold>|butlast ws\<^bold>| < \<^bold>|ws\<^bold>|\<close> _ \<open>pu \<cdot> u \<cdot> su' = concat (butlast ws)\<close> \<open>u \<noteq> \<epsilon>\<close>] 
+        obtain p s vs ps ss' where "p u s \<sim>\<^sub>\<I> vs" and  "ps \<cdot> vs \<cdot> ss' = butlast ws" and "concat ps \<cdot> p = pu" and "s \<cdot> concat ss' = su'".
+        have "ps \<cdot> vs \<cdot> (ss' \<cdot> [last ws]) = ws" 
+          using  append_butlast_last_id[OF \<open>ws \<noteq> \<epsilon>\<close>, folded \<open>ps \<cdot> vs \<cdot> ss' = butlast ws\<close>] unfolding rassoc. 
+        have "s \<cdot> concat (ss' \<cdot> [last ws]) = su"
+          using \<open>s \<cdot> concat ss' = su'\<close> \<open>su = su' \<cdot> last ws\<close> by fastforce
+        from less.prems(1)[OF \<open>p u s \<sim>\<^sub>\<I> vs\<close> \<open>ps \<cdot> vs \<cdot> (ss' \<cdot> [last ws]) = ws\<close> \<open>concat ps \<cdot> p = pu\<close>  \<open>s \<cdot> concat (ss' \<cdot> [last ws]) = su\<close>] 
+        show thesis.
+      qed
+    next
+      assume not_or: "\<not> (hd ws \<le>p pu \<or> last ws \<le>s su)"
+      hence "pu <p hd ws" and "su <s last ws"
+        using ruler[OF concat_hd_pref[OF \<open>ws \<noteq> \<epsilon>\<close>] prefI'[OF \<open>pu \<cdot> u \<cdot> su = concat ws\<close>[symmetric]]] 
+          ruler[reversed, OF concat_hd_pref[reversed, OF \<open>ws \<noteq> \<epsilon>\<close>] prefI'[reversed, OF \<open>pu \<cdot> u \<cdot> su = concat ws\<close>[symmetric, unfolded lassoc]]] by auto 
+      from fac_interpretI[OF this \<open>pu \<cdot> u \<cdot> su = concat ws\<close>]
+      have "pu u su \<sim>\<^sub>\<I> ws".
+      from less.prems(1)[OF this, of \<epsilon> \<epsilon>]
+      show thesis by simp
+    qed
+  qed
+qed
+
+lemma obtain_fac_interp': assumes "u \<le>f concat ws" and "u \<noteq> \<epsilon>" 
+  obtains p s vs where "p u s \<sim>\<^sub>\<I> vs" and "vs \<le>f ws" 
+proof-
+  from facE[OF \<open>u \<le>f concat ws\<close>]
+  obtain pu su where "concat ws = pu \<cdot> u \<cdot> su".
+  from obtain_fac_interpret[OF this[symmetric] \<open>u \<noteq> \<epsilon>\<close>] that
+  show thesis
+    using facI' by metis 
+qed     
+
+lemma rev_in_set_map_rev_conv: "rev u \<in> set (map rev ws) \<longleftrightarrow> u \<in> set ws"
+  by auto
+
+lemma rev_fac_interp: assumes "p u s \<sim>\<^sub>\<I> ws" shows "(rev s) (rev u) (rev p) \<sim>\<^sub>\<I> rev (map rev ws)"
+proof (rule fac_interpretI)
+  note fac_interpretE[OF assms]
+  show \<open>rev s <p hd (rev (map rev ws))\<close>
+    using \<open>s <s last ws\<close>
+    by (metis \<open>p <p hd ws\<close> \<open>p \<cdot> u \<cdot> s = concat ws\<close> append_is_Nil_conv concat.simps(1) hd_rev last_map list.simps(8) rev_is_Nil_conv strict_suffix_to_prefix)
+  show "rev p <s last (rev (map rev ws))"
+    using \<open> p <p hd ws\<close>
+    by (metis \<open>p \<cdot> u \<cdot> s = concat ws\<close> \<open>s <s last ws\<close> append_is_Nil_conv concat.simps(1) last_rev list.map_sel(1) list.simps(8) rev_is_Nil_conv spref_rev_suf_iff)
+  show "rev s \<cdot> rev u \<cdot> rev p = concat (rev (map rev ws))"
+    using \<open>p \<cdot> u \<cdot> s = concat ws\<close>
+    by (metis append_assoc rev_append rev_concat rev_map)
+qed       
+
+lemma rev_fac_interp_iff [reversal_rule]: "(rev s) (rev u) (rev p) \<sim>\<^sub>\<I> rev (map rev ws) \<longleftrightarrow> p u s \<sim>\<^sub>\<I> ws"
+  using rev_fac_interp
+  by (metis (no_types, lifting) map_rev_involution rev_map rev_rev_ident) 
+
+section Miscellanea
+
+subsection \<open>Mismatch additions\<close>
+
+lemma mismatch_pref_comm_len: assumes "w1 \<in> \<langle>{u,v}\<rangle>" and "w2 \<in> \<langle>{u,v}\<rangle>" and "p \<le>p w1" 
+  "u \<cdot> p \<le>p v \<cdot> w2" and "\<^bold>|v\<^bold>| \<le> \<^bold>|p\<^bold>|"
+shows "u \<cdot> v = v \<cdot> u"
+proof (rule ccontr)
+  assume "u \<cdot> v \<noteq> v \<cdot> u"
+  then interpret binary_code u v 
+    by unfold_locales
+  show False 
+    using bin_code_prefs bin_code_prefs[OF \<open>w1 \<in> \<langle>{u,v}\<rangle>\<close> \<open>p \<le>p w1\<close> \<open>w2 \<in> \<langle>{u,v}\<rangle>\<close> \<open>\<^bold>|v\<^bold>| \<le> \<^bold>|p\<^bold>|\<close>]
+      \<open>u \<cdot> p \<le>p v \<cdot> w2\<close> bin_code_prefs
+    by blast
+qed
+
+lemma mismatch_pref_comm: assumes "w1 \<in> \<langle>{u,v}\<rangle>" and "w2 \<in> \<langle>{u,v}\<rangle>" and 
+  "u \<cdot> w1 \<cdot> v \<le>p v \<cdot> w2 \<cdot> u"
+shows "u \<cdot> v = v \<cdot> u" 
+  using assms  by mismatch
+
+lemma mismatch_eq_comm: assumes "w1 \<in> \<langle>{u,v}\<rangle>" and "w2 \<in> \<langle>{u,v}\<rangle>" and 
+  "u \<cdot> w1 = v \<cdot> w2"
+shows "u \<cdot> v = v \<cdot> u"
+  using assms  by mismatch
+
+lemmas mismatch_suf_comm = mismatch_pref_comm[reversed] and
+  mismatch_suf_comm_len = mismatch_pref_comm_len[reversed, unfolded rassoc]
+
+subsection  \<open>Conjugate words with conjugate periods\<close>
+
+lemma conj_pers_conj_comm_aux:
+  assumes "(u \<cdot> v)\<^sup>@Suc k \<cdot> u = r \<cdot> s" and "(v \<cdot> u)\<^sup>@Suc l \<cdot> v = (s \<cdot> r)\<^sup>@Suc (Suc m)"
+  shows "u \<cdot> v =  v \<cdot> u"
+proof (rule nemp_comm)
+  assume "u \<noteq> \<epsilon>" and "v \<noteq> \<epsilon>" hence "u \<cdot> v \<noteq> \<epsilon>" and "v \<cdot> u \<noteq> \<epsilon>" by blast+
+  have "l \<noteq> 0" \<comment> \<open>impossible by a length argument\<close>
+  proof (rule notI)
+    assume "l = 0"
+    hence "v \<cdot> u \<cdot> v = (s \<cdot> r)\<^sup>@ Suc(Suc m)"
+      using assms(2) by simp
+    from lenarg[OF assms(1)] \<open>u \<noteq> \<epsilon>\<close>
+    have "\<^bold>|v \<cdot> u\<^bold>| + \<^bold>|u\<^bold>| \<le> \<^bold>|r \<cdot> s\<^bold>|" 
+      unfolding lenmorph pow_len by simp 
+    hence "\<^bold>|v \<cdot> u \<cdot> v \<cdot> u\<^bold>| \<le> 2*\<^bold>|r \<cdot> s\<^bold>|"
+      unfolding lenmorph pow_len by simp 
+    hence "\<^bold>|v \<cdot> u \<cdot> v\<^bold>| < 2*\<^bold>|r \<cdot> s\<^bold>|"
+      unfolding lenmorph pow_len using nemp_len[OF \<open>u \<noteq> \<epsilon>\<close>] by linarith
+    from this[unfolded \<open>v \<cdot> u \<cdot> v = (s \<cdot> r)\<^sup>@ Suc(Suc m)\<close>]
+    show False
+      unfolding lenmorph pow_len by simp
+  qed
+    \<comment> \<open>we can therefore use the Periodicity lemma\<close>
+  then obtain l' where "l = Suc l'"
+    using not0_implies_Suc by auto
+  let ?w = "(v \<cdot> u)\<^sup>@Suc l \<cdot> v"
+  have per1: "?w \<le>p (v \<cdot> u) \<cdot> ?w"
+    using \<open>v \<cdot> u \<noteq> \<epsilon>\<close>  per_rootD[of ?w "v \<cdot> u", unfolded per_eq] by blast
+  have per2: "?w \<le>p (s \<cdot> r) \<cdot> ?w"
+    unfolding  assms(2) using pref_pow_ext' by blast 
+  have len: "\<^bold>|v \<cdot> u\<^bold>| + \<^bold>|s \<cdot> r\<^bold>|  \<le> \<^bold>|?w\<^bold>|"
+  proof-
+    have  len1: "2*\<^bold>|s \<cdot> r\<^bold>| \<le> \<^bold>|?w\<^bold>|"
+      unfolding \<open>(v \<cdot> u)\<^sup>@Suc l \<cdot> v = (s \<cdot> r)\<^sup>@Suc (Suc m)\<close> lenmorph pow_len by simp
+    moreover have len2: "2*\<^bold>|v \<cdot> u\<^bold>|  \<le> \<^bold>|?w\<^bold>|"
+      unfolding lenmorph pow_len \<open>l = Suc l'\<close> by simp 
+    ultimately show ?thesis
+      using len1 len2 by linarith
+  qed
+  from two_pers[OF per1 per2 len]
+  have "(v \<cdot> u) \<cdot> (s \<cdot> r) = (s \<cdot> r) \<cdot> (v \<cdot> u)".
+  hence "(v \<cdot> u)\<^sup>@Suc l \<cdot> (s \<cdot> r)\<^sup>@Suc (Suc m) = (s \<cdot> r)\<^sup>@Suc (Suc m) \<cdot> (v \<cdot> u)\<^sup>@Suc l"
+    using comm_add_exps by blast
+  from comm_drop_exp'[OF this[folded assms(2), unfolded rassoc cancel]]
+  show "u \<cdot> v = v \<cdot> u"
+    unfolding rassoc cancel.
+qed
+
+lemma conj_pers_conj_comm: assumes "\<rho> (v \<cdot> (u \<cdot> v)\<^sup>@(Suc k)) \<sim> \<rho> ((u \<cdot> v)\<^sup>@(Suc m) \<cdot> u)"
+  shows "u \<cdot> v = v \<cdot> u"
+proof (rule nemp_comm)
+  let ?v = "v \<cdot> (u \<cdot> v)\<^sup>@(Suc k)" and ?u = "(u \<cdot> v)\<^sup>@(Suc m) \<cdot> u"
+  assume "u \<noteq> \<epsilon>" and "v \<noteq> \<epsilon>"
+  hence "u \<cdot> v \<noteq> \<epsilon>" and "?v \<noteq> \<epsilon>" and "?u \<noteq> \<epsilon>" by simp_all
+  obtain r s where "r \<cdot> s = \<rho> ?v" and "s \<cdot> r = \<rho> ?u"
+    using conjugE[OF assms]. 
+  then obtain k1 k2 where "?v = (r \<cdot> s)\<^sup>@Suc k1" and "?u = (s \<cdot> r)\<^sup>@Suc k2"
+    using primroot_expE[OF  \<open>?v \<noteq> \<epsilon>\<close>] primroot_expE[OF \<open>?u \<noteq> \<epsilon>\<close>] by metis 
+  hence eq: "(s \<cdot> r)\<^sup>@Suc k2 \<cdot> (r \<cdot> s)\<^sup>@Suc k1 = (u \<cdot> v)\<^sup>@(Suc m + Suc 0 + Suc k)" 
+    unfolding add_exps pow_one rassoc by simp
+  have ineq: "2 \<le> Suc m + Suc 0 + Suc k"
+    by simp
+  consider (two_two) "2 \<le> Suc k1 \<and> 2 \<le> Suc k2"|
+    (one_one) "Suc k1 = 1 \<and> Suc k2 = 1" |
+    (two_one) "2 \<le> Suc k1 \<and> Suc k2 = 1" |
+    (one_two) "Suc k1 = 1 \<and> 2 \<le> Suc k2"
+    unfolding numerals One_nat_def Suc_le_mono by fastforce    
+  then show "u \<cdot> v = v \<cdot> u" 
+  proof (cases)
+    case (two_two)
+    with Lyndon_Schutzenberger(1)[OF eq _ _ ineq]
+    have "(s \<cdot> r) \<cdot> (r \<cdot> s) = (r \<cdot> s) \<cdot> (s \<cdot> r)"
+      using eqd_eq[of "s \<cdot> r" "r \<cdot> s" "r \<cdot> s" "s \<cdot> r"] by fastforce
+
+    from comm_add_exps[OF this, of "Suc k2" "Suc k1", folded \<open>?v = (r \<cdot> s)\<^sup>@Suc k1\<close> \<open>?u = (s \<cdot> r)\<^sup>@Suc k2\<close>, folded shift_pow, unfolded pow_Suc]
+    have "(u \<cdot> v) \<cdot> ((u \<cdot> v) \<^sup>@ m \<cdot> u) \<cdot> ((v \<cdot> u) \<cdot> (v \<cdot> u) \<^sup>@ k \<cdot> v) = (v \<cdot> u) \<cdot> (((v \<cdot> u) \<^sup>@ k) \<cdot> v) \<cdot> ((u \<cdot> v) \<cdot> (u \<cdot> v) \<^sup>@ m \<cdot> u)"
+      unfolding rassoc.
+    from eqd_eq[OF this, unfolded lenmorph]
+    show "u \<cdot> v =  v \<cdot> u"
+      by fastforce
+  next
+    case (one_one)
+    hence "(s \<cdot> r) \<^sup>@ Suc k2 \<cdot> (r \<cdot> s) \<^sup>@ Suc k1 = (s \<cdot> r) \<cdot> (r \<cdot> s)" 
+      using pow_one by simp
+    from eq[unfolded conjunct1[OF one_one] conjunct2[OF one_one] pow_one']
+         pow_nemp_imprim[OF ineq, folded eq[unfolded this]] 
+         Lyndon_Schutzenberger_conjug[of "s \<cdot> r" "r \<cdot> s", OF conjugI']  
+    have "(s \<cdot> r) \<cdot> (r \<cdot> s) = (r \<cdot> s) \<cdot> (s \<cdot> r)" by metis
+
+    from comm_add_exps[OF this, of "Suc k2" "Suc k1", folded \<open>?v = (r \<cdot> s)\<^sup>@Suc k1\<close> \<open>?u = (s \<cdot> r)\<^sup>@Suc k2\<close>, folded shift_pow, unfolded pow_Suc]
+    have "(u \<cdot> v) \<cdot> ((u \<cdot> v) \<^sup>@ m \<cdot> u) \<cdot> ((v \<cdot> u) \<cdot> (v \<cdot> u) \<^sup>@ k \<cdot> v) = (v \<cdot> u) \<cdot> (((v \<cdot> u) \<^sup>@ k) \<cdot> v) \<cdot> ((u \<cdot> v) \<cdot> (u \<cdot> v) \<^sup>@ m \<cdot> u)"
+      unfolding rassoc.
+    from eqd_eq[OF this, unfolded lenmorph]
+    show "u \<cdot> v =  v \<cdot> u"
+      by fastforce
+  next
+    case (two_one)
+    hence "?u = s \<cdot> r"
+      using \<open>?u = (s \<cdot> r)\<^sup>@Suc k2\<close> by simp
+    obtain l where "Suc k1 = Suc (Suc l)"
+      using conjunct1[OF two_one, unfolded numerals(2)] Suc_le_D le_Suc_eq by metis 
+    from \<open>?v = (r \<cdot> s)\<^sup>@Suc k1\<close>[folded shift_pow, unfolded this]  
+    have "(v \<cdot> u) \<^sup>@ Suc k \<cdot> v = (r \<cdot> s)\<^sup>@Suc (Suc l)".
+    from conj_pers_conj_comm_aux[OF \<open>?u = s \<cdot> r\<close> this]
+    show "u \<cdot> v = v \<cdot> u".
+  next
+    case (one_two)
+    hence "?v = r \<cdot> s"
+      using \<open>?v = (r \<cdot> s)\<^sup>@Suc k1\<close> by simp
+    obtain l where "Suc k2 = Suc (Suc l)"
+      using conjunct2[OF one_two, unfolded numerals(2)] Suc_le_D le_Suc_eq by metis 
+    from \<open>?u = (s \<cdot> r)\<^sup>@Suc k2\<close>[unfolded this]  
+    have "(u \<cdot> v) \<^sup>@ Suc m \<cdot> u = (s \<cdot> r) \<^sup>@ Suc (Suc l)".
+    from conj_pers_conj_comm_aux[OF \<open>?v = r \<cdot> s\<close>[folded shift_pow] this, symmetric] 
+    show "u \<cdot> v = v \<cdot> u".
+  qed
+qed
+
+hide_fact conj_pers_conj_comm_aux
+
+subsection \<open>Covering uvvu\<close>
+
+lemma uv_fac_uvv: assumes "p \<cdot> u \<cdot> v \<le>p u \<cdot> v \<cdot> v" and "p \<noteq> \<epsilon>" and "p \<le>s w" and "w \<in> \<langle>{u,v}\<rangle>"
+  shows "u \<cdot> v = v \<cdot> u"
+proof (rule nemp_comm)
+  assume "u \<noteq> \<epsilon>" and "v \<noteq> \<epsilon>" 
+  obtain s where "u \<cdot> v \<cdot> v = p \<cdot> u \<cdot> v \<cdot> s"
+    using \<open>p \<cdot> u \<cdot> v \<le>p u \<cdot> v \<cdot> v\<close> by (auto simp add: prefix_def)
+  obtain p' where "u \<cdot> p' = p \<cdot> u" and "p' \<cdot> v \<cdot> s = v \<cdot> v"
+    using eqdE[of  u "v \<cdot> v" "p \<cdot> u" "v \<cdot> s", unfolded rassoc, OF \<open>u \<cdot> v \<cdot> v = p \<cdot> u \<cdot> v \<cdot> s\<close> suf_len'].
+  hence "p' \<noteq> \<epsilon>"
+    using \<open>p \<noteq> \<epsilon>\<close> by force
+  have "p' \<cdot> v \<cdot> s = v \<cdot> v"
+    using \<open>u \<cdot> v \<cdot> v = p \<cdot> u \<cdot> v \<cdot> s\<close> \<open>u \<cdot> p' = p \<cdot> u\<close> cancel rassoc by metis
+  from mid_sq[OF this]
+  have "v \<cdot> p' = p' \<cdot> v" by simp 
+  from this primroot_prim[OF \<open>v \<noteq> \<epsilon>\<close>]
+  obtain r where "r = \<rho> v" and "r = \<rho> p'" and "primitive r"
+    unfolding comm_primroots[OF \<open>v \<noteq> \<epsilon>\<close> \<open>p' \<noteq> \<epsilon>\<close>] by blast+  
+  have "w \<in> \<langle>{u, v}\<rangle>" by fact
+  obtain m where "p' = r\<^sup>@m \<cdot> r"
+    using   primroot_expE[OF \<open>p' \<noteq> \<epsilon>\<close>, folded \<open>r = \<rho> p'\<close>] power_Suc2 by metis
+  hence "(u \<cdot> r\<^sup>@m) \<cdot> r \<le>s (r \<cdot> w) \<cdot> u"
+    using \<open>u \<cdot> p' = p \<cdot> u\<close> \<open>p \<le>s w\<close> unfolding suf_def by force
+
+  note mismatch_rule = mismatch_suf_comm_len[OF _ _ _ this, of "u \<cdot> r\<^sup>@m"]
+  have "u \<cdot> r = r \<cdot> u"
+  proof (rule mismatch_rule)  
+    have "w \<in> \<langle>{r, u}\<rangle>" 
+      using \<open>w \<in> \<langle>{u, v}\<rangle>\<close> \<open>r = \<rho> v\<close> \<open>v \<noteq> \<epsilon>\<close> doubleton_eq_iff gen_prim by metis
+    thus "r \<cdot> w \<in> \<langle>{r, u}\<rangle>" by blast 
+    show "\<^bold>|u\<^bold>| \<le> \<^bold>|u \<cdot> r \<^sup>@ m\<^bold>|" by simp
+    show "u \<cdot> r\<^sup>@m \<in> \<langle>{r, u}\<rangle>"
+      by (simp add: gen_in hull.prod_cl power_in) 
+  qed simp
+  thus "u \<cdot> v = v \<cdot> u"
+    using \<open>r = \<rho> v\<close> comm_primroot_conv by auto
+qed
+
+lemmas uv_fac_uvv_suf = uv_fac_uvv[reversed, unfolded rassoc]
+
+lemma assumes "p \<cdot> u \<cdot> v \<cdot> u \<cdot> q = u \<cdot> v \<cdot> v \<cdot> u" and "p \<noteq> \<epsilon>" and "q \<noteq> \<epsilon>"
+  shows "u \<cdot> v = v \<cdot> u"
+  oops \<comment> \<open>counterexample: v = abaaba, u = a, p = aab, q = baa; aab.a.abaaba.a.baa = a.abaaba.abaaba.a\<close>
+
+lemma uvu_pref_uvv: assumes "p \<cdot> u \<cdot> v \<cdot> v \<cdot> s = u \<cdot> v \<cdot> u \<cdot> q" and
+  "p <p u" and "q \<le>p w" and  "s \<le>p  w'" and 
+  "w \<in> \<langle>{u,v}\<rangle>" and "w' \<in> \<langle>{u,v}\<rangle>" and "\<^bold>|u\<^bold>| \<le> \<^bold>|s\<^bold>|"
+shows "u \<cdot> v = v \<cdot> u"
+proof(rule nemp_comm)
+  \<comment> \<open>Preliminaries\<close>
+  assume "u \<noteq> \<epsilon>" and "v \<noteq> \<epsilon>"
+  hence "u \<cdot> v \<noteq> \<epsilon>" by blast
+  have "\<^bold>|p \<cdot> u \<cdot> v\<^bold>| \<le> \<^bold>|u \<cdot> v \<cdot> u\<^bold>|"
+    using \<open>p <p u\<close> unfolding lenmorph  by (simp add: prefix_length_less less_imp_le)
+
+\<comment> \<open>p commutes with @{term "u \<cdot> v"}\<close>  
+  have "p \<cdot> (u \<cdot> v) = (u \<cdot> v) \<cdot> p"
+    by (rule pref_marker[of "u \<cdot> v \<cdot> u"], simp, rule eq_le_pref, unfold rassoc, fact+)
+
+\<comment> \<open>equality which will yield the main result\<close>
+  have "p \<cdot> v \<cdot> s = u  \<cdot> q" 
+  proof- 
+    have "((u \<cdot> v) \<cdot> p) \<cdot> v \<cdot>  s = (u \<cdot> v) \<cdot> u \<cdot> q"
+      unfolding \<open>p \<cdot> u \<cdot> v = (u \<cdot> v) \<cdot> p\<close>[symmetric] unfolding rassoc by fact 
+    from this[unfolded rassoc cancel]
+    show ?thesis.
+  qed
+  hence "p \<cdot> v \<cdot> s \<le>p u \<cdot> w"
+    using \<open>q \<le>p w\<close> by force
+
+  then show "u \<cdot> v = v \<cdot> u"
+  proof (cases "p = \<epsilon>")
+    assume "p = \<epsilon>"
+    thm mismatch_pref_comm 
+    note local_rule = mismatch_pref_comm_len[OF _ _ \<open>s \<le>p w'\<close> _ \<open>\<^bold>|u\<^bold>| \<le> \<^bold>|s\<^bold>|\<close>, of v w, symmetric]
+    show "u \<cdot> v = v \<cdot> u"
+    proof (rule local_rule)
+      show "w \<in> \<langle>{v, u}\<rangle>"
+        using \<open>w \<in> \<langle>{u,v}\<rangle>\<close> by (simp add: insert_commute) 
+      show "v \<cdot> s \<le>p u \<cdot> w"
+        using \<open>p = \<epsilon>\<close> \<open>p \<cdot> v \<cdot> s = u \<cdot> q\<close> \<open>q \<le>p w\<close> by simp 
+      show "w' \<in> \<langle>{v, u}\<rangle>" 
+        using \<open>w' \<in> \<langle>{u, v}\<rangle>\<close> insert_commute by metis 
+    qed 
+  next
+    assume "p \<noteq> \<epsilon>" 
+    show "u \<cdot> v = v \<cdot> u"
+    proof (rule ccontr)
+      obtain r where "r = \<rho> p" and "r = \<rho> (u \<cdot> v)"
+        using  \<open>p \<cdot> u \<cdot> v = (u \<cdot> v) \<cdot> p\<close>[symmetric, unfolded comm_primroots[OF \<open>u \<cdot> v \<noteq> \<epsilon>\<close> \<open>p \<noteq> \<epsilon>\<close>]] by blast
+      obtain k m where "r\<^sup>@k = p" and "r\<^sup>@m = u \<cdot> v"
+        using \<open>u \<cdot> v \<noteq> \<epsilon>\<close> \<open>p \<noteq> \<epsilon>\<close> \<open>r = \<rho> p\<close> \<open>r = \<rho> (u \<cdot> v)\<close> primroot_expE by metis 
+          \<comment> \<open>Idea:
+        maximal r-prefix of @{term "p \<cdot> v \<cdot> s"} is @{term "p \<cdot> bin_code_lcp"}, since the maximal r-prefix of 
+        @{term "v \<cdot> u"} is @{term "v \<cdot> u \<and>\<^sub>p u \<cdot> v"};
+        on the other hand, maximal r-prefix of @{term "u \<cdot> w \<cdot> bin_code_lcp"} is at least @{term "u \<cdot> bin_code_lcp"}, 
+        since this is, in particular, a prefix of @{term "u \<cdot> v \<cdot> u \<cdot> v \<in> r*"}\<close> 
+      assume "u \<cdot> v \<noteq> v \<cdot> u"                                    
+      then interpret binary_code u v
+        by (unfold_locales)
+      term "p \<cdot> v \<cdot> s = u  \<cdot> q"
+      have "p \<cdot> bin_code_lcp \<cdot> [bin_code_mismatch_snd] \<le>p u \<cdot> w \<cdot> bin_code_lcp"
+      proof-
+        have "p \<cdot> bin_code_lcp \<cdot> [bin_code_mismatch_snd] \<le>p p \<cdot> v \<cdot> w' \<cdot> bin_code_lcp"
+          unfolding pref_cancel_conv
+          using pref_prolong[OF  bin_snd_mismatch bin_lcp_pref_all_hull, OF \<open>w' \<in> \<langle>{u,v}\<rangle>\<close>].
+        note local_rule = ruler_le[OF this] 
+        have "p \<cdot> bin_code_lcp \<cdot> [bin_code_mismatch_snd] \<le>p p \<cdot> v \<cdot> s"
+        proof (rule local_rule)
+          show "p \<cdot> v \<cdot> s \<le>p p \<cdot> v \<cdot> w' \<cdot> bin_code_lcp"
+            using \<open>s \<le>p w'\<close> by fastforce 
+          show "\<^bold>|p \<cdot> bin_code_lcp \<cdot> [bin_code_mismatch_snd]\<^bold>| \<le> \<^bold>|p \<cdot> v \<cdot> s\<^bold>|"
+            using bin_lcp_short \<open>\<^bold>|u\<^bold>| \<le> \<^bold>|s\<^bold>|\<close>  by force
+        qed
+        from pref_ext[OF pref_trans[OF this \<open>p \<cdot> v \<cdot> s \<le>p u \<cdot> w\<close>]]
+        show "p \<cdot> bin_code_lcp \<cdot> [bin_code_mismatch_snd] \<le>p u \<cdot> w \<cdot> bin_code_lcp"
+          by force
+      qed
+      moreover 
+      have "p \<cdot> bin_code_lcp \<cdot> [bin_code_mismatch_fst] \<le>p u \<cdot> w \<cdot> bin_code_lcp" 
+      proof (rule pref_trans[of _ "u \<cdot> bin_code_lcp"])
+        show "u \<cdot> bin_code_lcp \<le>p u \<cdot> w \<cdot> bin_code_lcp"
+          using  bin_lcp_pref_all_hull[OF \<open>w \<in> \<langle>{u,v}\<rangle>\<close>]  by auto
+        show "p \<cdot> bin_code_lcp \<cdot> [bin_code_mismatch_fst] \<le>p u \<cdot> bin_code_lcp"  
+        proof (rule ruler_le)
+          show "\<^bold>|p \<cdot> bin_code_lcp \<cdot> [bin_code_mismatch_fst]\<^bold>| \<le> \<^bold>|u \<cdot> bin_code_lcp\<^bold>|"
+            unfolding lenmorph using prefix_length_less[OF \<open>p <p u\<close>] by simp
+          show "u \<cdot> bin_code_lcp \<le>p r \<^sup>@ (m + m)"
+            unfolding add_exps \<open>r\<^sup>@m = u \<cdot> v\<close> rassoc pref_cancel_conv
+            using bin_lcp_pref_snd_fst pref_prolong prefix_def by metis
+          show "p \<cdot> bin_code_lcp \<cdot> [bin_code_mismatch_fst] \<le>p r \<^sup>@ (m + m)"
+          proof (rule pref_trans)
+            show "p \<cdot> bin_code_lcp \<cdot> [bin_code_mismatch_fst] \<le>p r\<^sup>@(k+m)"
+              unfolding  power_add  \<open>r \<^sup>@ k = p\<close> \<open>r \<^sup>@ m = u \<cdot> v\<close> pref_cancel_conv 
+              using bin_fst_mismatch'.
+            show "r \<^sup>@ (k + m) \<le>p r \<^sup>@ (m + m)"
+              unfolding  power_add  \<open>r \<^sup>@ k = p\<close> \<open>r \<^sup>@ m = u \<cdot> v\<close> \<open>p \<cdot> u \<cdot> v = (u \<cdot> v) \<cdot> p\<close> 
+              using \<open>p <p u\<close> by force  
+          qed
+        qed
+      qed
+      ultimately show False
+        using  bin_mismatch_neq by (force simp add: prefix_def)
+    qed
+  qed
+qed
+
+lemma uvu_pref_uvvu: assumes "p \<cdot> u \<cdot> v \<cdot> v \<cdot> u = u \<cdot> v \<cdot> u \<cdot> q" and
+  "p <p u" and "q \<le>p w" and  " w \<in> \<langle>{u,v}\<rangle>"
+shows "u \<cdot> v = v \<cdot> u"
+  using uvu_pref_uvv[OF \<open>p \<cdot> u \<cdot> v \<cdot> v \<cdot> u = u \<cdot> v \<cdot> u \<cdot> q\<close> \<open>p <p u\<close> \<open>q \<le>p w\<close> _ \<open>w \<in> \<langle>{u,v}\<rangle>\<close>, of u]
+  by blast
+
+
+lemma uvu_pref_uvvu_interpret: assumes interp: "p u \<cdot> v \<cdot> v \<cdot> u s \<sim>\<^sub>\<I> ws" and
+  "[u, v, u] \<le>p  ws" and "ws \<in> lists {u,v}"
+shows "u \<cdot> v = v \<cdot> u"
+proof-
+  note fac_interpretE[OF interp]
+  obtain ws' where "[u,v,u] \<cdot> ws' = ws" and "ws' \<in> lists {u,v}"
+    using \<open>[u, v, u] \<le>p  ws\<close> \<open>ws \<in> lists {u,v}\<close> by (force simp add: prefix_def)
+  have "p \<cdot> u \<cdot> v \<cdot> v \<cdot> u \<cdot> s = u \<cdot> v \<cdot> u \<cdot> concat ws'"
+    using \<open>p \<cdot> (u \<cdot> v \<cdot> v \<cdot> u) \<cdot> s = concat ws\<close>[folded \<open>[u,v,u] \<cdot> ws' = ws\<close>, unfolded concat_morph rassoc]
+    by simp
+  from lenarg[OF this, unfolded lenmorph]
+  have "\<^bold>|s\<^bold>| \<le> \<^bold>|concat ws'\<^bold>|"
+    by auto
+  hence "s \<le>s concat ws'" 
+    using eqd[reversed, OF \<open>p \<cdot> u \<cdot> v \<cdot> v \<cdot> u \<cdot> s = u \<cdot> v \<cdot> u \<cdot> concat ws'\<close>[unfolded lassoc]]
+    by blast
+  note local_rule = uvu_pref_uvv[of p u v u "concat ws'\<^sup><\<inverse>s" "concat ws'" u]
+  show "u \<cdot> v = v \<cdot> u"
+  proof (rule local_rule)
+    show "p <p u"
+      using \<open>p <p hd ws\<close> pref_hd_eq[OF \<open>[u, v, u] \<le>p  ws\<close> list.distinct(1)[of u "[v,u]", symmetric]]
+      by force
+    have "p \<cdot> u \<cdot> v \<cdot> v \<cdot> u \<cdot> s = u \<cdot> v \<cdot> u \<cdot> (concat ws'\<^sup><\<inverse>s) \<cdot> s"
+      using \<open>p \<cdot> u \<cdot> v \<cdot> v \<cdot> u \<cdot> s = u \<cdot> v \<cdot> u \<cdot> concat ws'\<close> unfolding rq_suf[OF \<open>s \<le>s concat ws'\<close>]. 
+    thus "p \<cdot> u \<cdot> v \<cdot> v \<cdot> u = u \<cdot> v \<cdot> u \<cdot> concat ws'\<^sup><\<inverse>s" 
+      by simp
+    show "concat ws' \<in> \<langle>{u,v}\<rangle>"
+      using \<open>ws' \<in> lists {u,v}\<close> by blast
+    show "concat ws'\<^sup><\<inverse>s  \<le>p concat ws'"
+      using rq_suf[OF \<open>s \<le>s concat ws'\<close>] by fast
+  qed auto  
+qed
+
+lemmas uvu_suf_uvvu = uvu_pref_uvvu[reversed, unfolded rassoc] and
+  uvu_suf_uvv = uvu_pref_uvv[reversed, unfolded rassoc]
+
+lemma uvu_suf_uvvu_interp: "p u \<cdot> v \<cdot> v \<cdot> u s \<sim>\<^sub>\<I> ws \<Longrightarrow> [u, v, u] \<le>s  ws
+  \<Longrightarrow> ws \<in> lists {u,v} \<Longrightarrow> u \<cdot> v = v \<cdot> u"
+  by (rule uvu_pref_uvvu_interpret[reversed, unfolded rassoc clean_emp, symmetric, of p u v s ws], 
+      simp, force, simp add: image_iff rev_in_lists rev_map)
+
+subsection \<open>Conjugate words\<close>
+
+lemma conjug_pref_suf_mismatch: assumes "w1 \<in> \<langle>{r\<cdot>s,s\<cdot>r}\<rangle>" and "w2 \<in> \<langle>{r\<cdot>s,s\<cdot>r}\<rangle>" and "r \<cdot> w1 = w2 \<cdot> s"
+  shows "r = s \<or> r = \<epsilon> \<or> s = \<epsilon>"
+proof (rule ccontr)
+  assume "\<not> (r = s \<or> r = \<epsilon> \<or> s = \<epsilon>)"
+  hence "r \<noteq> s" and "r \<noteq> \<epsilon>" and "s \<noteq> \<epsilon>" by simp_all
+  from assms
+  show False 
+  proof (induct "\<^bold>|w1\<^bold>|" arbitrary: w1 w2 rule: less_induct)
+    case less
+    have "w1 \<in> \<langle>{r,s}\<rangle>"
+      using \<open>w1 \<in> \<langle>{r\<cdot>s,s\<cdot>r}\<rangle>\<close> by force
+    obtain w1' where "(w1 = \<epsilon> \<or> w1 = r \<cdot> s \<cdot> w1' \<or> w1 = s \<cdot> r \<cdot> w1') \<and> w1' \<in> \<langle>{r\<cdot>s,s\<cdot>r}\<rangle>"
+      using hull.cases[OF \<open>w1 \<in> \<langle>{r\<cdot>s,s\<cdot>r}\<rangle>\<close>]  empty_iff insert_iff mult_assoc \<open>w1 \<in> \<langle>{r \<cdot> s, s \<cdot> r}\<rangle>\<close> by metis  
+    hence "w1' \<in> \<langle>{r\<cdot>s,s\<cdot>r}\<rangle>" and cases1: "(w1 = \<epsilon> \<or> w1 = r \<cdot> s \<cdot> w1' \<or> w1 = s \<cdot> r \<cdot> w1')" by blast+
+    hence "w1' \<in> \<langle>{r,s}\<rangle>" by force
+    obtain w2' where "(w2 = \<epsilon> \<or> w2 = r \<cdot> s \<cdot> w2' \<or> w2 = s \<cdot> r \<cdot> w2') \<and> w2' \<in> \<langle>{r\<cdot>s,s\<cdot>r}\<rangle>"
+      using hull.cases[OF \<open>w2 \<in> \<langle>{r\<cdot>s,s\<cdot>r}\<rangle>\<close>]  empty_iff insert_iff mult_assoc \<open>w1 \<in> \<langle>{r \<cdot> s, s \<cdot> r}\<rangle>\<close> by metis  
+    hence "w2' \<in> \<langle>{r\<cdot>s,s\<cdot>r}\<rangle>" and cases2: "(w2 = \<epsilon> \<or> w2 = r \<cdot> s \<cdot> w2' \<or> w2 = s \<cdot> r \<cdot> w2')" by blast+
+    hence "w2' \<in> \<langle>{r,s}\<rangle>" by force
+    consider (empty2) "w2 = \<epsilon>" | (sr2) "w2 = s \<cdot> r \<cdot> w2'" | (rs2) "w2 = r \<cdot> s \<cdot> w2'"using cases2 by blast 
+    thus False
+    proof (cases)
+      case empty2
+      consider (empty1) "w1 = \<epsilon>" | (sr1) "w1 = s \<cdot> r \<cdot> w1'" | (rs1) "w1 = r \<cdot> s \<cdot> w1'"
+        using cases1 by blast 
+      thus False
+      proof (cases)
+        case empty1
+        show False 
+          using \<open>r \<cdot> w1 = w2 \<cdot> s\<close>[unfolded empty1 empty2 rassoc] \<open>r \<noteq> s\<close> by simp
+      next
+        case sr1
+        show False
+          using \<open>r \<cdot> w1 = w2 \<cdot> s\<close>[unfolded sr1 empty2 rassoc] \<open>r \<noteq> \<epsilon>\<close> fac_triv by auto
+      next
+        case rs1
+        show False
+          using \<open>r \<cdot> w1 = w2 \<cdot> s\<close>[unfolded rs1 empty2 rassoc clean_emp] \<open>r \<noteq> \<epsilon>\<close>
+            fac_triv[of "r \<cdot> r" s w1', unfolded rassoc] by force  
+      qed
+    next
+      case sr2
+      have "r \<cdot> s = s \<cdot> r"
+        using \<open>w2' \<in> \<langle>{r,s}\<rangle>\<close> \<open>w1 \<in> \<langle>{r,s}\<rangle>\<close> \<open>r \<cdot> w1 = w2 \<cdot> s\<close>[unfolded sr2 rassoc] 
+        by (mismatch)
+      consider (empty1) "w1 = \<epsilon>" | (sr1) "w1 = s \<cdot> r \<cdot> w1'" | (rs1) "w1 = r \<cdot> s \<cdot> w1'" using cases1 by blast 
+      thus False
+      proof (cases)
+        case empty1
+        then show False 
+          using \<open>r \<cdot> w1 = w2 \<cdot> s\<close>[unfolded sr2 empty1 rassoc cancel clean_emp, symmetric] \<open>s \<noteq> \<epsilon>\<close> fac_triv by blast 
+      next
+        case rs1
+        then have "r \<cdot> s = s \<cdot> r" 
+          using \<open>w2' \<in> \<langle>{r,s}\<rangle>\<close> \<open>w1' \<in> \<langle>{r,s}\<rangle>\<close> \<open>r \<cdot> w1 = w2 \<cdot> s\<close>[unfolded rs1 sr2 rassoc cancel] 
+          by mismatch
+        hence "r \<cdot> w1' = w2' \<cdot> s" 
+          using \<open>r \<cdot> w1 = w2 \<cdot> s\<close>[unfolded rs1 sr2] rassoc cancel by metis
+        from less.hyps[OF _ \<open>w1' \<in> \<langle>{r \<cdot> s, s \<cdot> r}\<rangle>\<close> \<open>w2' \<in> \<langle>{r \<cdot> s, s \<cdot> r}\<rangle>\<close> this] 
+        show False 
+          using lenarg[OF \<open>w1 = r \<cdot> s \<cdot> w1'\<close>, unfolded lenmorph] nemp_len[OF \<open>s \<noteq> \<epsilon>\<close>] by linarith
+      next
+        case sr1
+        then have "r \<cdot> s = s \<cdot> r" 
+          using \<open>w2' \<in> \<langle>{r,s}\<rangle>\<close> \<open>w1' \<in> \<langle>{r,s}\<rangle>\<close> \<open>r \<cdot> w1 = w2 \<cdot> s\<close>[unfolded sr1 sr2 rassoc cancel] 
+          by mismatch
+        hence "r \<cdot> w1' = w2' \<cdot> s" 
+          using \<open>r \<cdot> w1 = w2 \<cdot> s\<close>[unfolded sr1 sr2] rassoc cancel by metis
+        from less.hyps[OF _ \<open>w1' \<in> \<langle>{r \<cdot> s, s \<cdot> r}\<rangle>\<close> \<open>w2' \<in> \<langle>{r \<cdot> s, s \<cdot> r}\<rangle>\<close> this] 
+        show False 
+          using less.hyps[OF _ \<open>w1' \<in> \<langle>{r \<cdot> s, s \<cdot> r}\<rangle>\<close> \<open>w2' \<in> \<langle>{r \<cdot> s, s \<cdot> r}\<rangle>\<close> \<open>r \<cdot> w1' = w2' \<cdot> s\<close>] 
+            lenarg[OF \<open>w1 = s \<cdot> r \<cdot> w1'\<close>, unfolded lenmorph] nemp_len[OF \<open>s \<noteq> \<epsilon>\<close>] by linarith
+      qed
+    next
+      case rs2
+      consider (empty1) "w1 = \<epsilon>" | (sr1) "w1 = s \<cdot> r \<cdot> w1'" | (rs1) "w1 = r \<cdot> s \<cdot> w1'" using cases1 by blast 
+      thus False
+      proof (cases)
+        case empty1
+        then show False 
+          using \<open>r \<cdot> w1 = w2 \<cdot> s\<close>[unfolded rs2 empty1 rassoc cancel] \<open>s \<noteq> \<epsilon>\<close> by blast
+      next
+        case rs1
+        then have "r \<cdot> s = s \<cdot> r" 
+          using \<open>w2' \<in> \<langle>{r,s}\<rangle>\<close> \<open>w1' \<in> \<langle>{r,s}\<rangle>\<close> \<open>r \<cdot> w1 = w2 \<cdot> s\<close>[unfolded rs2 rs1 rassoc cancel] 
+          by mismatch
+        hence "r \<cdot> w1' = w2' \<cdot> s"           
+          using \<open>r \<cdot> w1 = w2 \<cdot> s\<close>[unfolded rs1 rs2] rassoc cancel by metis
+        from less.hyps[OF _ \<open>w1' \<in> \<langle>{r \<cdot> s, s \<cdot> r}\<rangle>\<close> \<open>w2' \<in> \<langle>{r \<cdot> s, s \<cdot> r}\<rangle>\<close> this] 
+        show False 
+          using less.hyps[OF _ \<open>w1' \<in> \<langle>{r \<cdot> s, s \<cdot> r}\<rangle>\<close> \<open>w2' \<in> \<langle>{r \<cdot> s, s \<cdot> r}\<rangle>\<close> \<open>r \<cdot> w1' = w2' \<cdot> s\<close>] 
+            lenarg[OF \<open>w1 = r \<cdot> s \<cdot> w1'\<close>, unfolded lenmorph] nemp_len[OF \<open>s \<noteq> \<epsilon>\<close>] by linarith
+      next
+        case sr1
+        then show False 
+          using less.hyps[OF _ \<open>w1' \<in> \<langle>{r \<cdot> s, s \<cdot> r}\<rangle>\<close> \<open>w2' \<in> \<langle>{r \<cdot> s, s \<cdot> r}\<rangle>\<close> \<open>r \<cdot> w1 = w2 \<cdot> s\<close>[unfolded rs2 sr1 rassoc cancel]] 
+            lenarg[OF \<open>w1 = s \<cdot> r \<cdot> w1'\<close>, unfolded lenmorph] nemp_len[OF \<open>s \<noteq> \<epsilon>\<close>] by linarith
+      qed
+    qed
+  qed
+qed
+
+lemma conjug_conjug_primroots: assumes "u \<noteq> \<epsilon>" and "r \<noteq> \<epsilon>" and "\<rho> (u \<cdot> v) = r \<cdot> s" and "\<rho> (v \<cdot> u) = s \<cdot> r"
+  obtains k m where "(r \<cdot> s)\<^sup>@k \<cdot> r = u" and "(s \<cdot> r)\<^sup>@m \<cdot> s = v"
+proof-
+  have "v \<cdot> u \<noteq> \<epsilon>" and "u \<cdot> v \<noteq> \<epsilon>"
+    using \<open>u \<noteq> \<epsilon>\<close> by blast+
+  have "\<rho> (s \<cdot> r) = s \<cdot> r"
+    using primroot_idemp[OF \<open>v \<cdot> u \<noteq> \<epsilon>\<close>, unfolded \<open>\<rho> (v \<cdot> u) = s \<cdot> r\<close>].
+  obtain n where "(r \<cdot> s)\<^sup>@Suc n = u \<cdot> v"
+    using  primroot_expE[OF \<open>u \<cdot> v \<noteq> \<epsilon>\<close>, unfolded \<open>\<rho> (u \<cdot> v) = r \<cdot> s\<close>].
+  obtain n' where "(s \<cdot> r)\<^sup>@Suc n' = v \<cdot> u"
+    using  primroot_expE[OF \<open>v \<cdot> u \<noteq> \<epsilon>\<close>, unfolded \<open>\<rho> (v \<cdot> u) = s \<cdot> r\<close>].
+  have "(s \<cdot> u) \<cdot> (s \<cdot> r) = (s \<cdot> r) \<cdot> (s \<cdot> u)"
+  proof (rule pref_marker)
+    show "(s \<cdot> u) \<cdot> s \<cdot> r \<le>p s \<cdot> (r \<cdot> s)\<^sup>@(Suc n+ Suc n)"
+      unfolding rassoc add_exps \<open>(r \<cdot> s)\<^sup>@Suc n = u \<cdot> v\<close> 
+      unfolding lassoc \<open>(s \<cdot> r)\<^sup>@Suc n' = v \<cdot> u\<close>[symmetric] pow_Suc by force
+    have aux: "(s \<cdot> r) \<cdot> s \<cdot> (r \<cdot> s) \<^sup>@ (Suc n + Suc n) = s \<cdot> (r \<cdot> s)\<^sup>@(Suc  n + Suc n) \<cdot> (r \<cdot> s)"
+      by (simp add: pow_comm)
+    show "s \<cdot> (r \<cdot> s) \<^sup>@ (Suc n + Suc n) \<le>p (s \<cdot> r) \<cdot> s \<cdot> (r \<cdot> s) \<^sup>@ (Suc n + Suc n)"
+      unfolding aux pref_cancel_conv by blast
+  qed
+  from comm_primroot_exp[OF primroot_nemp[OF \<open>v \<cdot> u \<noteq> \<epsilon>\<close>, unfolded \<open>\<rho> (v \<cdot> u) = s \<cdot> r\<close>] this]
+  obtain k where "(s \<cdot> r)\<^sup>@Suc k = s \<cdot> u"
+    using  nemp_pow_SucE[OF suf_nemp[OF \<open>u \<noteq> \<epsilon>\<close>, of s]] \<open>\<rho> (s \<cdot> r) =  s \<cdot> r\<close> by metis
+  hence u: "(r \<cdot> s)\<^sup>@k \<cdot> r = u"
+    unfolding pow_Suc rassoc cancel shift_pow by fast
+  from exp_pref_cancel[OF \<open>(r \<cdot> s)\<^sup>@Suc n = u \<cdot> v\<close>[folded this, unfolded rassoc, symmetric]]
+  have "r \<cdot> v = (r \<cdot> s) \<^sup>@ (Suc n - k)".   
+  from nemp_pow_SucE[OF _ this]
+  obtain m where "r \<cdot> v = (r \<cdot> s)\<^sup>@Suc m"
+    using \<open>r \<noteq> \<epsilon>\<close> by blast 
+  from this[unfolded pow_Suc rassoc cancel shift_pow[symmetric], symmetric]
+  have v: "(s \<cdot> r)\<^sup>@m \<cdot> s = v".
+  show thesis
+    using that[OF u v].
+qed      
+
+subsection \<open>Predicate ``commutes''\<close>
+
+definition commutes :: "'a list set \<Rightarrow> bool"
+  where "commutes A = (\<forall>x y. x \<in> A \<longrightarrow> y \<in> A \<longrightarrow> x\<cdot>y = y\<cdot>x)"
+
+lemma commutesE: "commutes A \<Longrightarrow> x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x\<cdot>y = y\<cdot>x"
+  using commutes_def by blast
+
+lemma commutes_root: assumes "commutes A"
+  obtains r where "\<And>x. x \<in> A \<Longrightarrow> x \<in> r*"
+  using assms comm_primroots emp_all_roots primroot_is_root
+  unfolding commutes_def
+  by metis
+
+lemma commutes_primroot: assumes "commutes A"
+  obtains r where "\<And>x. x \<in> A \<Longrightarrow> x \<in> r*" and "primitive r"
+  using commutes_root[OF assms] emp_all_roots prim_sing 
+    primroot_is_root primroot_prim root_trans
+  by metis
+
+lemma commutesI [intro]: "(\<And>x y. x \<in> A \<Longrightarrow> y \<in> A \<Longrightarrow> x\<cdot>y = y\<cdot>x) \<Longrightarrow> commutes A"
+  unfolding commutes_def
+  by blast
+
+lemma commutesI': assumes "x \<noteq> \<epsilon>" and "\<And>y. y \<in> A \<Longrightarrow> x\<cdot>y = y\<cdot>x"
+  shows "commutes A"
+proof-
+  have "\<And>x' y'. x' \<in> A \<Longrightarrow> y' \<in> A \<Longrightarrow> x'\<cdot>y' = y'\<cdot>x'"
+  proof-
+    fix x' y'
+    assume "x' \<in> A" "y' \<in> A"
+    hence "x'\<cdot>x = x\<cdot>x'" and "y'\<cdot>x = x\<cdot>y'"
+      using assms(2) by auto+
+    from comm_trans[OF this assms(1)]
+    show "x'\<cdot>y' = y'\<cdot>x'".
+  qed
+  thus ?thesis
+    by (simp add: commutesI)
+qed
+
+lemma commutesI_root: "\<forall>x \<in> A. x \<in> t* \<Longrightarrow> commutes A"
+  by (meson comm_root commutesI)
+
+lemma commutes_sub: "commutes A \<Longrightarrow> B \<subseteq> A \<Longrightarrow> commutes B"
+  by (simp add: commutes_def subsetD)
+
+lemma commutes_insert: "commutes A \<Longrightarrow> x \<in> A \<Longrightarrow> x \<noteq> \<epsilon> \<Longrightarrow>  x\<cdot>y = y\<cdot>x \<Longrightarrow> commutes (insert y A)"
+  using commutesE[of A x] commutesI'[of x "insert y A"] insertE
+  by blast
+
+lemma commutes_emp [simp]: "commutes {\<epsilon>, w}"
+  by (simp add: commutes_def)
+
+lemma commutes_emp'[simp]: "commutes {w, \<epsilon>}" 
+  by (simp add: commutes_def)
+
+lemma commutes_cancel: "commutes (insert y (insert (x \<cdot> y) A)) \<Longrightarrow> commutes (insert y (insert x A))"
+proof
+  fix u v 
+  assume com: "commutes (insert y (insert (x \<cdot> y) A))" and
+         "u \<in> insert y (insert x A)" "v \<in> insert y (insert x A)"
+  then consider "u = y" | "u = x" | "u \<in> A"
+    by blast
+  note u_cases = this
+  consider "v = y" | "v = x" | "v \<in> A"
+    using \<open>v \<in> insert y (insert x A)\<close> by blast
+  note v_cases = this
+  have "y \<cdot> (x \<cdot> y) = (x \<cdot> y) \<cdot> y" 
+    using \<open>commutes (insert y (insert (x \<cdot> y) A))\<close> commutesE by blast 
+  hence "x \<cdot> y = y \<cdot> x" 
+    by simp
+  have[simp]: "w \<in> A \<Longrightarrow> y \<cdot> w = w \<cdot> y" for w
+    using com by (simp add: commutesE) 
+  hence[simp]: "w \<in> A \<Longrightarrow> x \<cdot> w = w \<cdot> x" for w
+    using \<open>x \<cdot> y = y \<cdot> x\<close>  com commutesE
+    comm_trans insertCI shifts_rev(37) by metis 
+  have[simp]: "u \<in> A \<Longrightarrow> v \<in> A \<Longrightarrow> u \<cdot> v = v \<cdot> u"
+     using com commutesE by blast
+  show "u \<cdot> v = v \<cdot> u"
+    by (rule u_cases, (rule v_cases, simp_all add: \<open>x \<cdot> y = y \<cdot> x\<close> com)+)
+qed
+
+
+subsection \<open>Strong elementary lemmas\<close>
+
+text\<open>Discovered by smt\<close>
+
+lemma xyx_per_comm: assumes "x\<cdot>y\<cdot>x \<le>p q\<cdot>x\<cdot>y\<cdot>x"
+  and "q \<noteq> \<epsilon>" and "q \<le>p y \<cdot> q"
+shows "x\<cdot>y = y\<cdot>x"
+  (* by (smt (verit, best) assms(1) assms(2) assms(3) pref_cancel pref_cancel' pref_marker pref_prolong prefix_same_cases root_comm_root triv_pref) *) 
+proof(cases)
+  assume "x \<cdot> y \<le>p q"
+  from pref_marker[OF \<open>q \<le>p y \<cdot> q\<close> this]
+  show "x \<cdot> y = y \<cdot> x".
+next  
+  have "(x \<cdot> y) \<cdot> x \<le>p q \<cdot> x \<cdot> y \<cdot> x" unfolding rassoc by fact
+  assume "\<not> x \<cdot> y \<le>p q"
+  hence "q \<le>p  x \<cdot> y"  
+    using ruler_prefE[OF \<open>(x \<cdot> y) \<cdot> x \<le>p q \<cdot> x \<cdot> y \<cdot> x\<close>] by argo
+  from pref_prolong[OF \<open>q \<le>p y \<cdot> q\<close> this, unfolded lassoc]
+  have"q \<le>p (y \<cdot> x) \<cdot> y".
+  from ruler_pref'[OF this, THEN disjE] \<open>q \<le>p x \<cdot> y\<close>
+  have "q \<le>p y \<cdot> x" 
+    using pref_trans[OF _ \<open>q \<le>p x \<cdot> y\<close>, of "y \<cdot> x", THEN pref_comm_eq] by metis   
+  from pref_cancel'[OF this, of x]
+  have "x \<cdot> q = q \<cdot> x"
+    using  pref_marker[OF \<open>x \<cdot> y \<cdot> x \<le>p q \<cdot> x \<cdot> y \<cdot> x\<close>, of x] by blast 
+  hence "x \<cdot> y \<cdot> x \<le>p x \<cdot> x \<cdot> y \<cdot> x"
+    using root_comm_root[OF _ _ \<open>q \<noteq> \<epsilon>\<close>, of "x \<cdot> y \<cdot> x" x] \<open>x \<cdot> y \<cdot> x \<le>p q \<cdot> x \<cdot> y \<cdot> x\<close> by fast
+  thus "x\<cdot>y = y\<cdot>x"
+    by mismatch
+qed
+
+lemma two_elem_root_suf_comm: assumes "u \<le>p v \<cdot> u" and "v \<le>s p \<cdot> u" and "p \<in> \<langle>{u,v}\<rangle>"
+  shows "u \<cdot> v = v \<cdot> u"
+  using root_suf_comm[OF \<open>u \<le>p v \<cdot> u\<close> two_elem_suf[OF \<open>v \<le>s p \<cdot> u\<close> \<open>p \<in> \<langle>{u,v}\<rangle>\<close>], symmetric].
+
+lemma two_elem_root_suf_comm': assumes "u \<le>p v \<cdot> u" and "q \<le>s p" and "q \<cdot> u \<cdot> v = v \<cdot> q \<cdot> u" and "p \<in> \<langle>{u,v}\<rangle>"
+  shows "u \<cdot> v = v \<cdot> u"
+proof (rule nemp_comm)
+  assume "u \<noteq> \<epsilon>" and "v \<noteq> \<epsilon>" 
+  have "p \<in> \<langle>{u, \<rho> v}\<rangle>"
+    using gen_prim[OF \<open>v \<noteq> \<epsilon>\<close> \<open>p \<in> \<langle>{u,v}\<rangle>\<close>].
+
+  have "(q \<cdot> u) \<cdot> v = v \<cdot> (q \<cdot> u)"
+    using \<open>q \<cdot> u \<cdot> v = v \<cdot> q \<cdot> u\<close> by fastforce
+  hence "(q \<cdot> u) \<cdot> \<rho> v = \<rho> v \<cdot> (q \<cdot> u)"
+    unfolding comm_primroot_conv[OF \<open>v \<noteq> \<epsilon>\<close>].
+
+  have "u \<le>p \<rho> v \<cdot> u"
+    using \<open>u \<le>p v \<cdot> u\<close> \<open>v \<noteq> \<epsilon>\<close> comm_primroot_conv root_comm_root by metis 
+
+  have "\<rho> v \<le>s q \<cdot> u"
+    using suf_nemp[OF \<open>u \<noteq> \<epsilon>\<close>] primroot_suf \<open>(q \<cdot> u) \<cdot> v = v \<cdot> q \<cdot> u\<close> \<open>v \<noteq> \<epsilon>\<close> comm_primroots by metis
+  hence "\<rho> v \<le>s p \<cdot> u"
+    using suf_trans \<open>q \<le>s p\<close> by (auto simp add: suf_def)
+
+  from two_elem_root_suf_comm[OF \<open>u \<le>p \<rho> v \<cdot> u\<close> this \<open>p \<in> \<langle>{u,\<rho> v}\<rangle>\<close>]
+  have "u \<cdot> \<rho> v = \<rho> v \<cdot> u".
+  thus "u \<cdot> v = v \<cdot> u"
+    using \<open>v \<noteq> \<epsilon>\<close> comm_primroot_conv by metis
+qed
+
+
+subsection \<open>Binary words without a letter square\<close>
+
+lemma no_repetition_list:  
+  assumes "set ws \<subseteq> {a,b}"
+    and not_per:  "\<not> ws \<le>p [a,b] \<cdot> ws" "\<not> ws \<le>p [b,a] \<cdot> ws"
+    and not_square:  "\<not> [a,a] \<le>f ws" and "\<not> [b,b] \<le>f ws" 
+  shows False
+  using assms
+proof (induction ws, simp)
+  case (Cons d ws)
+  show ?case 
+  proof (rule "Cons.IH")
+    show "set ws \<subseteq> {a,b}" 
+      using \<open>set (d # ws) \<subseteq> {a, b}\<close> by auto
+    have "ws \<noteq> \<epsilon>"
+      using "Cons.IH" Cons.prems by force
+    from hd_tl[OF this]
+    have "hd ws \<noteq> d" 
+      using Cons.prems(1,4-5) hd_pref[OF \<open>ws \<noteq> \<epsilon>\<close>] by force  
+    thus "\<not> [a, a] \<le>f ws" and "\<not> [b, b] \<le>f ws" 
+      using Cons.prems(4-5) unfolding sublist_code(3) by blast+
+    show "\<not> ws \<le>p [a, b] \<cdot> ws"
+    proof (rule notI)
+      assume "ws \<le>p [a, b] \<cdot> ws"
+      from pref_hd_eq[OF this \<open>ws \<noteq> \<epsilon>\<close>]
+      have "hd ws = a" by simp
+      hence  "d = b"
+        using \<open>set (d # ws) \<subseteq> {a, b}\<close> \<open>hd ws \<noteq> d\<close> by auto
+      show False
+        using \<open>ws \<le>p [a, b] \<cdot> ws\<close>  \<open>\<not> d # ws \<le>p [b, a] \<cdot> d # ws\<close>[unfolded \<open>d = b\<close>] by force
+    qed
+    show "\<not> ws \<le>p [b, a] \<cdot> ws"
+    proof (rule notI)
+      assume "ws \<le>p [b, a] \<cdot> ws"
+      from pref_hd_eq[OF this \<open>ws \<noteq> \<epsilon>\<close>]
+      have "hd ws = b" by simp
+      hence  "d = a"
+        using \<open>set (d # ws) \<subseteq> {a, b}\<close> \<open>hd ws \<noteq> d\<close> by auto
+      show False
+        using \<open>ws \<le>p [b, a] \<cdot> ws\<close>  \<open>\<not> d # ws \<le>p [a, b] \<cdot> d # ws\<close>[unfolded \<open>d = a\<close>] by force
+    qed
+  qed
+qed
+
+lemma hd_Cons_append[intro,simp]: "hd ((a#v) \<cdot> u) = a" 
+  by simp
+
+lemma no_repetition_list_bin:  
+  fixes ws :: "binA list"
+  assumes not_square:  "\<And> c. \<not> [c,c] \<le>f ws" 
+  shows "ws \<le>p [hd ws, 1-(hd ws)] \<cdot> ws"
+proof (cases "ws = \<epsilon>", simp)
+  assume "ws \<noteq> \<epsilon>"
+  have set: "set ws \<subseteq> {hd ws, 1-hd ws}"
+    using swap_UNIV by auto 
+  have "\<not> ws \<le>p [1 - hd ws, hd ws] \<cdot> ws"
+    using pref_hd_eq[OF _ \<open>ws \<noteq> \<epsilon>\<close>, of "[1 - hd ws, hd ws] \<cdot> ws"] bin_swap_neq'
+    unfolding hd_Cons_append by blast 
+  from no_repetition_list[OF set _ this not_square not_square] 
+  show "ws \<le>p [hd ws, 1-(hd ws)] \<cdot> ws" by blast  
+qed
+
+lemma per_root_hd_last_root: assumes "ws \<le>p [a,b] \<cdot> ws" and "hd ws \<noteq> last ws" 
+  shows "ws \<in> [a,b]*"
+  using assms
+proof (induction "\<^bold>|ws\<^bold>|" arbitrary: ws rule: less_induct)
+  case less
+  then show ?case
+  proof (cases "ws = \<epsilon>", simp)
+    assume "ws \<noteq> \<epsilon>"
+    with \<open>hd ws \<noteq> last ws\<close>
+    have *: "[hd ws, hd (tl ws)] \<cdot> tl (tl ws) = ws"
+      using append_Cons last_ConsL[of "tl ws" "hd ws"] list.exhaust_sel[of ws] hd_tl by metis 
+    have ind: "\<^bold>|tl (tl ws)\<^bold>| < \<^bold>|ws\<^bold>|" using \<open>ws \<noteq> \<epsilon>\<close> by auto
+    have "[hd ws, hd (tl ws)] \<cdot> tl (tl ws) \<le>p [a,b] \<cdot> ws "
+      unfolding * using  \<open>ws \<le>p [a, b] \<cdot> ws\<close>.
+    hence "[a,b] = [hd ws, hd (tl ws)]" by simp
+    hence "hd ws = a" by simp
+    have "tl (tl ws) \<le>p [a,b] \<cdot> tl (tl ws)" 
+      unfolding pref_cancel_conv[of "[a,b]" "tl (tl ws)", symmetric] \<open>[a,b] = [hd ws, hd (tl ws)]\<close> *
+      using \<open>ws \<le>p [a, b] \<cdot> ws\<close>[unfolded \<open>[a,b] = [hd ws, hd (tl ws)]\<close>].  
+    have "tl (tl ws) \<in> [a, b]*"
+    proof (cases "tl (tl ws) = \<epsilon>", simp)
+      assume "tl (tl ws) \<noteq> \<epsilon>"
+      from pref_hd_eq[OF \<open>tl (tl ws) \<le>p [a, b] \<cdot> tl (tl ws)\<close> this]
+      have "hd (tl (tl ws)) = a" by simp
+      have "last (tl (tl ws)) = last ws"
+        using \<open>tl (tl ws) \<noteq> \<epsilon>\<close> last_tl tl_Nil by metis 
+      from \<open>hd ws \<noteq> last ws\<close>[unfolded \<open>hd ws =a\<close>, folded this \<open>hd (tl (tl ws)) = a\<close>]
+      have "hd (tl (tl ws)) \<noteq> last (tl (tl ws))".
+      from less.hyps[OF ind \<open>tl (tl ws) \<le>p [a,b] \<cdot> tl (tl ws)\<close> this]
+      show "tl (tl ws) \<in> [a, b]*".
+    qed
+    thus "ws \<in> [a,b]*"
+      unfolding add_root[of "[a,b]" "tl(tl ws)", symmetric]
+       *[folded \<open>[a,b] = [hd ws, hd (tl ws)]\<close> ].
+  qed
+qed
+
+lemma no_cyclic_repetition_list: 
+  assumes  "set ws \<subseteq> {a,b}" "ws \<notin> [a,b]*" "ws \<notin> [b,a]*" "hd ws \<noteq> last ws"
+    "\<not> [a,a] \<le>f ws" "\<not> [b,b] \<le>f ws" 
+  shows False
+  using per_root_hd_last_root[OF _ \<open>hd ws \<noteq> last ws\<close>] \<open>ws \<notin> [a,b]*\<close> \<open>ws \<notin> [b,a]*\<close>
+        no_repetition_list[OF assms(1) _ _ assms(5-6)] by blast
+
+subsection \<open>Three covers\<close>
+
+\<comment> \<open>Example:
+$v = a$
+$t = (b a^(j+1))^k b a$
+$r = a b (a^(j+1) b)^k$
+$t' = $
+$w = (a (b a^(j+1))^l b) a^(j+1) ((b a^(j+1))^m b a)$
+\<close>
+
+lemma three_covers_example: 
+  assumes 
+    v: "v = [0::nat]" and 
+    t: "t = ([1] \<cdot> [0]\<^sup>@Suc j)\<^sup>@Suc (m + l) \<cdot> [1,0] " and
+    r: "r = [0,1] \<cdot> ([0]\<^sup>@Suc j \<cdot> [1])\<^sup>@Suc (m + l)" and
+    t': "t' = ([1] \<cdot> [0]\<^sup>@Suc j)\<^sup>@m \<cdot> [1,0] " and
+    r': "r' = [0,1] \<cdot> ([0]\<^sup>@Suc j \<cdot> [1])\<^sup>@l" and
+    w: "w = [0] \<cdot> ([1] \<cdot> [0]\<^sup>@Suc j)\<^sup>@Suc (m + l) \<cdot> [1,0]"
+  shows "w = v \<cdot> t" and "w = r \<cdot> v" and "w = r' \<cdot> v\<^sup>@Suc j \<cdot> t'" and "t' <p t" and "r' <s r"
+proof-
+  show "w = v \<cdot> t"
+    unfolding w v t..
+  show "w = r \<cdot> v"
+    unfolding  w r v by comparison
+  show "t' <p t"
+    unfolding t t' pow_Suc2[of _ "m+l"] add_exps rassoc spref_cancel_conv 
+    unfolding lassoc unfolding rassoc[of _ "[1]"] pow_comm
+    unfolding pow_Suc rassoc by simp 
+  have "r = [0,1] \<cdot> ([0]\<^sup>@Suc j \<cdot> [1])\<^sup>@ m \<cdot> [0]\<^sup>@j \<cdot>  r'" 
+    unfolding r' r by comparison
+  thus "r' <s r" 
+    by force
+  show "w = r' \<cdot> v\<^sup>@Suc j \<cdot> t'"
+    unfolding w r' v t'  
+    by comparison 
+qed
+
+lemma three_covers_pers: \<comment> \<open>alias Old Good Lemma\<close>
+  assumes "w = v \<cdot> t" and "w = r' \<cdot> v\<^sup>@Suc j \<cdot> t'" and "w = r \<cdot> v" and
+    "r' <s r" and "t' <p t"
+  shows "period w (\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|)" and "period w (\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|)" and
+    "(\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|) + (\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|) = \<^bold>|w\<^bold>| + Suc j*\<^bold>|v\<^bold>| - 2*\<^bold>|v\<^bold>|"              
+proof-
+  let ?per_r = "\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|" 
+  let ?per_t = "\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|" 
+  let ?gcd = "gcd (\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|) (\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|)"
+  have "w \<noteq> \<epsilon>"
+    using \<open>w = v \<cdot> t\<close> \<open>t' <p t\<close> by auto 
+  obtain "r''" where "r'' \<cdot> r' = r" and "r'' \<noteq> \<epsilon>"
+    using  ssufD[OF \<open>r' <s r\<close>] sufD by blast    
+  hence "w \<le>p r'' \<cdot> w" 
+    using assms unfolding pow_Suc using rassoc triv_pref by metis
+  thus "period w ?per_r"
+    using lenarg[OF \<open>r'' \<cdot> r' = r\<close>]  period_I[OF \<open>w \<noteq> \<epsilon>\<close> \<open>r'' \<noteq> \<epsilon>\<close> \<open>w \<le>p r'' \<cdot> w\<close>] unfolding lenmorph
+    by (metis add_diff_cancel_right')  
+  have "\<^bold>|r'\<^bold>| < \<^bold>|r\<^bold>|"
+    using suffix_length_less[OF \<open>r' <s r\<close>].
+  obtain "t''" where "t' \<cdot> t'' = t" and "t'' \<noteq> \<epsilon>" 
+    using  sprefD[OF \<open>t' <p t\<close>] prefD by blast
+  hence "w \<le>s w \<cdot> t''" 
+    using assms unfolding pow_Suc2 using rassoc triv_suf by metis 
+  have "\<^bold>|t'\<^bold>| < \<^bold>|t\<^bold>|"
+    using prefix_length_less[OF \<open>t' <p t\<close>].
+  show "period w ?per_t"
+    using lenarg[OF \<open>t' \<cdot> t'' = t\<close>]  period_I[reversed, OF \<open>w \<noteq> \<epsilon>\<close> \<open>t'' \<noteq> \<epsilon>\<close> \<open>w \<le>s w \<cdot> t''\<close> ] unfolding lenmorph
+    by (metis add_diff_cancel_left')  
+  show eq: "?per_t + ?per_r = \<^bold>|w\<^bold>| + Suc j*\<^bold>|v\<^bold>| - 2*\<^bold>|v\<^bold>|"
+    using lenarg[OF \<open>w = r' \<cdot> v\<^sup>@Suc j \<cdot> t'\<close>]
+      lenarg[OF \<open>w = v \<cdot> t\<close>] lenarg[OF \<open>w = r \<cdot> v\<close>] \<open>\<^bold>|t'\<^bold>| < \<^bold>|t\<^bold>|\<close> \<open>\<^bold>|r'\<^bold>| < \<^bold>|r\<^bold>|\<close>
+    unfolding pow_len lenmorph by force
+qed
+
+lemma three_covers_per0: assumes "w = v \<cdot> t" and "w = r' \<cdot> v\<^sup>@Suc j \<cdot> t'" and "w = r \<cdot> v" and
+  "r' <s r" and "t' <p t" and "\<^bold>|t'\<^bold>| \<le> \<^bold>|r'\<^bold>|"  
+  and "primitive v"
+shows "period w (gcd (\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|) (\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|))"
+  using assms
+proof (induct "\<^bold>|w\<^bold>|" arbitrary: w t r t' r' v rule: less_induct)
+  case less
+  then show ?case
+  proof-
+    let ?per_r = "\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|" 
+    let ?per_t = "\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|" 
+    let ?gcd = "gcd (\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|) (\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|)"
+    have "v \<noteq> \<epsilon>" using prim_nemp[OF \<open>primitive v\<close>].
+    have "w \<noteq> \<epsilon>" using \<open>w = v \<cdot> t\<close> \<open>t' <p t\<close>  by blast
+    note prefix_length_less[OF \<open>t' <p t\<close>] prefix_length_less[reversed, OF \<open>r' <s r\<close>] 
+    have  "?gcd \<noteq> 0"
+      using \<open>\<^bold>|t'\<^bold>| < \<^bold>|t\<^bold>|\<close> gcd_eq_0_iff zero_less_diff' by metis
+    have "period w ?per_t" and "period w ?per_r"  and eq: "?per_t + ?per_r = \<^bold>|w\<^bold>| + Suc j*\<^bold>|v\<^bold>| - 2*\<^bold>|v\<^bold>|"
+      using three_covers_pers[OF \<open>w = v \<cdot> t\<close> \<open>w = r' \<cdot> v \<^sup>@ Suc j \<cdot> t'\<close> \<open>w = r \<cdot> v\<close> \<open>r' <s r\<close> \<open>t' <p t\<close>]. 
+
+    obtain "r''" where "r'' \<cdot> r' = r" and "r'' \<noteq> \<epsilon>"
+      using  ssufD[OF \<open>r' <s r\<close>] sufD by blast    
+    hence "w \<le>p r'' \<cdot> w" 
+      using less.prems unfolding pow_Suc using rassoc triv_pref by metis
+    obtain "t''" where "t' \<cdot> t'' = t" and "t'' \<noteq> \<epsilon>" 
+      using  sprefD[OF \<open>t' <p t\<close>] prefD by blast
+
+    show "period w ?gcd"
+    proof (cases)
+      have local_rule: "a - c \<le> b \<Longrightarrow> k + a - c - b \<le> k" for a b c k :: nat
+        by simp
+      assume "Suc j*\<^bold>|v\<^bold>| - 2*\<^bold>|v\<^bold>| \<le> ?gcd" \<comment> \<open>Condition allowing to use the Periodicity lemma\<close>
+      from local_rule[OF this] 
+      have len: "?per_t + ?per_r - ?gcd \<le> \<^bold>|w\<^bold>|"
+        unfolding eq.  
+      show "period w ?gcd"
+        using per_lemma[OF \<open>period w ?per_t\<close> \<open>period w ?per_r\<close> len].
+    next 
+      assume "\<not> Suc j*\<^bold>|v\<^bold>| - 2*\<^bold>|v\<^bold>| \<le> ?gcd"  \<comment> \<open>Periods are too long for the Periodicity lemma\<close>
+      hence "?gcd \<le> \<^bold>|v\<^sup>@Suc j\<^bold>| - 2*\<^bold>|v\<^bold>|"  \<comment> \<open>But then we have a potential for using the Periodicity lemma on the power of v's\<close>
+        unfolding pow_len by linarith
+      have "\<^bold>|v \<^sup>@ Suc j\<^bold>| - Suc (Suc 0) * \<^bold>|v\<^bold>| + \<^bold>|v\<^bold>| \<le> \<^bold>|v \<^sup>@ Suc j\<^bold>|"
+        by simp
+      with add_le_mono1[OF \<open>?gcd \<le> \<^bold>|v\<^sup>@Suc j\<^bold>| - 2*\<^bold>|v\<^bold>|\<close>, of "\<^bold>|v\<^bold>|"]
+      have "?gcd + \<^bold>|v\<^bold>| \<le> \<^bold>|v \<^sup>@ Suc j\<^bold>|"
+        unfolding numerals using le_trans by blast
+
+      show "period w ?gcd"
+      proof (cases)
+        assume "\<^bold>|r'\<^bold>| = \<^bold>|t'\<^bold>|" \<comment> \<open>The trivial case\<close>
+        hence "\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>| = \<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|"
+          using conj_len[OF \<open>w = v \<cdot> t\<close>[unfolded \<open>w = r \<cdot> v\<close>]] by force
+        show "period w (gcd (\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|) (\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|))"
+          unfolding \<open>\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>| = \<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|\<close>  gcd_idem_nat using \<open>period w (\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|)\<close>.
+      next
+        assume "\<^bold>|r'\<^bold>| \<noteq> \<^bold>|t'\<^bold>|" \<comment> \<open>The nontrivial case\<close>
+        hence "\<^bold>|t'\<^bold>| < \<^bold>|r'\<^bold>|" using \<open>\<^bold>|t'\<^bold>| \<le> \<^bold>|r'\<^bold>|\<close> by force
+        have "r' \<cdot> v <p w" 
+          using \<open>\<^bold>|r'\<^bold>| < \<^bold>|r\<^bold>|\<close> \<open>r'' \<cdot> r' = r\<close> \<open>w \<le>p r'' \<cdot> w\<close> \<open>w = r \<cdot> v\<close> by force 
+        obtain p where "r' \<cdot> v = v \<cdot> p" 
+          using   ruler_le[OF triv_pref[of v t , folded \<open>w = v \<cdot> t\<close>], of "r' \<cdot> v"] 
+          unfolding lenmorph \<open>w = r' \<cdot> v\<^sup>@Suc j \<cdot> t'\<close>[unfolded pow_Suc] rassoc 
+          by (force simp add: prefix_def)
+        from \<open>w = r' \<cdot> v\<^sup>@Suc j \<cdot> t'\<close>[unfolded pow_Suc lassoc this \<open>w = v \<cdot> t\<close>, unfolded rassoc cancel]
+        have "p \<le>p t"
+          by blast  
+        have "\<^bold>|v \<cdot> p\<^bold>| < \<^bold>|w\<^bold>|"
+          using prefix_length_less[OF \<open>r' \<cdot> v <p w\<close>, unfolded \<open>r' \<cdot> v = v \<cdot> p\<close>].
+        have "v \<cdot> p \<le>s w" \<comment> \<open>r'v is a long border of w\<close>
+          using \<open>r' \<cdot> v = v \<cdot> p\<close> \<open>w = r \<cdot> v\<close> \<open>r' <s r\<close> same_suffix_suffix ssufD by metis
+        have "\<^bold>|r'\<^bold>| = \<^bold>|p\<^bold>|"
+          using conj_len[OF \<open>r' \<cdot> v = v \<cdot> p\<close>].
+        note \<open>\<^bold>|t'\<^bold>| \<le> \<^bold>|r'\<^bold>|\<close>[unfolded \<open>\<^bold>|r'\<^bold>| = \<^bold>|p\<^bold>|\<close>] 
+        hence "t' <p p"
+          using \<open>t = p \<cdot> v \<^sup>@ j \<cdot> t'\<close> \<open>t' \<cdot> t'' = t\<close> \<open>\<^bold>|r'\<^bold>| = \<^bold>|p\<^bold>|\<close> \<open>\<^bold>|t'\<^bold>| < \<^bold>|r'\<^bold>|\<close> \<open>p \<le>p t\<close> pref_prod_long_less by metis
+        show ?thesis
+        proof (cases)                                 
+          assume "\<^bold>|v \<cdot> p\<^bold>| \<le> \<^bold>|v\<^sup>@Suc j \<cdot> t'\<^bold>|" \<comment> \<open>The border does not cover the whole power of v's. 
+                                              In this case, everything commutes\<close>
+          have "\<rho> (rev v) = rev (\<rho> v)"
+            using \<open>v \<noteq> \<epsilon>\<close> primroot_rev by auto
+          from pref_marker_ext[reversed, OF \<open>\<^bold>|t'\<^bold>| \<le> \<^bold>|p\<^bold>|\<close> \<open>v \<noteq> \<epsilon>\<close>]
+            suf_prod_le[OF \<open>v \<cdot> p \<le>s w\<close>[unfolded \<open>w = r' \<cdot> v\<^sup>@Suc j \<cdot> t'\<close>] \<open>\<^bold>|v \<cdot> p\<^bold>| \<le> \<^bold>|v\<^sup>@Suc j \<cdot> t'\<^bold>|\<close>]
+          obtain k where "p = v\<^sup>@k \<cdot> t'" 
+            unfolding  prim_self_root[OF \<open>primitive v\<close>].
+          hence "p \<le>p v\<^sup>@k \<cdot> p"
+            using \<open>t' <p p\<close> by simp
+          from root_comm_root[OF this power_commutes[symmetric]]
+          have "p \<le>p v \<cdot> p"
+            using \<open>\<^bold>|r'\<^bold>| = \<^bold>|p\<^bold>|\<close> \<open>\<^bold>|r'\<^bold>| \<noteq> \<^bold>|t'\<^bold>|\<close> \<open>p = v \<^sup>@ k \<cdot> t'\<close> by force 
+          hence "p = r'"           
+            using \<open>\<^bold>|r'\<^bold>| = \<^bold>|p\<^bold>|\<close> \<open>r' \<cdot> v = v \<cdot> p\<close> pref_prod_eq by metis
+          note \<open>r' \<cdot> v = v \<cdot> p\<close>[folded this] \<open>r' \<cdot> v = v \<cdot> p\<close>[unfolded this]
+          then obtain er' where "r' = v\<^sup>@er'"
+            using \<open>primitive v\<close> by auto
+          from \<open>p \<cdot> v = v \<cdot> p\<close>[unfolded \<open>p = v\<^sup>@k \<cdot> t'\<close> lassoc pow_comm[symmetric], unfolded rassoc cancel]
+          have "t' \<cdot> v = v \<cdot> t'".
+          then obtain et' where "t' = v\<^sup>@et'"
+            using \<open>primitive v\<close> by auto 
+          have "t \<cdot> v = v \<cdot> t"
+            by (simp add: pow_comm \<open>p = r'\<close> \<open>r' \<cdot> v = v \<cdot> r'\<close> \<open>t = p \<cdot> v \<^sup>@ j \<cdot> t'\<close> \<open>t' \<cdot> v = v \<cdot> t'\<close>)
+          then obtain et where "t = v\<^sup>@et"
+            using \<open>primitive v\<close> by auto 
+          have "r \<cdot> v = v \<cdot> r"
+            using \<open>t \<cdot> v = v \<cdot> t\<close> cancel_right \<open>w = v \<cdot> t\<close> \<open>w = r \<cdot> v\<close> by metis
+          then obtain er where "r = v\<^sup>@er"
+            using \<open>primitive v\<close> by auto 
+          have "w \<cdot> v = v \<cdot> w"
+            by (simp add: \<open>r \<cdot> v = v \<cdot> r\<close> \<open>w = r \<cdot> v\<close>)
+          then obtain ew where "w = v\<^sup>@ew"
+            using \<open>primitive v\<close> by auto 
+          hence "period w \<^bold>|v\<^bold>|"
+            using \<open>v \<noteq> \<epsilon>\<close> \<open>w \<cdot> v = v \<cdot> w\<close> \<open>w \<noteq> \<epsilon>\<close> by blast 
+          have dift: "\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>| = (et - et')*\<^bold>|v\<^bold>|"
+            using lenarg[OF \<open>t = v\<^sup>@et\<close>] lenarg[OF \<open>t' = v\<^sup>@et'\<close>] unfolding lenmorph pow_len
+            by (simp add: diff_mult_distrib)  
+          have difr: "(\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|) = (er - er')*\<^bold>|v\<^bold>|"
+            using lenarg[OF \<open>r = v\<^sup>@er\<close>] lenarg[OF \<open>r' = v\<^sup>@er'\<close>] unfolding lenmorph pow_len
+            by (simp add: diff_mult_distrib)  
+          obtain g where g: "g*\<^bold>|v\<^bold>| = ?gcd"
+            unfolding dift difr mult.commute[of _ "\<^bold>|v\<^bold>|"]
+              gcd_mult_distrib_nat[symmetric] by blast
+          hence "g \<noteq> 0"
+            using  nemp_len[OF \<open>v \<noteq> \<epsilon>\<close>] per_positive[OF \<open>period w (\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|)\<close>] gcd_nat.neutr_eq_iff mult_is_0 by metis
+          from per_mult[OF \<open>period w \<^bold>|v\<^bold>|\<close> this]
+          show ?thesis
+            unfolding g.  
+        next
+          assume "\<not> \<^bold>|v \<cdot> p\<^bold>| \<le> \<^bold>|v \<^sup>@ Suc j \<cdot> t'\<^bold>|"  \<comment> \<open>The border covers the whole power. An induction is available.\<close>
+          then obtain ri' where "v \<cdot> p = ri'\<cdot>v\<^sup>@Suc j \<cdot> t'" and "ri' \<le>s r'" 
+            using \<open>v \<cdot> p \<le>s w\<close> unfolding \<open>w = r' \<cdot> v\<^sup>@Suc j \<cdot> t'\<close>
+            using suffix_append suffix_length_le by blast 
+          hence "ri' <s r'"
+            using \<open>r' \<cdot> v = v \<cdot> p\<close> cancel_right less.prems(2) less.prems(3) less.prems(4) suffix_order.le_neq_trans by metis
+
+          have gcd_eq: "gcd (\<^bold>|p\<^bold>| - \<^bold>|t'\<^bold>|) (\<^bold>|r'\<^bold>| - \<^bold>|ri'\<^bold>|) = ?gcd" \<comment> \<open>The two gcd's are the same\<close>
+          proof-
+            have "\<^bold>|r'\<^bold>| \<le> \<^bold>|r\<^bold>|"
+              by (simp add: \<open>\<^bold>|r'\<^bold>| < \<^bold>|r\<^bold>|\<close> dual_order.strict_implies_order)  
+            have "\<^bold>|t\<^bold>| = \<^bold>|r\<^bold>|"
+              using lenarg[OF \<open>w = v \<cdot> t\<close>] unfolding lenarg[OF \<open>w = r \<cdot> v\<close>]  lenmorph by auto
+            have e1: "\<^bold>|r'\<^bold>| - \<^bold>|ri'\<^bold>| = \<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|"
+              using lenarg[OF \<open>v \<cdot> p = ri'\<cdot>v\<^sup>@Suc j \<cdot> t'\<close>[folded \<open>r' \<cdot> v = v \<cdot> p\<close>]]
+                lenarg[OF \<open>w = r \<cdot> v\<close>[unfolded \<open>w = r' \<cdot> v\<^sup>@Suc j \<cdot> t'\<close>]]
+              unfolding lenmorph pow_len by (simp add: add.commute diff_add_inverse diff_diff_add)
+            have "\<^bold>|t\<^bold>| = \<^bold>|p\<^bold>| + \<^bold>|r'\<^bold>| - \<^bold>|ri'\<^bold>|"
+              unfolding add_diff_assoc[OF suffix_length_le[OF \<open>ri' \<le>s r'\<close>], unfolded e1, symmetric]
+                \<open>\<^bold>|t\<^bold>| = \<^bold>|r\<^bold>|\<close> unfolding \<open>\<^bold>|r'\<^bold>| = \<^bold>|p\<^bold>|\<close>   
+              using \<open>\<^bold>|r'\<^bold>| < \<^bold>|r\<^bold>|\<close>[unfolded \<open>\<^bold>|r'\<^bold>| = \<^bold>|p\<^bold>|\<close>] by linarith
+            (* TODO *)
+            hence e2: "\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>| = (\<^bold>|p\<^bold>| - \<^bold>|t'\<^bold>|) + (\<^bold>|r'\<^bold>| - \<^bold>|ri'\<^bold>|)"
+              using \<open>\<^bold>|t'\<^bold>| \<le> \<^bold>|p\<^bold>|\<close> diff_commute \<open>ri' \<le>s r'\<close> \<open>\<^bold>|r'\<^bold>| = \<^bold>|p\<^bold>|\<close> \<open>\<^bold>|r'\<^bold>| \<le> \<^bold>|r\<^bold>|\<close> \<open>\<^bold>|t\<^bold>| = \<^bold>|r\<^bold>|\<close>
+               by linarith 
+            show ?thesis  
+              unfolding e2 e1 gcd_add1..
+          qed
+
+          have per_vp: "period (v \<cdot> p) ?gcd" 
+          proof (cases)
+            assume "\<^bold>|t'\<^bold>| \<le> \<^bold>|ri'\<^bold>|" 
+              \<comment> \<open>By induction.\<close>
+            from less.hyps[OF \<open>\<^bold>|v \<cdot> p\<^bold>| < \<^bold>|w\<^bold>|\<close> refl \<open>v \<cdot> p = ri'\<cdot>v\<^sup>@Suc j \<cdot> t'\<close> \<open>r' \<cdot> v = v \<cdot> p\<close>[symmetric] \<open>ri' <s r'\<close> \<open>t' <p p\<close> this \<open>primitive v\<close>]
+            show "period (v \<cdot> p) ?gcd"
+              unfolding gcd_eq by blast
+          next \<comment> \<open>...(using symmetry)\<close>
+            assume "\<not> \<^bold>|t'\<^bold>| \<le> \<^bold>|ri'\<^bold>|" hence "\<^bold>|ri'\<^bold>| \<le> \<^bold>|t'\<^bold>|" by simp
+            have "period (rev p \<cdot> rev v) (gcd (\<^bold>|rev r'\<^bold>| - \<^bold>|rev ri'\<^bold>|) (\<^bold>|rev p\<^bold>| - \<^bold>|rev t'\<^bold>|))"
+            proof (rule less.hyps[OF _ _ _ refl])
+              show "\<^bold>|rev p \<cdot> rev v\<^bold>| < \<^bold>|w\<^bold>|"
+                using \<open>\<^bold>|v \<cdot> p\<^bold>| < \<^bold>|w\<^bold>|\<close> by simp 
+              show "rev p \<cdot> rev v = rev v \<cdot> rev r'"
+                using \<open>r' \<cdot> v = v \<cdot> p\<close> unfolding rev_append[symmetric] by simp 
+              show "rev p \<cdot> rev v = rev t' \<cdot> rev v \<^sup>@ Suc j \<cdot> rev ri'"
+                using \<open>v \<cdot> p = ri'\<cdot>v\<^sup>@Suc j \<cdot> t'\<close> unfolding rev_append[symmetric] rev_pow[symmetric] rassoc by simp
+              show "rev t' <s rev p"
+                using \<open>t' <p p\<close> by (auto simp add: prefix_def) 
+              show "rev ri' <p rev r'"
+                using \<open>ri' <s r'\<close> strict_suffix_to_prefix by blast
+              show "\<^bold>|rev ri'\<^bold>| \<le> \<^bold>|rev t'\<^bold>|"
+                by (simp add: \<open>\<^bold>|ri'\<^bold>| \<le> \<^bold>|t'\<^bold>|\<close>) 
+              show "primitive (rev v)"
+                by (simp add: \<open>primitive v\<close> prim_rev_iff)
+            qed 
+            thus ?thesis
+              unfolding length_rev rev_append[symmetric] period_rev_conv gcd.commute[of "\<^bold>|r'\<^bold>| - \<^bold>|ri'\<^bold>|"] gcd_eq. 
+          qed
+
+          have "period (v\<^sup>@Suc j) (gcd \<^bold>|v\<^bold>| ?gcd)"
+          proof (rule per_lemma)
+            show " \<^bold>|v\<^bold>| + ?gcd - gcd \<^bold>|v\<^bold>| (gcd (\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|) (\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|)) \<le> \<^bold>|v \<^sup>@ Suc j\<^bold>|"
+              using \<open>?gcd + \<^bold>|v\<^bold>| \<le> \<^bold>|v \<^sup>@ Suc j\<^bold>|\<close> by linarith
+            show "period (v \<^sup>@ Suc j) \<^bold>|v\<^bold>|"
+              using \<open>v \<noteq> \<epsilon>\<close> pow_per by blast
+            have "v \<^sup>@ Suc j \<noteq> \<epsilon>"
+              using \<open>v \<noteq> \<epsilon>\<close> by auto
+            from period_fac[OF per_vp[unfolded \<open>v \<cdot> p = ri' \<cdot> v \<^sup>@ Suc j \<cdot> t'\<close>] this]
+            show "period (v \<^sup>@ Suc j) ?gcd".
+          qed
+
+          have per_vp': "period (v \<cdot> p) (gcd \<^bold>|v\<^bold>| ?gcd)"
+          proof (rule refine_per)
+            show "gcd \<^bold>|v\<^bold>| ?gcd dvd ?gcd" by blast
+            show "?gcd \<le> \<^bold>|v\<^sup>@Suc j\<^bold>|"
+              using \<open>?gcd + \<^bold>|v\<^bold>| \<le> \<^bold>|v \<^sup>@ Suc j\<^bold>|\<close> add_leE by blast
+            show "v \<^sup>@ Suc j \<le>f v \<cdot> p"
+              using  facI'[OF \<open>v \<cdot> p = ri' \<cdot> v \<^sup>@ Suc j \<cdot> t'\<close>[symmetric]].
+          qed fact+
+
+          have "period w (gcd \<^bold>|v\<^bold>| ?gcd)"
+          proof (rule per_glue)
+            show "v \<cdot> p \<le>p w"
+              using \<open>p \<le>p t\<close> \<open>w = v \<cdot> t\<close> by auto
+            have "\<^bold>|v \<^sup>@ Suc j\<^bold>| + \<^bold>|t'\<^bold>| \<le> \<^bold>|v\<^bold>| + \<^bold>|p\<^bold>|"
+              using \<open>\<not> \<^bold>|v \<cdot> p\<^bold>| \<le> \<^bold>|v \<^sup>@ Suc j \<cdot> t'\<^bold>|\<close> by auto
+            moreover have "\<^bold>|r'\<^bold>| + gcd \<^bold>|v\<^bold>| ?gcd \<le> \<^bold>|v\<^bold>| + \<^bold>|p\<^bold>|"
+              using lenarg[OF \<open>r' \<cdot> v = v \<cdot> p\<close>, unfolded lenmorph]
+                \<open>v \<noteq> \<epsilon>\<close> gcd_le1_nat length_0_conv nat_add_left_cancel_le by metis 
+            ultimately show "\<^bold>|w\<^bold>| + gcd \<^bold>|v\<^bold>| ?gcd \<le> \<^bold>|v \<cdot> p\<^bold>| + \<^bold>|v \<cdot> p\<^bold>|"
+              unfolding lenarg[OF \<open>w = r' \<cdot> v \<^sup>@ Suc j \<cdot> t'\<close>] lenmorph add.commute[of "\<^bold>|r'\<^bold>|"] by linarith
+          qed fact+
+
+          obtain k where k: "?gcd = k*(gcd \<^bold>|v\<^bold>| ?gcd)"
+            using gcd_dvd2 unfolding dvd_def mult.commute[of _ "gcd \<^bold>|v\<^bold>| ?gcd"] by blast
+          hence "k \<noteq> 0"
+            using \<open>?gcd \<noteq> 0\<close> by algebra
+
+          from per_mult[OF \<open>period w (gcd \<^bold>|v\<^bold>| ?gcd)\<close> this, folded k] 
+          show ?thesis.
+        qed
+      qed
+    qed
+  qed
+qed
+
+lemma three_covers_per: assumes "w = v \<cdot> t" and "w = r' \<cdot> v\<^sup>@Suc j \<cdot> t'" and "w = r \<cdot> v" and
+  "r' <s r" and "t' <p t"
+shows "period w (gcd (\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|) (\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|))"
+proof-
+  let ?per_r = "\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|" 
+  let ?per_t = "\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|" 
+  let ?gcd = "gcd (\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|) (\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|)"
+  have "period w ?per_t" and "period w ?per_r" and len: "(\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|) + (\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|) = \<^bold>|w\<^bold>| + Suc j*\<^bold>|v\<^bold>| - 2*\<^bold>|v\<^bold>|"
+    using three_covers_pers[OF \<open>w = v \<cdot> t\<close> \<open>w = r' \<cdot> v \<^sup>@ Suc j \<cdot> t'\<close> \<open>w = r \<cdot> v\<close> \<open>r' <s r\<close> \<open>t' <p t\<close>] by blast+
+  show ?thesis
+  proof(cases)
+    assume "v = \<epsilon>"
+    have "\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>| + (\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|) = \<^bold>|w\<^bold>|"
+      using \<open>w = v \<cdot> t\<close> \<open>w = r' \<cdot> v\<^sup>@Suc j \<cdot> t'\<close> \<open>w = r \<cdot> v\<close> unfolding \<open>v = \<epsilon>\<close> emp_pow clean_emp  by force
+    from per_lemma[OF \<open>period w ?per_t\<close> \<open>period w ?per_r\<close>, unfolded this]
+    show "period w ?gcd"
+      by fastforce  
+  next
+    assume "v \<noteq> \<epsilon>"
+    show ?thesis
+    proof (cases)
+      assume "j \<le> 1"
+      hence "(j = 0 \<Longrightarrow> P) \<Longrightarrow> (j = 1 \<Longrightarrow> P) \<Longrightarrow> P" for P by force
+      hence "\<^bold>|w\<^bold>| + Suc j*\<^bold>|v\<^bold>| - 2*\<^bold>|v\<^bold>| - ?gcd \<le> \<^bold>|w\<^bold>|" \<comment> \<open>Condition allowing to use the Periodicity lemma\<close>
+        by (cases, simp_all)  
+      thus "period w ?gcd"
+        using per_lemma[OF \<open>period w ?per_t\<close> \<open>period w ?per_r\<close>] unfolding len by blast
+    next   
+      assume "\<not> j \<le> 1" hence "2 \<le> j" by simp
+      obtain e where "v = \<rho> v\<^sup>@Suc e"
+        using \<open>v \<noteq> \<epsilon>\<close> primroot_expE by metis 
+      have "e + (Suc e * (Suc j - 2) + 2 + e) = Suc e * (Suc j - 2) + Suc e + Suc e"
+        by auto
+      also have "... = Suc e * (Suc j - 2 + Suc 0 + Suc 0)" 
+        unfolding add_mult_distrib2 by simp
+      also have "... = Suc e * Suc j"  
+        using \<open>2 \<le> j\<close> by auto  
+      finally have calc: "e + (Suc e * (Suc j - 2) + 2 + e) = Suc e * Suc j".
+      have "w = \<rho> v \<cdot> (\<rho> v\<^sup>@e \<cdot> t)"
+        using \<open>v = \<rho> v \<^sup>@ Suc e\<close> \<open>w = v \<cdot> t\<close> by fastforce
+      have "w = (r \<cdot> \<rho> v\<^sup>@e) \<cdot> \<rho> v"
+        unfolding rassoc pow_Suc2[symmetric] \<open>v = \<rho> v \<^sup>@ Suc e\<close>[symmetric] by fact 
+      obtain e' where e': "Suc e' = Suc e * (Suc j - 2) + 2"
+        by auto 
+      have "w = (r' \<cdot> \<rho> v\<^sup>@e) \<cdot> \<rho> v \<^sup>@Suc e' \<cdot> (\<rho> v\<^sup>@e \<cdot> t')"
+        unfolding e'\<open>w = r' \<cdot> v\<^sup>@Suc j \<cdot> t'\<close> rassoc cancel unfolding lassoc cancel_right add_exps[symmetric] calc
+          pow_mult \<open>v = \<rho> v\<^sup>@Suc e\<close>[symmetric].. 
+
+      show ?thesis   
+      proof(cases)
+        assume "\<^bold>|t'\<^bold>| \<le> \<^bold>|r'\<^bold>|"
+        have dif1: "\<^bold>|\<rho> v \<^sup>@ e \<cdot> t\<^bold>| - \<^bold>|\<rho> v \<^sup>@ e \<cdot> t'\<^bold>| = \<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|"
+          unfolding lenmorph by simp
+        have dif2: "\<^bold>|r \<cdot> \<rho> v \<^sup>@ e\<^bold>| - \<^bold>|r' \<cdot> \<rho> v \<^sup>@ e\<^bold>| = \<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|"
+          unfolding lenmorph by simp
+        show ?thesis
+        proof (rule  three_covers_per0[OF \<open>w = \<rho> v \<cdot> (\<rho> v\<^sup>@e \<cdot> t)\<close>
+              \<open>w = (r' \<cdot> \<rho> v\<^sup>@e) \<cdot> \<rho> v \<^sup>@Suc e' \<cdot> (\<rho> v\<^sup>@e \<cdot> t')\<close> \<open>w = (r \<cdot> \<rho> v\<^sup>@e) \<cdot> \<rho> v\<close>, unfolded dif1 dif2])
+          show "r' \<cdot> \<rho> v \<^sup>@ e <s r \<cdot> \<rho> v \<^sup>@ e"
+            using \<open>r' <s r\<close> by auto  
+          show "\<rho> v \<^sup>@ e \<cdot> t' <p \<rho> v \<^sup>@ e \<cdot> t"
+            using \<open>t' <p t\<close> by auto  
+          show "\<^bold>|\<rho> v \<^sup>@ e \<cdot> t'\<^bold>| \<le> \<^bold>|r' \<cdot> \<rho> v \<^sup>@ e\<^bold>|"
+            unfolding lenmorph using \<open>\<^bold>|t'\<^bold>| \<le> \<^bold>|r'\<^bold>|\<close> by auto  
+          show "primitive (\<rho> v)"
+            using primroot_prim[OF \<open>v \<noteq> \<epsilon>\<close>].
+        qed
+      next
+        let ?w = "rev w" and ?r = "rev t" and ?t = "rev r" and ?\<rho> = "rev (\<rho> v)" and ?r' = "rev t'" and ?t' = "rev r'"
+        assume "\<not> \<^bold>|t'\<^bold>| \<le> \<^bold>|r'\<^bold>|" 
+        hence "\<^bold>|?t'\<^bold>| \<le> \<^bold>|?r'\<^bold>|" by auto
+        have "?w = (?r \<cdot> ?\<rho>\<^sup>@e) \<cdot> ?\<rho>" 
+          unfolding rev_pow[symmetric] rev_append[symmetric] \<open>w = \<rho> v \<cdot> (\<rho> v\<^sup>@e \<cdot> t)\<close> rassoc..
+        have "?w = ?\<rho> \<cdot> (?\<rho>\<^sup>@e \<cdot> ?t)"
+          unfolding rev_pow[symmetric] rev_append[symmetric] \<open>w = (r \<cdot> \<rho> v\<^sup>@e) \<cdot> \<rho> v\<close>.. 
+        have "?w = (?r' \<cdot> ?\<rho>\<^sup>@e) \<cdot> ?\<rho>\<^sup>@Suc e' \<cdot> (?\<rho>\<^sup>@e \<cdot> ?t')"
+          unfolding rev_pow[symmetric] rev_append[symmetric] \<open>w = (r' \<cdot> \<rho> v\<^sup>@e) \<cdot> \<rho> v \<^sup>@Suc e' \<cdot> (\<rho> v\<^sup>@e \<cdot> t')\<close> rassoc.. 
+        have dif1: "\<^bold>|?\<rho> \<^sup>@ e \<cdot> ?t\<^bold>| - \<^bold>|?\<rho> \<^sup>@ e \<cdot> ?t'\<^bold>| = \<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|"
+          unfolding lenmorph by simp
+        have dif2: "\<^bold>|?r \<cdot> ?\<rho> \<^sup>@ e\<^bold>| - \<^bold>|?r' \<cdot> ?\<rho> \<^sup>@ e\<^bold>| = \<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|"
+          unfolding lenmorph by simp
+        show ?thesis
+        proof (rule  three_covers_per0[OF \<open>?w = ?\<rho> \<cdot> (?\<rho>\<^sup>@e \<cdot> ?t)\<close>
+              \<open>?w = (?r' \<cdot> ?\<rho>\<^sup>@e) \<cdot> ?\<rho>\<^sup>@Suc e' \<cdot> (?\<rho>\<^sup>@e \<cdot> ?t')\<close> \<open>?w = (?r \<cdot> ?\<rho>\<^sup>@e) \<cdot> ?\<rho>\<close>, 
+              unfolded dif1 dif2 period_rev_conv gcd.commute[of "\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|"]])
+          show "?r' \<cdot> ?\<rho> \<^sup>@ e <s ?r \<cdot> ?\<rho> \<^sup>@ e"
+            using \<open>t' <p t\<close> by (auto simp add: prefix_def) 
+          show "?\<rho> \<^sup>@ e \<cdot> ?t' <p ?\<rho> \<^sup>@ e \<cdot> ?t"
+            using \<open>r' <s r\<close> by (auto simp add: suf_def)  
+          show "\<^bold>|?\<rho> \<^sup>@ e \<cdot> ?t'\<^bold>| \<le> \<^bold>|?r' \<cdot> ?\<rho> \<^sup>@ e\<^bold>|"
+            unfolding lenmorph using \<open>\<^bold>|?t'\<^bold>| \<le> \<^bold>|?r'\<^bold>|\<close> by auto  
+          show "primitive ?\<rho>"
+            using primroot_prim[OF \<open>v \<noteq> \<epsilon>\<close>] by (simp add: prim_rev_iff) 
+        qed
+      qed
+    qed
+  qed
+qed
+
+hide_fact three_covers_per0
+
+lemma three_covers_pref_suf_pow: assumes "x \<cdot> y \<le>p w" and "y \<cdot> x \<le>s w" and "w \<le>f y\<^sup>@k" and  "\<^bold>|y\<^bold>| \<le> \<^bold>|x\<^bold>|"
+  shows "x \<cdot> y =  y \<cdot> x" 
+  using fac_marker_suf[OF fac_trans[OF pref_fac[OF \<open>x \<cdot> y \<le>p w\<close>] \<open>w \<le>f y\<^sup>@k\<close>]]
+    fac_marker_pref[OF fac_trans[OF suf_fac[OF \<open>y \<cdot> x \<le>s w\<close>] \<open>w \<le>f y\<^sup>@k\<close>]]
+    root_suf_comm'[OF _ suf_prod_long, OF _ _ \<open>\<^bold>|y\<^bold>| \<le> \<^bold>|x\<^bold>|\<close>, of x] by presburger  
+
+subsection \<open>Binary Equality Words\<close>
+
+(*rudimentary material for classification of binary equality words *)
+
+\<comment> \<open>translation of a combinatorial lemma into the language of "something is not BEW"\<close>
+
+definition binary_equality_word :: "binA list \<Rightarrow> bool" where
+  "binary_equality_word w = (\<exists> (g :: binA list \<Rightarrow> nat list) h. binary_code_morphism g \<and> binary_code_morphism h \<and> g \<noteq> h \<and> w \<in> g =\<^sub>M h)"
+
+lemma not_bew_baiba: assumes  "\<^bold>|y\<^bold>| < \<^bold>|v\<^bold>|" and  "x \<le>s y" and "u \<le>s v" and 
+  "y \<cdot> x \<^sup>@ k \<cdot> y = v \<cdot> u \<^sup>@ k \<cdot> v"
+shows "commutes {x,y,u,v}" 
+proof-
+  obtain p where "y\<cdot>p = v"
+    using eqdE[OF \<open>y \<cdot> x \<^sup>@ k \<cdot> y = v \<cdot> u \<^sup>@ k \<cdot> v\<close> less_imp_le[OF \<open>\<^bold>|y\<^bold>| < \<^bold>|v\<^bold>|\<close>]] by blast
+  have "\<^bold>|u \<^sup>@ k \<cdot> v\<^bold>| \<le> \<^bold>|x \<^sup>@ k \<cdot> y\<^bold>|"
+    using lenarg[OF \<open>y \<cdot> x \<^sup>@ k \<cdot> y = v \<cdot> u \<^sup>@ k \<cdot> v\<close>] \<open>\<^bold>|y\<^bold>| < \<^bold>|v\<^bold>|\<close> unfolding lenmorph
+    by linarith 
+  obtain s where "s\<cdot>y = v"
+    using eqdE[reversed, OF \<open>y \<cdot> x \<^sup>@ k \<cdot> y = v \<cdot> u \<^sup>@ k \<cdot> v\<close>[unfolded lassoc] less_imp_le[OF \<open>\<^bold>|y\<^bold>| < \<^bold>|v\<^bold>|\<close>]]. 
+
+  have "s \<noteq> \<epsilon>"
+    using \<open>\<^bold>|y\<^bold>| < \<^bold>|v\<^bold>|\<close> \<open>s \<cdot> y = v\<close> by force
+  have "p \<noteq> \<epsilon>"
+    using \<open>\<^bold>|y\<^bold>| < \<^bold>|v\<^bold>|\<close> \<open>y \<cdot> p = v\<close> by force
+
+  have "s \<cdot> y = y \<cdot> p"
+    by (simp add: \<open>s \<cdot> y = v\<close> \<open>y \<cdot> p = v\<close>)
+  obtain w w' q t where p_def: "p = (w'\<cdot>w)\<^sup>@Suc q" and s_def: "s = (w\<cdot>w')\<^sup>@Suc q" and y_def: "y = (w\<cdot>w')\<^sup>@t\<cdot>w" and "w' \<noteq> \<epsilon>" and "primitive (w\<cdot>w')"
+    using conjug_eq_primrootE[OF \<open>s \<cdot> y = y \<cdot> p\<close> \<open>s \<noteq> \<epsilon>\<close>, of thesis]
+    by blast
+  have "primitive (w'\<cdot>w)"
+    using \<open>primitive (w \<cdot> w')\<close> prim_conjug by auto
+
+  have "y \<cdot> x \<^sup>@ k \<cdot> y = y\<cdot> p \<cdot> u \<^sup>@ k \<cdot> s \<cdot> y"
+    using \<open>s \<cdot> y = v\<close> \<open>y \<cdot> p = v\<close> \<open>y \<cdot> x \<^sup>@ k \<cdot> y = v \<cdot> u \<^sup>@ k \<cdot> v\<close> by auto
+  hence "x\<^sup>@k = p\<cdot>u\<^sup>@k\<cdot>s"
+    by auto
+  hence "x \<noteq> \<epsilon>"
+    using \<open>p \<noteq> \<epsilon>\<close> by force
+
+  have "w\<cdot>w' \<le>s x\<^sup>@k"
+    using \<open>x \<^sup>@ k = p \<cdot> u \<^sup>@ k \<cdot> s\<close>[unfolded s_def]
+    unfolding CoWBasic.power_Suc2
+    using sufI[of "p \<cdot> u \<^sup>@ k \<cdot> (w \<cdot> w') \<^sup>@ q" "w \<cdot> w'" "x\<^sup>@k", unfolded rassoc]
+    by argo
+
+  have "\<^bold>|w\<cdot>w'\<^bold>| \<le> \<^bold>|x\<^bold>|"
+  proof(intro leI notI)
+    assume "\<^bold>|x\<^bold>| < \<^bold>|w \<cdot> w'\<^bold>|" 
+    have "x \<le>s (w\<cdot>w')\<cdot>y"
+      using  \<open>x \<le>s y\<close>  by (auto simp add: suf_def)
+    have "(w'\<cdot>w) \<le>s (w\<cdot>w')\<cdot>y"
+      unfolding \<open>y = (w\<cdot>w')\<^sup>@t\<cdot>w\<close> lassoc pow_comm[symmetric] suf_cancel_conv
+      by blast
+     
+    from ruler_le[reversed, OF \<open>x \<le>s (w\<cdot>w')\<cdot>y\<close> this 
+        less_imp_le[OF \<open>\<^bold>|x\<^bold>| < \<^bold>|w \<cdot> w'\<^bold>|\<close>[unfolded swap_len]]]
+    have "x \<le>s w'\<cdot> w".
+    hence "x \<le>s p"
+      unfolding p_def pow_Suc2 suffix_append by blast  
+    from root_suf_comm[OF _ suf_ext[OF this]]
+    have "x\<cdot>p = p\<cdot>x"
+      using pref_prod_root[OF prefI[OF \<open>x \<^sup>@ k = p \<cdot> u \<^sup>@ k \<cdot> s\<close>[symmetric]]] by blast
+    from  comm_drop_exp[OF _ this[unfolded \<open>p = (w' \<cdot> w) \<^sup>@ Suc q\<close>]]
+    have "x \<cdot> (w' \<cdot> w) = (w' \<cdot> w) \<cdot> x"
+      by force
+    from prim_comm_short_emp[OF \<open>primitive (w'\<cdot>w)\<close> this \<open>\<^bold>|x\<^bold>| < \<^bold>|w\<cdot>w'\<^bold>|\<close>[unfolded swap_len]]
+    show False 
+      using \<open>x \<noteq> \<epsilon>\<close> by blast
+  qed
+
+  hence "w\<cdot>w' \<le>s x"
+    using  suf_prod_le[OF suf_prod_root[OF \<open>w \<cdot> w' \<le>s x \<^sup>@ k\<close>]] by blast
+  from suffix_order.trans[OF this \<open>x \<le>s y\<close>]
+  have "w \<cdot> w' \<le>s y".
+  hence "\<^bold>|w \<cdot> w'\<^bold>| \<le> \<^bold>|y\<^bold>|"
+    using suffix_length_le by blast 
+  then obtain t' where  "t = Suc t'"
+    unfolding  y_def lenmorph pow_len \<open>w' \<noteq> \<epsilon>\<close> add.commute[of _ "\<^bold>|w\<^bold>|"] nat_add_left_cancel_le
+    using \<open>w' \<noteq> \<epsilon>\<close> mult_0[of "\<^bold>|w\<^bold>| + \<^bold>|w'\<^bold>|"] npos_len[of w'] not0_implies_Suc[of t] by force
+  from ruler_eq_len[reversed, OF \<open>w \<cdot> w' \<le>s y\<close> _ swap_len, unfolded y_def this pow_Suc2 rassoc]  
+  have "w \<cdot> w' = w'\<cdot> w"
+    unfolding lassoc suf_cancel_conv by blast 
+  from comm_not_prim[OF _ \<open>w' \<noteq> \<epsilon>\<close> this]
+  have "w = \<epsilon>" 
+    using  \<open>primitive (w \<cdot> w')\<close> by blast
+  hence "primitive w'"
+    using \<open>primitive (w' \<cdot> w)\<close> by auto
+
+  have "k \<noteq> 0"
+    using \<open>\<^bold>|y\<^bold>| < \<^bold>|v\<^bold>|\<close> lenarg[OF \<open>y \<cdot> x \<^sup>@ k \<cdot> y = v \<cdot> u \<^sup>@ k \<cdot> v\<close>, unfolded lenmorph pow_len]
+      not_add_less1 by fastforce 
+
+  have "y = w'\<^sup>@t"
+    using y_def \<open>w = \<epsilon>\<close>  by force 
+  hence "y \<in> w'*"
+    using rootI by blast
+
+  have "s \<in> w'*"
+    using s_def \<open>w = \<epsilon>\<close> rootI by force
+  hence "v \<in> w'*"
+    using \<open>s \<cdot> y = v\<close>  \<open>y \<in> w'*\<close> add_roots by blast
+
+  have "w' \<le>p x"
+    using \<open>x\<^sup>@k = p\<cdot>u\<^sup>@k\<cdot>s\<close> eq_le_pref[OF _ \<open>\<^bold>|w\<cdot>w'\<^bold>| \<le> \<^bold>|x\<^bold>|\<close>, of "w' \<^sup>@ q \<cdot> u \<cdot> u \<^sup>@ (k - 1) \<cdot> s" "x \<^sup>@ (k - 1)"] 
+    unfolding p_def \<open>w = \<epsilon>\<close> clean_emp pop_pow_one[OF \<open>k \<noteq> 0\<close>] pow_Suc rassoc
+    by argo
+
+  have "x \<cdot> w' = w' \<cdot> x"
+    using  \<open>x \<le>s y\<close>  \<open>w' \<le>p x\<close> y_def[unfolded \<open>w = \<epsilon>\<close> \<open>t = Suc t'\<close> clean_emp]
+      pref_suf_pows_comm[of w' x 0 0 0 t', unfolded pow_zero clean_emp, folded y_def[unfolded \<open>w = \<epsilon>\<close> \<open>t = Suc t'\<close>, unfolded clean_emp]]
+    by force
+  hence "x \<in> w'*"
+    using  prim_comm_exp[OF \<open>primitive w'\<close>, of x]
+    unfolding root_def
+    by metis
+
+  have "p \<in> w'*"
+    using \<open>s \<in> w'*\<close> \<open>y \<in> w'*\<close> \<open>s \<cdot> y = v\<close>[folded \<open>y \<cdot> p = v\<close>]
+    by (simp add: \<open>s \<cdot> y = y \<cdot> p\<close> \<open>s \<in> w'*\<close> \<open>y \<in> w'*\<close> \<open>w \<cdot> w' = w' \<cdot> w\<close> p_def s_def)
+
+  obtain k' where "k = Suc k'" using \<open>k \<noteq> 0\<close> not0_implies_Suc by auto 
+
+  have "u\<^sup>@k \<in> w'*"
+    using root_suf_cancel[OF \<open>s \<in> w'*\<close>, of "p \<cdot> u \<^sup>@ k", THEN root_pref_cancel[OF _ \<open>p \<in> w'*\<close>], unfolded rassoc, folded \<open>x\<^sup>@k = p\<cdot>u\<^sup>@k\<cdot>s\<close>, OF root_pow_root[OF \<open>x \<in> w'*\<close>]].
+  from prim_root_drop_exp[OF \<open>k \<noteq> 0\<close> \<open>primitive w'\<close> this]  
+  have "u \<in> w'*".      
+
+  show "commutes {x,y,u,v}"
+    by (intro commutesI_root[of _ w'], unfold Set.ball_simps(7), simp add: \<open>x \<in> w'*\<close> \<open>y \<in> w'*\<close> \<open>u \<in> w'*\<close> \<open>v \<in> w'*\<close>)
+qed
+
+lemma not_bew_baibaib: assumes "\<^bold>|x\<^bold>| < \<^bold>|u\<^bold>|" and "1 < i" and 
+  "x \<cdot> y\<^sup>@i\<cdot> x \<cdot> y\<^sup>@i \<cdot> x = u \<cdot> v\<^sup>@i\<cdot> u \<cdot> v\<^sup>@i \<cdot> u"
+shows "commutes {x,y,u,v}"
+proof-
+  have "i \<noteq> 0"
+    using assms(2) by auto
+
+  from lenarg[OF \<open>x \<cdot> y\<^sup>@i\<cdot> x \<cdot> y\<^sup>@i \<cdot> x = u \<cdot> v\<^sup>@i\<cdot> u \<cdot> v\<^sup>@i \<cdot> u\<close>]
+  have "2*\<^bold>|x \<cdot> y\<^sup>@i\<^bold>| + \<^bold>|x\<^bold>| = 2*\<^bold>|u \<cdot> v\<^sup>@i\<^bold>| + \<^bold>|u\<^bold>|"
+    by auto
+  hence "\<^bold>|u \<cdot> v\<^sup>@i\<^bold>| < \<^bold>|x \<cdot> y\<^sup>@i\<^bold>|"
+    using \<open>\<^bold>|x\<^bold>| < \<^bold>|u\<^bold>|\<close> by fastforce
+  hence "u \<cdot> v\<^sup>@i <p x \<cdot> y\<^sup>@i"
+    using assms(3) eq_le_pref less_or_eq_imp_le mult_assoc sprefI2 by metis
+
+  have "x\<cdot>y\<^sup>@i \<noteq> \<epsilon>"
+    by (metis \<open>u \<cdot> v \<^sup>@ i <p x \<cdot> y \<^sup>@ i\<close> strict_prefix_simps(1))
+  have "u\<cdot>v\<^sup>@i \<noteq> \<epsilon>"
+    using assms(1) gr_implies_not0 by blast
+
+  have "(u\<cdot>v\<^sup>@i) \<cdot> (x\<cdot>y\<^sup>@i) = (x\<cdot>y\<^sup>@i) \<cdot> (u\<cdot>v\<^sup>@i)"
+  proof(rule sq_short_per)
+    have eq: "(x \<cdot> y \<^sup>@ i) \<cdot> (x \<cdot> y \<^sup>@ i) \<cdot> x = (u \<cdot> v \<^sup>@ i) \<cdot> (u \<cdot> v \<^sup>@ i) \<cdot> u"
+      using assms(3) by auto
+    from lenarg[OF this] 
+    have "\<^bold>|u \<cdot> v\<^sup>@i \<cdot> u\<^bold>| < \<^bold>|x \<cdot> y\<^sup>@i \<cdot> x \<cdot> y\<^sup>@i\<^bold>|"
+      unfolding lenmorph using \<open>\<^bold>|x\<^bold>| < \<^bold>|u\<^bold>|\<close> by linarith
+    from eq_le_pref[OF _ less_imp_le[OF this]]
+    have "(u \<cdot> v\<^sup>@i)\<cdot>u \<le>p (x \<cdot> y\<^sup>@i) \<cdot> (x \<cdot> y\<^sup>@i)"
+      using eq[symmetric] unfolding rassoc by blast 
+    hence "(u \<cdot> v \<^sup>@ i) \<cdot> (u \<cdot> v\<^sup>@i) \<cdot> u \<le>p (u \<cdot> v \<^sup>@ i) \<cdot> ((x \<cdot> y\<^sup>@i) \<cdot> (x \<cdot> y\<^sup>@i))"
+      unfolding same_prefix_prefix.  
+    from pref_trans[OF prefI[of "(x \<cdot> y \<^sup>@ i) \<cdot> (x \<cdot> y \<^sup>@ i)" x "(x \<cdot> y \<^sup>@ i) \<cdot> (x \<cdot> y \<^sup>@ i) \<cdot> x"]
+        this[folded \<open>(x \<cdot> y \<^sup>@ i) \<cdot> (x \<cdot> y \<^sup>@ i) \<cdot> x = (u \<cdot> v \<^sup>@ i) \<cdot> (u \<cdot> v \<^sup>@ i) \<cdot> u\<close>],
+        unfolded rassoc, OF refl]
+    show "(x \<cdot> y\<^sup>@i)\<cdot>(x \<cdot> y\<^sup>@i) \<le>p (u \<cdot> v\<^sup>@i) \<cdot> ((x \<cdot> y\<^sup>@i) \<cdot> (x \<cdot> y\<^sup>@i))"
+      by fastforce
+    show "\<^bold>|u \<cdot> v \<^sup>@ i\<^bold>| \<le> \<^bold>|x \<cdot> y \<^sup>@ i\<^bold>|"
+      using less_imp_le_nat[OF \<open>\<^bold>|u \<cdot> v \<^sup>@ i\<^bold>| < \<^bold>|x \<cdot> y \<^sup>@ i\<^bold>|\<close>].
+  qed
+
+  obtain r m k where "x\<cdot>y\<^sup>@i = r\<^sup>@k" "u\<cdot>v\<^sup>@i = r\<^sup>@m" "primitive r"
+    using \<open>(u \<cdot> v \<^sup>@ i) \<cdot> x \<cdot> y \<^sup>@ i = (x \<cdot> y \<^sup>@ i) \<cdot> u \<cdot> v \<^sup>@ i\<close>[unfolded 
+        comm_primroots[OF \<open>u \<cdot> v \<^sup>@ i \<noteq> \<epsilon>\<close> \<open>x \<cdot> y \<^sup>@ i \<noteq> \<epsilon>\<close>]]
+      \<open>u \<cdot> v \<^sup>@ i \<noteq> \<epsilon>\<close> \<open>x \<cdot> y \<^sup>@ i \<noteq> \<epsilon>\<close> primroot_expE primroot_prim by metis
+
+  have "m < k"
+    using \<open>\<^bold>|u \<cdot> v \<^sup>@ i\<^bold>| < \<^bold>|x \<cdot> y \<^sup>@ i\<^bold>|\<close>
+    unfolding strict_prefix_def \<open>u \<cdot> v \<^sup>@ i = r \<^sup>@ m\<close> \<open>x \<cdot> y \<^sup>@ i = r \<^sup>@ k\<close>
+      pow_len
+    by simp
+
+  have "x\<cdot>y\<^sup>@i = u\<cdot>v\<^sup>@i\<cdot>r\<^sup>@(k-m)"
+    by (simp add: \<open>m < k\<close> \<open>u \<cdot> v \<^sup>@ i = r \<^sup>@ m\<close> \<open>x \<cdot> y \<^sup>@ i = r \<^sup>@ k\<close> lassoc less_imp_le_nat pop_pow)
+
+  have "\<^bold>|y \<^sup>@ i\<^bold>| = \<^bold>|v \<^sup>@ i\<^bold>| + 3 * \<^bold>|r \<^sup>@ (k - m)\<^bold>|" and "\<^bold>|r\<^bold>| \<le> \<^bold>|y\<^sup>@(i-1)\<^bold>|"
+  proof-
+    have "\<^bold>|x \<cdot> y\<^sup>@i\<^bold>| = \<^bold>|r\<^sup>@(k-m)\<^bold>| + \<^bold>|u \<cdot> v\<^sup>@i\<^bold>|"
+      using lenarg[OF \<open>x\<cdot>y\<^sup>@i = u\<cdot>v\<^sup>@i\<cdot>r\<^sup>@(k-m)\<close>]
+      by auto
+
+    have "\<^bold>|u\<^bold>| = 2 * \<^bold>|r \<^sup>@ (k - m)\<^bold>| + \<^bold>|x\<^bold>|"
+      using \<open>2*\<^bold>|x \<cdot> y\<^sup>@i\<^bold>| + \<^bold>|x\<^bold>| = 2*\<^bold>|u \<cdot> v\<^sup>@i\<^bold>| + \<^bold>|u\<^bold>|\<close>
+      unfolding \<open>\<^bold>|x \<cdot> y\<^sup>@i\<^bold>| = \<^bold>|r\<^sup>@(k-m)\<^bold>| + \<^bold>|u \<cdot> v\<^sup>@i\<^bold>|\<close>
+        add_mult_distrib2
+      by simp
+
+    have "2*\<^bold>|y\<^sup>@i\<^bold>| + 3*\<^bold>|x\<^bold>| = 2*\<^bold>|v\<^sup>@i\<^bold>| + 3*\<^bold>|u\<^bold>|"
+      using lenarg[OF \<open>x \<cdot> y\<^sup>@i\<cdot> x \<cdot> y\<^sup>@i \<cdot> x = u \<cdot> v\<^sup>@i\<cdot> u \<cdot> v\<^sup>@i \<cdot> u\<close>]
+      unfolding lenmorph numeral_3_eq_3 numerals(2)
+      by linarith
+
+    have "2 * \<^bold>|y \<^sup>@ i\<^bold>| = 2 * \<^bold>|v \<^sup>@ i\<^bold>| + 3 * (2 * \<^bold>|r \<^sup>@ (k - m)\<^bold>|)"
+      using \<open>2*\<^bold>|y\<^sup>@i\<^bold>| + 3*\<^bold>|x\<^bold>| = 2*\<^bold>|v\<^sup>@i\<^bold>| + 3*\<^bold>|u\<^bold>|\<close>
+      unfolding \<open>\<^bold>|u\<^bold>| = 2 * \<^bold>|r \<^sup>@ (k - m)\<^bold>| + \<^bold>|x\<^bold>|\<close> add_mult_distrib2
+      by simp
+    hence "2 * \<^bold>|y \<^sup>@ i\<^bold>| = 2 * \<^bold>|v \<^sup>@ i\<^bold>| + 2 * (3 * \<^bold>|r \<^sup>@ (k - m)\<^bold>|)"
+      by presburger
+    hence "2 * \<^bold>|y \<^sup>@ i\<^bold>| = 2 * (\<^bold>|v \<^sup>@ i\<^bold>| + (3 * \<^bold>|r \<^sup>@ (k - m)\<^bold>|))"
+      by simp
+    thus "\<^bold>|y \<^sup>@ i\<^bold>| = \<^bold>|v \<^sup>@ i\<^bold>| + 3 * \<^bold>|r \<^sup>@ (k - m)\<^bold>|"
+      using nat_mult_eq_cancel1[of 2] zero_less_numeral
+      by force
+    hence "3 * \<^bold>|r \<^sup>@ (k - m)\<^bold>| \<le> \<^bold>|y \<^sup>@ i\<^bold>|"
+      using le_add2 by presburger
+    moreover have "\<^bold>|r\<^bold>| \<le> \<^bold>|r \<^sup>@ (k - m)\<^bold>|"
+      by (metis CoWBasic.power.power_Suc CoWBasic.power_Suc2 \<open>primitive r\<close> \<open>u \<cdot> v \<^sup>@ i <p x \<cdot> y \<^sup>@ i\<close> \<open>x \<cdot> y \<^sup>@ i = u \<cdot> v \<^sup>@ i \<cdot> r \<^sup>@ (k - m)\<close> not_le prim_comm_short_emp self_append_conv strict_prefix_def)
+    ultimately have "3 * \<^bold>|r\<^bold>| \<le> \<^bold>|y \<^sup>@ i\<^bold>|"
+      by (meson le_trans mult_le_mono2)
+    hence "3 * \<^bold>|r\<^bold>| \<le> i*\<^bold>|y\<^bold>|"
+      by (simp add: pow_len)
+    moreover have "i \<le> 3*(i-1)"
+      using assms(2) by linarith
+    ultimately have "3*\<^bold>|r\<^bold>| \<le> 3*((i-1)*\<^bold>|y\<^bold>|)"
+      by (metis (no_types, lifting) le_trans mult.assoc mult_le_mono1)
+    hence "\<^bold>|r\<^bold>| \<le> (i-1)*\<^bold>|y\<^bold>|"
+      by (meson nat_mult_le_cancel1 zero_less_numeral)
+    thus "\<^bold>|r\<^bold>| \<le> \<^bold>|y\<^sup>@(i-1)\<^bold>|"
+      unfolding pow_len.
+  qed
+  have "\<^bold>|r\<^bold>| + \<^bold>|y\<^bold>| \<le> \<^bold>|y \<^sup>@ i\<^bold>|"
+    using \<open>\<^bold>|r\<^bold>| \<le> \<^bold>|y\<^sup>@(i-1)\<^bold>|\<close> 
+    unfolding pow_len nat_add_left_cancel_le[of "\<^bold>|y\<^bold>|" "\<^bold>|r\<^bold>|", symmetric]
+    using add.commute \<open>i \<noteq> 0\<close> mult_eq_if
+    by force
+
+  have "y\<^sup>@i \<le>s y\<^sup>@i\<cdot>r"
+    using triv_suf[of "y \<^sup>@ i" x, unfolded \<open>x \<cdot> y \<^sup>@ i = r \<^sup>@ k\<close>,
+        THEN suf_prod_root].
+  have "y\<^sup>@i \<le>s y\<^sup>@i\<cdot>y"
+    by (simp add: suf_pow_ext')
+
+  from two_pers[reversed, OF \<open>y\<^sup>@i \<le>s y\<^sup>@i\<cdot>r\<close> \<open>y\<^sup>@i \<le>s y\<^sup>@i\<cdot>y\<close> \<open>\<^bold>|r\<^bold>| + \<^bold>|y\<^bold>| \<le> \<^bold>|y \<^sup>@ i\<^bold>|\<close>]
+  have "y \<cdot> r = r \<cdot> y".
+
+  have "x \<cdot> y \<^sup>@ i \<cdot> r = r \<cdot> x \<cdot> y \<^sup>@ i"
+    by (simp add: power_commutes \<open>x \<cdot> y \<^sup>@ i = r \<^sup>@ k\<close> lassoc)
+  hence "x \<cdot> r \<cdot> y \<^sup>@ i  = r \<cdot> x \<cdot> y \<^sup>@ i"
+    by (simp add: \<open>y \<cdot> r = r \<cdot> y\<close> comm_add_exp)
+  hence "x \<cdot> r = r \<cdot> x"
+    by auto
+
+  obtain n where "y = r\<^sup>@n"
+    using \<open>primitive r\<close> \<open>y \<cdot> r = r \<cdot> y\<close> by blast
+  hence "\<^bold>|y\<^sup>@i\<^bold>| = i*n*\<^bold>|r\<^bold>|"
+    by (simp add: pow_len)
+  hence "\<^bold>|v \<^sup>@ i\<^bold>| = i*n*\<^bold>|r\<^bold>| - 3 * \<^bold>|r \<^sup>@ (k - m)\<^bold>|"
+    using \<open>\<^bold>|y \<^sup>@ i\<^bold>| = \<^bold>|v \<^sup>@ i\<^bold>| + 3 * \<^bold>|r \<^sup>@ (k - m)\<^bold>|\<close>
+      diff_add_inverse2 by presburger
+  hence "\<^bold>|v \<^sup>@ i\<^bold>| = (i*n - 3*(k-m))*\<^bold>|r\<^bold>|"
+    by (simp add: \<open>\<^bold>|v \<^sup>@ i\<^bold>| = i * n * \<^bold>|r\<^bold>| - 3 * \<^bold>|r \<^sup>@ (k - m)\<^bold>|\<close> ab_semigroup_mult_class.mult_ac(1) left_diff_distrib' pow_len)
+
+  have "v\<^sup>@i \<in> r*"
+    using per_exp_eq[reversed, OF _ \<open>\<^bold>|v \<^sup>@ i\<^bold>| = (i*n - 3*(k-m))*\<^bold>|r\<^bold>|\<close>]
+      \<open>u \<cdot> v \<^sup>@ i = r \<^sup>@ m\<close> suf_prod_root triv_suf by metis
+
+  have "u \<cdot> r = r \<cdot> u"
+    using  root_suf_cancel[OF \<open>v \<^sup>@ i \<in> r*\<close> rootI[of r m, folded \<open>u \<cdot> v \<^sup>@ i = r \<^sup>@ m\<close>]]
+      self_root[of r] unfolding comm_root
+    by blast
+
+  have "v \<cdot> r = r \<cdot> v"
+    using comm_drop_exp[OF \<open>i \<noteq> 0\<close>, 
+        OF comm_rootI[OF self_root \<open>v\<^sup>@i \<in> r*\<close>]].
+
+  show ?thesis
+    using commutesI_root[of "{x, y, u, v}" r]
+      prim_comm_root[OF \<open>primitive r\<close> \<open>u \<cdot> r = r \<cdot> u\<close>]
+      prim_comm_root[OF \<open>primitive r\<close> \<open>v \<cdot> r = r \<cdot> v\<close>]
+      prim_comm_root[OF \<open>primitive r\<close> \<open>x \<cdot> r = r \<cdot> x\<close>]
+      prim_comm_root[OF \<open>primitive r\<close> \<open>y \<cdot> r = r \<cdot> y\<close>]
+    by auto
+qed
+
+theorem "\<not> binary_equality_word (\<zero> \<cdot> \<one>\<^sup>@Suc k \<cdot> \<zero> \<cdot> \<one>)"
+proof
+  assume "binary_equality_word (\<zero> \<cdot> \<one> \<^sup>@ Suc k \<cdot> \<zero> \<cdot> \<one>)"
+  then obtain g' h' where g'_morph: "binary_code_morphism (g' :: binA list \<Rightarrow> nat list)" and h'_morph: "binary_code_morphism h'" and "g' \<noteq> h'" and 
+    msol': "(\<zero> \<cdot> \<one> \<^sup>@ Suc k \<cdot> \<zero> \<cdot> \<one>) \<in> g' =\<^sub>M h'"
+    using binary_equality_word_def by blast
+  interpret g': binary_code_morphism g'
+    by fact 
+  interpret h': binary_code_morphism h'
+    by fact 
+  interpret gh: two_morphisms g' h'
+    by (simp add: g'.morphism_axioms h'.morphism_axioms two_morphisms_def)
+  have "\<^bold>|g'(\<zero> \<cdot> \<one>)\<^bold>| \<noteq> \<^bold>|h'(\<zero> \<cdot> \<one>)\<^bold>|"
+  proof
+    assume len: "\<^bold>|g'(\<zero> \<cdot> \<one>)\<^bold>| = \<^bold>|h'(\<zero> \<cdot> \<one>)\<^bold>|"
+    hence eq1: "g'(\<zero> \<cdot> \<one>) = h'(\<zero> \<cdot> \<one>)" and eq2: "g' (\<one>\<^sup>@k \<cdot> \<zero> \<cdot> \<one>) = h' (\<one>\<^sup>@k \<cdot> \<zero> \<cdot> \<one>)"
+      using msol' eqd_eq[OF _ len, of "g' (\<one>\<^sup>@k \<cdot> \<zero> \<cdot> \<one>)" "h' (\<one>\<^sup>@k \<cdot> \<zero> \<cdot> \<one>) "]  
+      unfolding minsoldef pow_Suc pow_one g'.morph[symmetric] h'.morph[symmetric] rassoc
+      by blast+
+    hence "g' (\<one>\<^sup>@k) = h' (\<one>\<^sup>@k)"
+      by (simp add: g'.morph h'.morph)
+    show False
+    proof (cases "k = 0")
+      assume "k = 0"
+      from minsolD_min[OF msol' _ _ eq1, unfolded \<open>k = 0\<close> pow_one]
+      show False by simp
+    next
+      assume "k \<noteq> 0"
+      hence "g' (\<one>) = h' (\<one>)"
+        using \<open>g' (\<one>\<^sup>@k) = h' (\<one>\<^sup>@k)\<close>
+        unfolding g'.pow_morph h'.pow_morph using  pow_eq_eq by blast
+      hence "g' (\<zero>) = h' (\<zero>)" 
+        using \<open>g'(\<zero> \<cdot> \<one>) = h'(\<zero> \<cdot> \<one>)\<close> unfolding g'.morph h'.morph
+        by simp
+      show False 
+        using gh.def_on_sings_eq[OF finite_2.induct[of "\<lambda> a. g'[a] = h'[a]", OF \<open>g' (\<zero>) = h' (\<zero>)\<close> \<open>g' (\<one>) = h' (\<one>)\<close>]]
+          \<open>g' \<noteq> h'\<close> by blast
+    qed
+  qed
+  then have less': "\<^bold>|(if \<^bold>|g' (\<zero> \<cdot> \<one>)\<^bold>| < \<^bold>|h' (\<zero> \<cdot> \<one>)\<^bold>| then g' else h') (\<zero> \<cdot> \<one>)\<^bold>|
+    < \<^bold>|(if \<^bold>|g' (\<zero> \<cdot> \<one>)\<^bold>| < \<^bold>|h' (\<zero> \<cdot> \<one>)\<^bold>| then h' else g') (\<zero> \<cdot> \<one>)\<^bold>|"
+    by simp 
+  obtain g h where g_morph: "binary_code_morphism (g :: binA list \<Rightarrow> nat list)" and h_morph: "binary_code_morphism h"
+    and msol: "g (\<zero> \<cdot> \<one> \<^sup>@ Suc k \<cdot> \<zero> \<cdot> \<one>) = h (\<zero> \<cdot> \<one> \<^sup>@ Suc k \<cdot> \<zero> \<cdot> \<one>)" and less: "\<^bold>|g(\<zero> \<cdot> \<one>)\<^bold>| < \<^bold>|h(\<zero> \<cdot> \<one>)\<^bold>|"
+    using that[of "(if \<^bold>|g' (\<zero> \<cdot> \<one>)\<^bold>| < \<^bold>|h' (\<zero> \<cdot> \<one>)\<^bold>| then g' else h')" "(if \<^bold>|g' (\<zero> \<cdot> \<one>)\<^bold>| < \<^bold>|h' (\<zero> \<cdot> \<one>)\<^bold>| then h' else g')", OF _ _ _ less']
+      g'_morph h'_morph minsolD[OF msol']  by presburger  
+  interpret g: binary_code_morphism g
+    using g_morph by blast
+  interpret h: binary_code_morphism h
+    using h_morph by blast
+  have "g \<one> \<le>s g (\<zero> \<cdot> \<one>)" and "h \<one> \<le>s h (\<zero> \<cdot> \<one>)" 
+    unfolding g.morph h.morph by blast+
+  from not_bew_baiba[OF less this, of k] msol
+  have "commutes {g \<one>, g (\<zero> \<cdot> \<one>), h \<one>, h (\<zero> \<cdot> \<one>)}"
+    unfolding g.morph h.morph g.pow_morph h.pow_morph pow_Suc rassoc by blast
+  hence "g \<one> \<cdot> g (\<zero> \<cdot> \<one>) = g (\<zero> \<cdot> \<one>) \<cdot> g \<one>"
+    unfolding commutes_def by blast
+  from this[unfolded g.morph lassoc cancel_right]
+  show False
+    using g.non_comm_morph by simp
+qed
+
+end
\ No newline at end of file
diff --git a/thys/Combinatorics_Words/Lyndon_Schutzenberger.thy b/thys/Combinatorics_Words/Lyndon_Schutzenberger.thy
--- a/thys/Combinatorics_Words/Lyndon_Schutzenberger.thy
+++ b/thys/Combinatorics_Words/Lyndon_Schutzenberger.thy
@@ -1,333 +1,1201 @@
-(*  Title:      CoW/Lyndon_Schutzenberger.thy
+(*  Title:      CoW_Equations/Lyndon_Schutzenberger.thy
     Author:     Štěpán Holub, Charles University
+    Author:     Štěpán Starosta, CTU in Prague
+
+Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/
 *)
 
 theory Lyndon_Schutzenberger
-  imports CoWBasic
+  imports Submonoids Periodicity_Lemma
+
 begin
 
+text\<open>If $x^a$ or $y^b$ is sufficiently long, then the claim follows from the Periodicity Lemma.\<close>
+
+lemma LS_per_lemma_case:
+  assumes eq: "x\<^sup>@a\<cdot>y\<^sup>@b = z\<^sup>@c" and "a \<noteq> 0" and "b \<noteq> 0" and "\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>|"
+  shows "x\<cdot>y=y\<cdot>x"
+proof (cases "x = \<epsilon>")
+  assume "x = \<epsilon>"
+  thus "x\<cdot>y=y\<cdot>x" by simp 
+next 
+  assume "x \<noteq> \<epsilon>"
+  hence "z\<^sup>@c \<noteq> \<epsilon>" 
+    using eq assms emp_pow[of c] by auto
+  hence "x\<^sup>@a \<le>p (z\<^sup>@c)\<^sup>\<omega>"
+    unfolding period_root_def using 
+      pref_ext[OF triv_pref[of "x\<^sup>@a" "y\<^sup>@b", unfolded eq], of "x\<^sup>@a"] by blast 
+  have "x \<^sup>@ a \<le>p x\<^sup>\<omega>"
+    using \<open>x \<noteq> \<epsilon>\<close> \<open>a \<noteq> 0\<close> root_self[THEN per_drop_exp] by blast
+  from two_pers_root[OF per_drop_exp[OF \<open>x\<^sup>@a \<le>p (z\<^sup>@c)\<^sup>\<omega>\<close>] this \<open>\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| \<le> \<^bold>|x \<^sup>@ a\<^bold>|\<close> ]
+  have "z \<cdot> x = x \<cdot> z".
+  hence "z\<^sup>@c\<cdot>x\<^sup>@a = x\<^sup>@a\<cdot>z\<^sup>@c"
+    by (simp add: comm_add_exps)
+  from this[folded eq, unfolded rassoc cancel, symmetric]
+  have "x\<^sup>@a \<cdot> y\<^sup>@b = y\<^sup>@b \<cdot> x\<^sup>@a".
+  from this[unfolded comm_pow_roots[OF \<open>a \<noteq> 0\<close> \<open>b \<noteq> 0\<close>]]
+  show "x \<cdot> y = y \<cdot> x".
+qed
+
 chapter \<open>Lyndon-Schützenberger Equation\<close>
 
+section \<open>The original result\<close>
+
 text\<open>The Lyndon-Schützenberger equation is the following equation on words:
 \[
 x^ay^b = z^c,
 \]
 in this formalization denoted as @{term "x\<^sup>@a\<cdot>y\<^sup>@b = z\<^sup>@c"}, with $2 \leq a,b,c$.
-We formalize here a proof that the equation has periodic solutions only in free monoids, that is, that any three words
+We formalize here a proof that the equation has periodic solutions only in free monoids, that is, that any three words 
 $x$, $y$ and $z$ satisfying the equality pairwise commute.
 The result was first proved in @{cite LySch62} in a more general setting of free groups.
 There are several proofs to be found in the literature (for instance @{cite Lo83 and Dmsi2006}).
 The presented proof is the author's proof.
 \<close>
 
 text\<open>We set up a locale representing the Lyndon-Schützenberger Equation.\<close>
 
-locale LS =
-  fixes x a y b z c
-  assumes a:  "2 \<le> a" and b: "2 \<le> b" and c: "2 \<le> c"   and eq: "x\<^sup>@a \<cdot> y\<^sup>@b = z\<^sup>@c"
-begin
-
-lemma a0: "a \<noteq> 0" and b0: "b \<noteq> 0"
-      using a b by auto
-
-text\<open>If $x^a$ or $y^b$ is sufficiently long, then the calim follows from the Periodicity Lemma.\<close>
-
-lemma per_lemma_case:
-  assumes "\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>|"
-  shows "x\<cdot>y=y\<cdot>x"
-proof (cases "x = \<epsilon>")
-  assume "x = \<epsilon>"
-  thus "x\<cdot>y=y\<cdot>x" by simp
-next
-  assume "x \<noteq> \<epsilon>"
-  hence "z\<^sup>@c \<noteq> \<epsilon>"
-    using eq assms emp_pow[of c] by auto
-  hence "x\<^sup>@a \<le>p (z\<^sup>@c)\<^sup>\<omega>"
-    unfolding period_root_def using
-    pref_ext[OF triv_pref[of "x\<^sup>@a" "y\<^sup>@b", unfolded eq], of "x\<^sup>@a"] by blast
-  have "x \<^sup>@ a \<le>p x\<^sup>\<omega>"
-    using \<open>x \<noteq> \<epsilon>\<close> a0 root_self[THEN per_drop_exp] by blast
-  from two_pers[OF per_drop_exp[OF \<open>x\<^sup>@a \<le>p (z\<^sup>@c)\<^sup>\<omega>\<close>] this assms]
-  have "z \<cdot> x = x \<cdot> z".
-  hence "z\<^sup>@c\<cdot>x\<^sup>@a = x\<^sup>@a\<cdot>z\<^sup>@c"
-    by (simp add: comm_add_exps)
-  from this[folded eq, unfolded rassoc cancel, symmetric]
-  have "x\<^sup>@a \<cdot> y\<^sup>@b = y\<^sup>@b \<cdot> x\<^sup>@a".
-  from this[unfolded comm_pow_roots[OF a0 b0]]
-  show "x \<cdot> y = y \<cdot> x".
-qed
 
 text\<open>The most challenging case is when $c = 3$.\<close>
 
-lemma core_case:
-  assumes
-    "c = 3" and
-    "b*\<^bold>|y\<^bold>| \<le> a*\<^bold>|x\<^bold>|" and "x \<noteq> \<epsilon>" and "y \<noteq> \<epsilon>" and
+lemma LS_core_case:
+  assumes 
+    eq: "x\<^sup>@a \<cdot> y\<^sup>@b = z\<^sup>@c" and
+    "2 \<le> a" and "2 \<le> b" and "2 \<le> c" and
+    "c = 3" and 
+    "b*\<^bold>|y\<^bold>| \<le> a*\<^bold>|x\<^bold>|" and "x \<noteq> \<epsilon>" and "y \<noteq> \<epsilon>" and 
     lenx: "a*\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|x\<^bold>|" and
     leny: "b*\<^bold>|y\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|y\<^bold>|"
-  shows "x\<cdot>y = y\<cdot>x"
-proof-
-  have "a \<noteq> 0" and "b \<noteq> 0"
-      using a b by auto
+  shows "x\<cdot>y = y\<cdot>x" 
+proof- 
+  have "a \<noteq> 0" and "b \<noteq> 0"  
+    using \<open>2 \<le> a\<close> \<open>2 \<le> b\<close> by auto
 
-  \<comment>\<open>We first show that a = 2\<close>
+\<comment>\<open>We first show that a = 2\<close>
   have "a*\<^bold>|x\<^bold>|+b*\<^bold>|y\<^bold>| = 3*\<^bold>|z\<^bold>|"
-    using \<open>c = 3\<close> eq length_append[of "x\<^sup>@a" "y\<^sup>@b"]
+    using \<open>c = 3\<close> eq lenmorph[of "x\<^sup>@a" "y\<^sup>@b"]
     by (simp add: pow_len)
   hence "3*\<^bold>|z\<^bold>| \<le> a*\<^bold>|x\<^bold>| + a*\<^bold>|x\<^bold>|"
     using \<open>b*\<^bold>|y\<^bold>| \<le> a*\<^bold>|x\<^bold>|\<close>  by simp
   hence "3*\<^bold>|z\<^bold>| < 2*\<^bold>|z\<^bold>| + 2*\<^bold>|x\<^bold>|"
     using lenx by linarith
   hence "\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| < 3 * \<^bold>|x\<^bold>|" by simp
   from less_trans[OF lenx this, unfolded mult_less_cancel2]
-  have "a = 2" using a by force
+  have "a = 2" using \<open>2 \<le> a\<close> by force
 
-  hence "\<^bold>|y\<^bold>| \<le> \<^bold>|x\<^bold>|" using \<open>b*\<^bold>|y\<^bold>| \<le> a*\<^bold>|x\<^bold>|\<close> b
-      pow_len[of x 2]  pow_len[of y b] mult_le_less_imp_less[of a b "\<^bold>|x\<^bold>|" "\<^bold>|y\<^bold>|"] not_le
+  hence "\<^bold>|y\<^bold>| \<le> \<^bold>|x\<^bold>|" using \<open>b*\<^bold>|y\<^bold>| \<le> a*\<^bold>|x\<^bold>|\<close> \<open>2 \<le> b\<close> 
+      pow_len[of x 2]  pow_len[of y b]
+      mult_le_less_imp_less[of a b "\<^bold>|x\<^bold>|" "\<^bold>|y\<^bold>|"] not_le
     by auto
-  have "x\<cdot>x\<cdot>y\<^sup>@b = z\<cdot>z\<cdot>z" using a eq \<open>c=3\<close> \<open>a=2\<close>
-    by (simp add: numeral_2_eq_2 numeral_3_eq_3)
+  have "x\<cdot>x\<cdot>y\<^sup>@b = z\<cdot>z\<cdot>z" using \<open>2 \<le> a\<close> eq \<open>c=3\<close> \<open>a=2\<close>
+    by (simp add: numeral_2_eq_2 numeral_3_eq_3) 
 
 \<comment> \<open>Find words u, v, w\<close>
   have "\<^bold>|z\<^bold>| < \<^bold>|x\<cdot>x\<^bold>|"
-    using \<open>\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| < 3 * \<^bold>|x\<^bold>|\<close> add.commute by auto
+    using \<open>\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| < 3 * \<^bold>|x\<^bold>|\<close> add.commute by auto 
   from ruler_le[THEN prefD, OF triv_pref[of z "z\<cdot>z"] _ less_imp_le[OF this]]
-  obtain w  where "z\<cdot>w = x\<cdot>x"
-    using prefI[of "x\<cdot>x" "y\<^sup>@b" "z\<cdot>z\<cdot>z", unfolded rassoc, OF \<open>x\<cdot>x\<cdot>y\<^sup>@b = z\<cdot>z\<cdot>z\<close>] by fastforce
+  obtain w  where "z\<cdot>w = x\<cdot>x" 
+    using prefI[of "x\<cdot>x" "y\<^sup>@b" "z\<cdot>z\<cdot>z", unfolded rassoc, OF \<open>x\<cdot>x\<cdot>y\<^sup>@b = z\<cdot>z\<cdot>z\<close>] by fastforce  
 
   have "\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|"
     using \<open>a = 2\<close> lenx by auto
   from ruler_le[THEN prefD, OF _ _ less_imp_le[OF this], of "x\<cdot>x\<cdot>y\<^sup>@b", OF triv_pref, unfolded \<open>x\<cdot>x\<cdot>y\<^sup>@b = z\<cdot>z\<cdot>z\<close>, OF triv_pref]
-  obtain u :: "'a list" where "x\<cdot>u=z"
+  obtain u :: "'a list" where "x\<cdot>u=z" 
     by blast
   have "u \<noteq> \<epsilon>"
-    using \<open>\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|\<close> \<open>x\<cdot>u = z\<close> by auto
+    using \<open>\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|\<close> \<open>x\<cdot>u = z\<close> by auto 
   have "x = u\<cdot>w" using  \<open>z\<cdot>w = x\<cdot>x\<close> \<open>x\<cdot>u = z\<close> by auto
 
   have "\<^bold>|x\<cdot>x\<^bold>| < \<^bold>|z\<cdot>z\<^bold>|"  by (simp add: \<open>\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|\<close> add_less_mono)
   from ruler_le[OF triv_pref[of "x\<cdot>x" "y\<^sup>@b", unfolded  rassoc \<open>x\<cdot>x\<cdot>y\<^sup>@b = z\<cdot>z\<cdot>z\<close>, unfolded lassoc] triv_pref, OF less_imp_le[OF this]]
   have "z\<cdot>w \<le>p z\<cdot>z"
     unfolding \<open>z\<cdot>w = x\<cdot>x\<close>.
   obtain v :: "'a list" where "w \<cdot> v = x"
-    using lq_pref[of w x]
-   pref_prod_pref'[OF pref_cancel[OF \<open>z\<cdot>w \<le>p z\<cdot>z\<close>, folded \<open>x \<cdot> u = z\<close>, unfolded \<open>x = u \<cdot> w\<close> rassoc], folded  \<open>x = u \<cdot> w\<close>] by blast
+    using lq_pref[of w x] 
+      pref_prod_pref'[OF pref_cancel[OF \<open>z\<cdot>w \<le>p z\<cdot>z\<close>, folded \<open>x \<cdot> u = z\<close>, unfolded \<open>x = u \<cdot> w\<close> rassoc], folded  \<open>x = u \<cdot> w\<close>] by blast  
   have "u\<cdot>w\<cdot>v \<noteq> \<epsilon>"
     by (simp add: \<open>u \<noteq> \<epsilon>\<close>)
 
 \<comment> \<open>Express x, y and z in terms of  u, v and w\<close>
   hence "z = w\<cdot>v\<cdot>u"
     using \<open>w \<cdot> v = x\<close> \<open>x \<cdot> u = z\<close> by auto
   from \<open>x \<cdot> x \<cdot> y\<^sup>@b = z \<cdot> z \<cdot> z\<close>[unfolded this lassoc, folded \<open>z \<cdot> w = x \<cdot> x\<close>, unfolded this rassoc]
   have "w\<cdot>v \<cdot> u\<cdot>w \<cdot> y\<^sup>@b = w\<cdot>v\<cdot>u\<cdot>w\<cdot>v\<cdot>u\<cdot>w\<cdot>v\<cdot>u".
   hence "y\<^sup>@b = v\<cdot>u\<cdot>w\<cdot>v\<cdot>u"
     using pref_cancel by auto
 
 \<comment> \<open>Double period of uwv\<close>
-  from periodN_fac[OF _ \<open>u\<cdot>w\<cdot>v \<noteq> \<epsilon>\<close>, of v u "\<^bold>|y\<^bold>|", unfolded rassoc, folded this]
-  have "periodN (u\<cdot>w\<cdot>v) \<^bold>|y\<^bold>|"
-    using pow_per[OF \<open>y \<noteq> \<epsilon>\<close> b0] by blast
+  from period_fac[OF _ \<open>u\<cdot>w\<cdot>v \<noteq> \<epsilon>\<close>, of v u "\<^bold>|y\<^bold>|", unfolded rassoc, folded this]
+  have "period (u\<cdot>w\<cdot>v) \<^bold>|y\<^bold>|"
+    using pow_per[OF \<open>y \<noteq> \<epsilon>\<close> \<open>b \<noteq> 0\<close>] by blast
   have "u\<cdot>w\<cdot>v = x \<cdot>v"
-    by (simp add: \<open>x = u \<cdot> w\<close>)
+    by (simp add: \<open>x = u \<cdot> w\<close>) 
   have "u\<cdot>w\<cdot>v = u\<cdot> x"
     by (simp add: \<open>w \<cdot> v = x\<close>)
   have "u\<cdot>w\<cdot>v \<le>p u\<^sup>\<omega>"
     unfolding period_root_def
     using \<open>u \<cdot> w \<cdot> v = u \<cdot> x\<close>[unfolded \<open>x = u \<cdot> w\<close>] \<open>u \<noteq> \<epsilon>\<close> triv_pref[of "u \<cdot> u \<cdot> w" v]
     by force
-  have "periodN (u\<cdot>w\<cdot>v) \<^bold>|u\<^bold>|"
+  have "period (u\<cdot>w\<cdot>v) \<^bold>|u\<^bold>|"
     using \<open>u \<cdot> w \<cdot> v \<le>p u \<^sup>\<omega>\<close> by auto
 
 \<comment> \<open>Common period d\<close>
   obtain d::nat where "d=gcd \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|"
     by simp
-  have "\<^bold>|y\<^bold>| + \<^bold>|u\<^bold>| \<le> \<^bold>|u\<cdot>w\<cdot>v\<^bold>|" using \<open>\<^bold>|y\<^bold>| \<le> \<^bold>|x\<^bold>|\<close> length_append \<open>u\<cdot>w\<cdot>v = u\<cdot> x\<close>
+  have "\<^bold>|y\<^bold>| + \<^bold>|u\<^bold>| \<le> \<^bold>|u\<cdot>w\<cdot>v\<^bold>|" using \<open>\<^bold>|y\<^bold>| \<le> \<^bold>|x\<^bold>|\<close> lenmorph \<open>u\<cdot>w\<cdot>v = u\<cdot> x\<close>
     by simp
-  hence "periodN (u\<cdot>w\<cdot>v) d"
-    using \<open>periodN (u \<cdot> w \<cdot> v) \<^bold>|u\<^bold>|\<close> \<open>periodN (u \<cdot> w \<cdot> v) \<^bold>|y\<^bold>|\<close> \<open>d = gcd \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|\<close> two_periodsN
+  hence "period (u\<cdot>w\<cdot>v) d" 
+    using \<open>period (u \<cdot> w \<cdot> v) \<^bold>|u\<^bold>|\<close> \<open>period (u \<cdot> w \<cdot> v) \<^bold>|y\<^bold>|\<close> \<open>d = gcd \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|\<close> two_periods
     by blast
 
 \<comment> \<open>Divisibility\<close>
   have "v\<cdot>u\<cdot>z=y\<^sup>@b"
     by (simp add: \<open>y\<^sup>@b = v \<cdot> u \<cdot> w \<cdot> v \<cdot> u\<close> \<open>z = w \<cdot> v \<cdot> u\<close>)
   have "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|"
-    using \<open>x = u \<cdot> w\<close> \<open>w \<cdot> v = x\<close> length_append[of u w] length_append[of w v] add.commute[of "\<^bold>|u\<^bold>|" "\<^bold>|w\<^bold>|"] add_left_cancel
+    using \<open>x = u \<cdot> w\<close> \<open>w \<cdot> v = x\<close> lenmorph[of u w] lenmorph[of w v] add.commute[of "\<^bold>|u\<^bold>|" "\<^bold>|w\<^bold>|"] add_left_cancel
     by simp
   hence "d dvd \<^bold>|v\<^bold>|" using gcd_nat.cobounded1[of "\<^bold>|v\<^bold>|" "\<^bold>|y\<^bold>|"] gcd.commute[of "\<^bold>|y\<^bold>|" "\<^bold>|u\<^bold>|"]
     by (simp add: \<open>d = gcd \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|\<close>)
   have "d dvd \<^bold>|u\<^bold>|"
     by (simp add: \<open>d = gcd  \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|\<close>)
   have "\<^bold>|z\<^bold>| + \<^bold>|u\<^bold>| + \<^bold>|v\<^bold>| = b*\<^bold>|y\<^bold>|"
-    using  lenarg[OF \<open>v\<cdot>u\<cdot>z=y\<^sup>@b\<close>, unfolded length_append pow_len] by auto
+    using  lenarg[OF \<open>v\<cdot>u\<cdot>z=y\<^sup>@b\<close>, unfolded lenmorph pow_len] by auto
   from dvd_add_left_iff[OF \<open>d dvd \<^bold>|v\<^bold>|\<close>, of "\<^bold>|z\<^bold>|+\<^bold>|u\<^bold>|", unfolded this dvd_add_left_iff[OF \<open>d dvd \<^bold>|u\<^bold>|\<close>, of "\<^bold>|z\<^bold>|"]]
-  have "d dvd \<^bold>|z\<^bold>|"
-    using \<open>d = gcd  \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|\<close> dvd_mult by blast
-  from lenarg[OF \<open>z = w \<cdot> v \<cdot> u\<close>, unfolded length_append pow_len]
+  have "d dvd \<^bold>|z\<^bold>|" 
+    using \<open>d = gcd  \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|\<close> dvd_mult by blast 
+  from lenarg[OF \<open>z = w \<cdot> v \<cdot> u\<close>, unfolded lenmorph pow_len]
   have "d dvd \<^bold>|w\<^bold>|"
     using \<open>d dvd \<^bold>|z\<^bold>|\<close>  \<open>d dvd \<^bold>|u\<^bold>|\<close> \<open>d dvd \<^bold>|v\<^bold>|\<close>  by (simp add: dvd_add_left_iff)
   hence "d dvd \<^bold>|x\<^bold>|"
     using \<open>d dvd \<^bold>|v\<^bold>|\<close> \<open>w \<cdot> v = x\<close> by force
 
 \<comment> \<open>x and y commute\<close>
   have "x \<le>p u\<cdot>w\<cdot>v"
-    by (simp add: \<open>x = u \<cdot> w\<close>)
-  have "periodN x d" using per_pref'[OF \<open>x\<noteq>\<epsilon>\<close>  \<open>periodN (u\<cdot>w\<cdot>v) d \<close> \<open>x \<le>p u \<cdot>w\<cdot>v\<close>].
+    by (simp add: \<open>x = u \<cdot> w\<close>)   
+  have "period x d" using per_pref'[OF \<open>x\<noteq>\<epsilon>\<close>  \<open>period (u\<cdot>w\<cdot>v) d \<close> \<open>x \<le>p u \<cdot>w\<cdot>v\<close>].
   hence "x \<in> (take d x)*"
     using \<open>d dvd \<^bold>|x\<^bold>|\<close>
-    using root_divisor by blast
+    using root_divisor by blast 
 
-  hence "periodN u d " using \<open>x = u \<cdot> w\<close> per_pref'
-    using \<open>periodN x d\<close> \<open>u \<noteq> \<epsilon>\<close> by blast
+  hence "period u d " using \<open>x = u \<cdot> w\<close> per_pref'
+    using \<open>period x d\<close> \<open>u \<noteq> \<epsilon>\<close> by blast
   have " take d x = take d u" using \<open>u\<noteq>\<epsilon>\<close>  \<open>x = u \<cdot> w\<close> pref_share_take
     by (simp add: \<open>d = gcd  \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|\<close>)
-  from root_divisor[OF \<open>periodN u d\<close> \<open>d dvd \<^bold>|u\<^bold>|\<close>, folded this]
+  from root_divisor[OF \<open>period u d\<close> \<open>d dvd \<^bold>|u\<^bold>|\<close>, folded this]
   have "u \<in> (take d x)*".
 
 
-  hence "z \<in> (take d x)*"
+  hence "z \<in> (take d x)*" 
     using \<open>x\<cdot>u=z\<close> \<open>x \<in> (take d x)*\<close> add_roots by blast
-  from root_pref_cancel'[OF _ root_pow_root[OF  \<open>x \<in> take d x*\<close>, of a],of "y\<^sup>@b", unfolded eq, OF root_pow_root[OF  this, of c]]
-  have "y\<^sup>@b \<in> (take d x)*".
-  from  commD[OF root_pow_root[OF  \<open>x \<in> take d x*\<close>, of a] this]
-  show "x \<cdot> y = y \<cdot> x"
+  from root_pref_cancel[OF _ root_pow_root[OF  \<open>x \<in> take d x*\<close>, of a],of "y\<^sup>@b", unfolded eq, OF root_pow_root[OF  this, of c]]
+  have "y\<^sup>@b \<in> (take d x)*". 
+  from  comm_rootI[OF root_pow_root[OF  \<open>x \<in> take d x*\<close>, of a] this] 
+  show "x \<cdot> y = y \<cdot> x" 
     unfolding comm_pow_roots[OF \<open>a \<noteq> 0\<close> \<open>b \<noteq> 0\<close>, of x y].
 qed
 
-end \<comment> \<open>locale LS\<close>
 
-text\<open>The main proof is by induction on the length of $z$. It also uses the reverse symmetry of the equation which is
-exploited by two interpretations of the locale @{term LS}. Note also that the case $|x^a| < |y^b|$ is solved by
+text\<open>The main proof is by induction on the length of $z$. It also uses the reverse symmetry of the equation which is 
+exploited by two interpretations of the locale @{term LS}. Note also that the case $|x^a| < |y^b|$ is solved by 
 using induction on $|z| + |y^b|$ instead of just on $|z|$.
 \<close>
 
 lemma Lyndon_Schutzenberger':
   "\<lbrakk> x\<^sup>@a\<cdot>y\<^sup>@b = z\<^sup>@c;  2 \<le> a;  2 \<le> b; 2 \<le> c \<rbrakk>
   \<Longrightarrow> x\<cdot>y = y\<cdot>x"
 proof (induction "\<^bold>|z\<^bold>| + b* \<^bold>|y\<^bold>|" arbitrary: x y z a b c  rule: less_induct)
   case less
 
-  interpret LS x a y b z c using \<open> x\<^sup>@a\<cdot>y\<^sup>@b = z\<^sup>@c\<close> \<open> 2 \<le>a \<close> \<open> 2 \<le> b\<close> \<open> 2 \<le> c\<close>
-    by (simp add: LS.intro)
-  interpret LSrev: LS "rev y" b "rev x" a "rev z" c
-        using  LS.intro[OF b a c, of "rev y" "rev x" "rev z", folded rev_append rev_pow, unfolded rev_is_rev_conv, OF \<open>x\<^sup>@a \<cdot> y\<^sup>@b = z\<^sup>@c\<close>].
+  have "a \<noteq> 0" and "b \<noteq> 0"
+    using \<open>2 \<le> a\<close> \<open>2 \<le> b\<close> by auto
+
+  have LSrev_eq: "rev y \<^sup>@ b \<cdot> rev x \<^sup>@ a = rev z \<^sup>@ c"
+    using \<open>x\<^sup>@a\<cdot>y\<^sup>@b = z\<^sup>@c\<close> 
+    unfolding rev_append[symmetric] rev_pow[symmetric]
+    by blast
 
   have leneq: "a * \<^bold>|x\<^bold>| + b*\<^bold>|y\<^bold>| = c * \<^bold>|z\<^bold>|"
-    using  eq unfolding pow_len[symmetric] length_append[symmetric] by simp
-  have "a \<noteq> 0" and "b \<noteq> 0"
-    using a b by auto
+    using lenarg[OF \<open>x\<^sup>@a\<cdot>y\<^sup>@b = z\<^sup>@c\<close>] unfolding pow_len lenmorph.
 
   show "x \<cdot> y = y \<cdot> x"
-  proof (cases "x = \<epsilon> \<or> y = \<epsilon>")
-    show "x = \<epsilon> \<or> y = \<epsilon> \<Longrightarrow> x \<cdot> y = y \<cdot> x"
-      by auto
-  next
-    assume "\<not> (x = \<epsilon> \<or> y = \<epsilon>)" hence "x \<noteq> \<epsilon>" and "y \<noteq> \<epsilon>" by blast+
+  proof
+    assume "x \<noteq> \<epsilon>" and "y \<noteq> \<epsilon>"
     show "x \<cdot> y = y \<cdot> x"
     proof (cases "\<^bold>|x \<^sup>@ a\<^bold>| < \<^bold>|y \<^sup>@ b\<^bold>|")
 
 \<comment> \<open>WLOG assumption\<close>
       assume "\<^bold>|x\<^sup>@a\<^bold>| < \<^bold>|y\<^sup>@b\<^bold>|"
       have "\<^bold>|rev z\<^bold>| + a* \<^bold>|rev x\<^bold>| < \<^bold>|z\<^bold>| + b* \<^bold>|y\<^bold>|" using \<open>\<^bold>|x\<^sup>@a\<^bold>| < \<^bold>|y\<^sup>@b\<^bold>|\<close>
         by (simp add: pow_len)
-      from "less.hyps"[OF this LSrev.eq b a c, symmetric]
+      from "less.hyps"[OF this LSrev_eq \<open>2 \<le> b\<close> \<open>2 \<le> a\<close> \<open>2 \<le> c\<close>, symmetric]
       show "x \<cdot> y = y \<cdot> x"
-        unfolding  rev_append[symmetric] rev_is_rev_conv by simp
+        unfolding rev_append[symmetric] rev_is_rev_conv by simp 
     next
       assume " \<not> \<^bold>|x\<^sup>@a\<^bold>| < \<^bold>|y\<^sup>@b\<^bold>|" hence "\<^bold>|y\<^sup>@b\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>|" by force
           \<comment> \<open>case solved by the Periodicity lemma\<close>
+      note minus =  Suc_minus2[OF \<open>2 \<le> a\<close>] Suc_minus2[OF \<open>2 \<le> b\<close>] 
       consider (with_Periodicity_lemma)
-        "\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| \<le> \<^bold>|x \<^sup>@ a\<^bold>| \<or> \<^bold>|z\<^bold>| + \<^bold>|y\<^bold>| \<le> \<^bold>|y \<^sup>@ b\<^bold>|" |
-        (without_Periodicity_lemma)
-        "\<^bold>|x\<^sup>@a\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|x\<^bold>|" and "\<^bold>|y\<^sup>@b\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|y\<^bold>|"
-        using not_le_imp_less by blast
+        "\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| \<le> \<^bold>|x \<^sup>@ Suc(Suc (a-2))\<^bold>| \<or> \<^bold>|z\<^bold>| + \<^bold>|y\<^bold>| \<le> \<^bold>|y \<^sup>@ Suc(Suc (b-2))\<^bold>|" |
+        (without_Periodicity_lemma)    
+        "\<^bold>|x\<^sup>@Suc(Suc (a-2))\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|x\<^bold>|" and "\<^bold>|y\<^sup>@Suc(Suc (b-2))\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|y\<^bold>|"
+        unfolding minus
+        using not_le_imp_less by blast 
       thus "x \<cdot> y = y \<cdot> x"
       proof (cases)
         case with_Periodicity_lemma
-        assume short: "\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>| \<or> \<^bold>|z\<^bold>| + \<^bold>|y\<^bold>| \<le> \<^bold>|y\<^sup>@b\<^bold>|"
         have "x = \<epsilon> \<or> rev y = \<epsilon> \<Longrightarrow> x \<cdot> y = y \<cdot> x"
           by auto
         thus "x \<cdot> y = y \<cdot> x"
-          using per_lemma_case LSrev.per_lemma_case short
-          unfolding length_rev rev_append[symmetric] rev_is_rev_conv rev_pow[symmetric] by blast
+          using LS_per_lemma_case[OF \<open>x\<^sup>@a\<cdot>y\<^sup>@b = z\<^sup>@c\<close> \<open>a \<noteq> 0\<close> \<open>b \<noteq> 0\<close>]
+            LS_per_lemma_case[OF LSrev_eq \<open>b \<noteq> 0\<close> \<open>a \<noteq> 0\<close>] with_Periodicity_lemma[unfolded minus]
+          unfolding length_rev rev_append[symmetric] rev_is_rev_conv rev_pow[symmetric]
+          by linarith
       next
         case without_Periodicity_lemma
-        assume lenx: "\<^bold>|x\<^sup>@a\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|x\<^bold>|" and leny: "\<^bold>|y\<^sup>@b\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|y\<^bold>|"
-        have ex: "\<exists> k. d = Suc (Suc k)" if "2 \<le> d" for d
-          using nat_le_iff_add that by auto
-        have "a * \<^bold>|x\<^bold>| + b*\<^bold>|y\<^bold>| < 4 * \<^bold>|z\<^bold>|"
-          using ex[OF \<open>2 \<le> a\<close>] ex[OF \<open>2 \<le> b\<close>] lenx leny unfolding pow_len by auto
-        hence "c < 4" using leneq by auto
+        assume lenx: "\<^bold>|x\<^sup>@Suc (Suc (a-2))\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|x\<^bold>|" and leny: "\<^bold>|y\<^sup>@Suc (Suc (b-2))\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|y\<^bold>|"
+        have "Suc (Suc (a-2)) * \<^bold>|x\<^bold>| + Suc (Suc (b-2))*\<^bold>|y\<^bold>| < 4 * \<^bold>|z\<^bold>|" 
+          using  lenx leny unfolding pow_len by fastforce
+        hence "c < 4" using leneq unfolding minus  by auto
         consider (c_is_3) "c = 3" | (c_is_2) "c = 2"
-          using \<open>c < 4\<close> c by linarith
+          using \<open>c < 4\<close> \<open>2 \<le> c\<close> by linarith
         then show "x \<cdot> y = y \<cdot> x"
         proof(cases)
-          case c_is_3
-          show "x \<cdot> y = y \<cdot> x"
-            using
-              core_case[OF \<open>c = 3\<close> \<open>\<^bold>|y\<^sup>@b\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>|\<close>[unfolded pow_len] _ _ lenx[unfolded pow_len] leny[unfolded pow_len]]
-              \<open>x \<noteq> \<epsilon>\<close> \<open>y \<noteq> \<epsilon>\<close>
+          case c_is_3 
+          show "x \<cdot> y = y \<cdot> x" 
+            using  
+              LS_core_case[OF \<open>x\<^sup>@a\<cdot>y\<^sup>@b = z\<^sup>@c\<close> \<open>2 \<le> a\<close> \<open>2 \<le> b\<close> \<open>2 \<le> c\<close> \<open>c = 3\<close> \<open>\<^bold>|y\<^sup>@b\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>|\<close>[unfolded pow_len]
+                _ _ lenx[unfolded pow_len minus] leny[unfolded pow_len minus]] 
+              \<open>x \<noteq> \<epsilon>\<close> \<open>y \<noteq> \<epsilon>\<close> 
             by blast
-        next
-          assume "c = 2"
+        next  
+          assume "c = 2"  
           hence eq2: "x\<^sup>@a \<cdot> y\<^sup>@b = z \<cdot> z"
-            by (simp add: eq pow2_list)
-          from   dual_order.trans  le_cases[of "\<^bold>|x\<^sup>@a\<^bold>|" "\<^bold>|z\<^bold>|" "\<^bold>|z\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>|", unfolded eq_len_iff[OF this]]
-          have "\<^bold>|z\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>|"
-            using \<open>\<^bold>|y\<^sup>@b\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>|\<close> by blast
+            by (simp add: \<open>x\<^sup>@a\<cdot>y\<^sup>@b = z\<^sup>@c\<close>)
+          from dual_order.trans  le_cases[of "\<^bold>|x\<^sup>@a\<^bold>|" "\<^bold>|z\<^bold>|" "\<^bold>|z\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>|", unfolded eq_len_iff[OF this]] 
+          have "\<^bold>|z\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>|" 
+            using \<open>\<^bold>|y\<^sup>@b\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>|\<close> by blast 
           obtain a' where "Suc a' = a" and "1 \<le> a'"
-            using \<open>2 \<le> a\<close> ex by auto
-          from eq2[folded \<open>Suc a' = a\<close>, unfolded pow_Suc2_list rassoc]  pow_Suc2_list[of x a', unfolded this, symmetric]
+            using \<open>2 \<le> a\<close> minus by auto
+          from eq2[folded \<open>Suc a' = a\<close>, unfolded pow_Suc2 rassoc]  pow_Suc2[of x a', unfolded this, symmetric]
           have eq3: "x \<^sup>@ a' \<cdot> x \<cdot> y \<^sup>@ b = z \<cdot> z" and aa':"x \<^sup>@ a' \<cdot> x = x \<^sup>@ a ".
-          hence "\<^bold>|x\<^sup>@a'\<^bold>| < \<^bold>|z\<^bold>|"
-            using \<open>Suc a' = a\<close> lenx pow_len by auto
-          hence "\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|"
-            using  mult_le_mono[of 1 a' "\<^bold>|z\<^bold>|" "\<^bold>|x\<^bold>|", OF \<open>1 \<le> a'\<close>, THEN leD] unfolding pow_len
+          hence "\<^bold>|x\<^sup>@a'\<^bold>| < \<^bold>|z\<^bold>|" 
+            using \<open>Suc a' = a\<close> lenx unfolding  pow_len minus by fastforce 
+          hence "\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|"  
+            using  mult_le_mono[of 1 a' "\<^bold>|z\<^bold>|" "\<^bold>|x\<^bold>|", OF \<open>1 \<le> a'\<close>, THEN leD] unfolding pow_len  
             by linarith
           obtain u w where "x\<^sup>@a'\<cdot>u = z" and "w \<cdot> y\<^sup>@b = z"
-            using eqd_prefE[OF eq3[unfolded rassoc] less_imp_le[OF \<open>\<^bold>|x\<^sup>@a'\<^bold>| < \<^bold>|z\<^bold>|\<close>], of thesis]
-              eqd_prefE[OF eq2[symmetric]  \<open>\<^bold>|z\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>|\<close>, of thesis] by fast
+            using eqdE[OF eq3[unfolded rassoc] less_imp_le[OF \<open>\<^bold>|x\<^sup>@a'\<^bold>| < \<^bold>|z\<^bold>|\<close>], of thesis]
+              eqdE[OF eq2[symmetric]  \<open>\<^bold>|z\<^bold>| \<le> \<^bold>|x\<^sup>@a\<^bold>|\<close>, of thesis] by fast
 
           have "x\<^sup>@a'\<cdot>x\<cdot>y\<^sup>@b = x\<^sup>@a'\<cdot>u\<cdot>w\<cdot>y\<^sup>@b"
-           unfolding lassoc  \<open>x \<^sup>@ a' \<cdot> u = z\<close> \<open>w \<cdot> y\<^sup>@b = z\<close> aa' cancel eq2 by simp
+            unfolding lassoc  \<open>x \<^sup>@ a' \<cdot> u = z\<close> \<open>w \<cdot> y\<^sup>@b = z\<close> aa' eq2 cancel..
           hence "u\<cdot>w=x"
             by auto
           hence "\<^bold>|w\<cdot>u\<^bold>| = \<^bold>|x\<^bold>|"
             using swap_len by blast
 
 \<comment> \<open>Induction step: new equation with shorter z\<close>
           have "w\<^sup>@2\<cdot>y\<^sup>@b = (w\<cdot>u)\<^sup>@a"
-            unfolding pow2_list using \<open>w \<cdot> y \<^sup>@ b = z\<close> \<open>x \<^sup>@ a' \<cdot> u = z\<close> \<open>u\<cdot>w=x\<close> pow_slide[of w u a', unfolded \<open>Suc a' = a\<close>] by simp
-          from "less.hyps"[OF _ this _ b a, unfolded \<open>\<^bold>|w\<cdot>u\<^bold>| = \<^bold>|x\<^bold>|\<close>]
-          have "y\<cdot>w = w\<cdot>y"
+            unfolding pow_two using \<open>w \<cdot> y \<^sup>@ b = z\<close> \<open>x \<^sup>@ a' \<cdot> u = z\<close> \<open>u\<cdot>w=x\<close> pow_slide[of w u a', unfolded \<open>Suc a' = a\<close>] by simp
+          from "less.hyps"[OF _ this _ \<open>2 \<le> b\<close> \<open>2 \<le> a\<close>, unfolded \<open>\<^bold>|w\<cdot>u\<^bold>| = \<^bold>|x\<^bold>|\<close>]
+          have "y\<cdot>w = w\<cdot>y" 
             using  \<open>\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|\<close>  by force
 
           have "y \<cdot> z = z \<cdot> y"
             unfolding \<open>w \<cdot> y\<^sup>@b = z\<close>[symmetric] lassoc \<open>y\<cdot>w = w\<cdot>y\<close>
-            by (simp add: pow_commutes_list)
+            by (simp add: pow_comm)   
           hence "z\<^sup>@c\<cdot>y\<^sup>@b = y\<^sup>@b\<cdot>z\<^sup>@c"
-            by (simp add: comm_add_exps)
-          from this[folded eq, unfolded lassoc]
+            by (simp add: comm_add_exps) 
+          from this[folded \<open>x\<^sup>@a\<cdot>y\<^sup>@b = z\<^sup>@c\<close>, unfolded lassoc]
           have "x\<^sup>@a\<cdot>y\<^sup>@b = y\<^sup>@b\<cdot>x\<^sup>@a"
             using cancel_right by blast
-          from this[unfolded comm_pow_roots[OF \<open>a\<noteq>0\<close> \<open>b \<noteq> 0\<close>]]
+          from this[unfolded comm_pow_roots[OF \<open>a \<noteq> 0\<close> \<open>b \<noteq> 0\<close>]]
           show "x \<cdot> y = y \<cdot> x".
         qed
       qed
     qed
   qed
 qed
 
 theorem Lyndon_Schutzenberger:
   assumes "x\<^sup>@a\<cdot>y\<^sup>@b = z\<^sup>@c" and  "2 \<le> a"  and "2 \<le> b" and "2 \<le> c"
   shows  "x\<cdot>y = y\<cdot>x" and "x\<cdot>z = z\<cdot>x" and "y\<cdot>z = z\<cdot>y"
 proof-
   show "x \<cdot> y = y \<cdot> x"
     using Lyndon_Schutzenberger'[OF assms].
   have "c \<noteq> 0" and  "b \<noteq> 0" using  \<open>2 \<le> c\<close> \<open>2 \<le> b\<close> by auto
   have "x \<cdot> x\<^sup>@a \<cdot> y\<^sup>@b = x\<^sup>@a \<cdot> y\<^sup>@b \<cdot> x" and "y \<cdot> x\<^sup>@a \<cdot> y\<^sup>@b = x\<^sup>@a \<cdot> y\<^sup>@b \<cdot> y"
     unfolding comm_add_exp[OF \<open>x \<cdot> y = y \<cdot> x\<close>[symmetric], of b] comm_add_exp[OF \<open>x \<cdot> y = y \<cdot> x\<close>, symmetric, of a]
-    lassoc power_commutes by blast+
+      lassoc power_commutes by blast+ 
   thus "x\<cdot>z = z\<cdot>x" and "y\<cdot>z = z\<cdot>y"
-    using comm_drop_exp[OF \<open>c \<noteq> 0\<close>] unfolding lassoc \<open>x\<^sup>@a\<cdot>y\<^sup>@b = z\<^sup>@c\<close> by force+
+    using comm_drop_exp[OF \<open>c \<noteq> 0\<close>] unfolding lassoc \<open>x\<^sup>@a\<cdot>y\<^sup>@b = z\<^sup>@c\<close> by metis+
+qed
+hide_fact Lyndon_Schutzenberger'
+
+lemma Lyndon_Schutzenberger_conjug: assumes "u \<sim> v" and  "\<not> primitive (u \<cdot> v)" shows "u \<cdot> v = v \<cdot> u"
+proof-
+  obtain r s where "u = r \<cdot> s" and "v = s \<cdot> r"
+    using \<open>u \<sim> v\<close> by blast
+  have "u \<cdot> v \<sim> r\<^sup>@2 \<cdot> s\<^sup>@2"
+    using conjugI'[of "r \<cdot> s \<cdot> s" r] unfolding \<open>u = r \<cdot> s\<close> \<open>v = s \<cdot> r\<close> pow_two rassoc.
+  hence "\<not> primitive (r\<^sup>@2 \<cdot> s\<^sup>@2)"
+    using \<open>\<not> primitive (u \<cdot> v)\<close> prim_conjug by auto
+  from not_prim_pow[OF this, of "r \<cdot> s = s \<cdot> r"]
+  have "r \<cdot> s = s \<cdot> r"
+    using Lyndon_Schutzenberger(1)[of r 2 s 2, OF _ order.refl order.refl] by metis  
+  thus "u \<cdot> v = v \<cdot> u"
+    using \<open>u = r \<cdot> s\<close> \<open>v = s \<cdot> r\<close> by presburger
 qed
 
+lemma Lyndon_Schutzenberger_prim: assumes "\<not> primitive x" and "\<not> primitive y" and "\<not> primitive (x \<cdot> y)" 
+  shows "x \<cdot> y = y \<cdot> x" 
+proof
+  assume "x \<noteq> \<epsilon>" and "y \<noteq> \<epsilon>" 
+  from not_prim_primroot_expE'[OF \<open>\<not> primitive y\<close> \<open>y \<noteq> \<epsilon>\<close>]
+  obtain m r where "r\<^sup>@m = y" and "2 \<le> m" and "\<rho> y = r" by metis
+  from not_prim_primroot_expE'[OF \<open>\<not> primitive x\<close> \<open>x \<noteq> \<epsilon>\<close>]
+  obtain k s where "s\<^sup>@k = x" and "2 \<le> k" and "\<rho> x = s" by metis
+  from not_prim_primroot_expE'[OF \<open>\<not> primitive (x \<cdot> y)\<close> pref_nemp[OF \<open>x \<noteq> \<epsilon>\<close>]]
+  obtain l z where "z\<^sup>@l = x \<cdot> y" and "2 \<le> l".
+  from Lyndon_Schutzenberger(1)[OF this(1)[symmetric,
+        folded \<open>r\<^sup>@m = y\<close> \<open>s\<^sup>@k = x\<close>, folded \<open>\<rho> x = s\<close> \<open>\<rho> y = r\<close>] \<open>2 \<le> k\<close> \<open>2 \<le> m\<close> \<open>2 \<le>l\<close>] 
+  show "x \<cdot> y = y \<cdot> x" 
+    unfolding comp_primroot_conv'[OF \<open>x \<noteq> \<epsilon>\<close> \<open>y \<noteq> \<epsilon>\<close>, symmetric]. 
+qed
+
+lemma Lyndon_Schutzenberger_rotate: assumes "x\<^sup>@k = r \<^sup>@ Suc q \<cdot> u\<^sup>@k \<cdot> r \<^sup>@ Suc q"
+  and "1 < k" and "u \<noteq> \<epsilon>"
+shows "u \<cdot> r = r \<cdot> u" and "u \<cdot> x = x \<cdot> u" and "x \<cdot> r = r \<cdot> x"
+proof-
+  have "2 \<le> k"
+    using One_nat_def assms(2) by presburger
+  have "2 \<le> Suc q + Suc q"
+    by simp
+
+  have "r \<^sup>@ Suc q \<le>p x \<cdot> r \<^sup>@ Suc q"
+    by (metis assms(1) prefI pref_prod_root)
+  have "u\<^sup>@k \<cdot> r \<^sup>@ (Suc q + Suc q) = ((r \<^sup>@ Suc q)\<inverse>\<^sup>>(x \<cdot>r\<^sup>@Suc q))\<^sup>@k"
+    unfolding add_exps[of r "Suc q" "Suc q"] 
+    using 
+      per_drop_exp'[of 1 "r \<^sup>@ Suc q" x, THEN lq_conjug_pow, of k,
+        unfolded assms(1)] \<open>r \<^sup>@ Suc q \<le>p x \<cdot> r \<^sup>@ Suc q\<close>
+    by force
+
+  from Lyndon_Schutzenberger(1)[OF \<open>u\<^sup>@k \<cdot> r \<^sup>@ (Suc q + Suc q) = ((r \<^sup>@ Suc q)\<inverse>\<^sup>>(x \<cdot>r\<^sup>@Suc q))\<^sup>@k\<close> \<open>2 \<le>k\<close> \<open>2 \<le> Suc q + Suc q\<close> \<open>2 \<le>k\<close>]
+  show "u \<cdot> r = r \<cdot> u".
+
+  have "x\<^sup>@k \<cdot> r = r \<cdot> x\<^sup>@k"
+    unfolding assms(1) lassoc pow_comm[of r "Suc q", symmetric]
+    unfolding rassoc power_commuting_commutes[OF \<open>u \<cdot> r = r \<cdot> u\<close>, of k, symmetric] 
+      pow_comm[of r "Suc q", symmetric]
+    by simp
+  from comm_drop_exp[OF gr_implies_not0[OF assms(2)] this[symmetric]]
+  show "x \<cdot> r = r \<cdot> x".
+  show "u \<cdot> x = x \<cdot> u"
+  proof(cases "r = \<epsilon>")
+    case True
+    with Lyndon_Schutzenberger(2)[OF \<open>u\<^sup>@k \<cdot> r \<^sup>@ (Suc q + Suc q) = ((r \<^sup>@ Suc q)\<inverse>\<^sup>>(x \<cdot>r\<^sup>@Suc q))\<^sup>@k\<close> \<open>2 \<le>k\<close> \<open>2 \<le> Suc q + Suc q\<close> \<open>2 \<le>k\<close>]
+    show ?thesis
+      by force
+  next
+    case False
+    from comm_trans[OF \<open>u \<cdot> r = r \<cdot> u\<close> \<open>x \<cdot> r = r \<cdot> x\<close> this]
+    show ?thesis.
+  qed
+qed
+
+section \<open>Parametric solution of the equation @{term "x\<^sup>@j\<cdot>y\<^sup>@k = z\<^sup>@l"}\<close>
+
+subsection \<open>Auxiliary lemmas\<close>
+
+lemma xjy_imprim: assumes "x \<cdot> y \<noteq> y \<cdot> x" and eq: "x\<^sup>@j \<cdot> y = z\<^sup>@l" and "2 \<le> j" and "2 \<le> l"
+  shows "\<^bold>|x\<^sup>@j\<^bold>| < \<^bold>|y\<^bold>| + 2*\<^bold>|x\<^bold>|" and "\<^bold>|z\<^bold>| < \<^bold>|x\<^bold>| + \<^bold>|y\<^bold>|" and "\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|" and "\<^bold>|x\<^sup>@j\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|x\<^bold>|"
+proof-
+  obtain j' where "j = Suc (Suc j')"
+    using \<open>2 \<le> j\<close> using at_least2_Suc by metis
+  have "j \<noteq> 0"
+    using \<open>2 \<le> j\<close> by force+
+  from LS_per_lemma_case[of _ _ _ 1, unfolded pow_one', OF eq this]
+  show "\<^bold>|x\<^sup>@j\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|x\<^bold>|"
+    using \<open>x \<cdot> y \<noteq> y \<cdot> x\<close> by linarith
+  from lenarg[OF eq, unfolded lenmorph, unfolded pow_len]
+    add_less_mono1[OF this, of "\<^bold>|y\<^bold>|",  unfolded pow_len]
+  show "\<^bold>|z\<^bold>| < \<^bold>|x\<^bold>| + \<^bold>|y\<^bold>|"
+    using mult_le_mono1[OF \<open>2 \<le> l\<close>, unfolded mult_2, of "\<^bold>|z\<^bold>|"] by linarith
+  with \<open>\<^bold>|x\<^sup>@j\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|x\<^bold>|\<close>
+  show "\<^bold>|x\<^sup>@j\<^bold>| < \<^bold>|y\<^bold>| + 2*\<^bold>|x\<^bold>|" and "\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|"
+    unfolding \<open>j = Suc (Suc j')\<close> pow_Suc lenmorph mult_2 by linarith+
+qed
+
+subsection \<open>@{term x} is longer\<close>
+
+locale LS_len_le = binary_code x y for x y +
+  fixes j k l z
+  assumes 
+    y_le_x: "\<^bold>|y\<^bold>| \<le> \<^bold>|x\<^bold>|" 
+    and eq: "x\<^sup>@j \<cdot> y\<^sup>@k = z\<^sup>@l"
+    and l_min: "2 \<le> l"
+    and j_min: "1 \<le> j"
+    and k_min: "1 \<le> k"
+begin
+
+lemma jk_small: obtains "j = 1" | "k = 1"
+  using Lyndon_Schutzenberger(1)[OF eq _ _ l_min]
+    le_neq_implies_less[OF j_min] 
+    le_neq_implies_less[OF k_min]
+    non_comm
+  unfolding One_less_Two_le_iff
+  by blast
+
+subsubsection \<open>case @{term "j = 2"}\<close>
+
+lemma case_j2k1: assumes "2 \<le> j" "k = 1"
+  obtains r q t where
+    "(r \<cdot> q) \<^sup>@ (Suc (Suc t)) \<cdot> r = x" and
+    "q \<cdot> r \<cdot> r \<cdot> q  =  y" and
+    "(r \<cdot> q) \<^sup>@ (Suc (Suc t)) \<cdot> r \<cdot> r \<cdot> q = z" and
+    "j = 2" and "l = 2" and "r\<cdot>q \<noteq> q\<cdot>r" and
+    "primitive x" and "primitive y"
+proof-
+  note eq' = eq[unfolded \<open>k = 1\<close> pow_one']
+  note xjy_imprim[OF non_comm eq[unfolded \<open>k = 1\<close> pow_one'] \<open>2 \<le> j\<close> l_min]
+
+  obtain j' where "j = Suc (Suc j')"
+    using \<open>2 \<le> j\<close> using at_least2_Suc by metis
+  hence "j \<noteq> 0" by blast
+  from lenarg[OF eq', unfolded lenmorph, unfolded pow_len]
+    add_less_mono1[OF \<open>\<^bold>|x\<^sup>@j\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|x\<^bold>|\<close>, of "\<^bold>|y\<^bold>|", unfolded pow_len]
+  have "l*\<^bold>|z\<^bold>| < 3*\<^bold>|z\<^bold>|"
+    using \<open>\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|\<close> y_le_x by linarith
+  hence "l = 2"
+    using l_min by simp
+  from \<open>\<^bold>|x \<^sup>@ j\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|x\<^bold>|\<close> add_less_mono1[OF \<open>\<^bold>|z\<^bold>| < \<^bold>|x\<^bold>| + \<^bold>|y\<^bold>|\<close>, of "\<^bold>|x\<^bold>|"] y_le_x
+  have "j' * \<^bold>|x\<^bold>| < \<^bold>|x\<^bold>|"
+    unfolding \<open>j = Suc (Suc j')\<close> pow_Suc lenmorph pow_len by linarith
+  hence "j = 2"
+    using  \<open>j = Suc (Suc j')\<close> by simp
+
+  note eq[ unfolded \<open>k = 1\<close> pow_one' \<open>j = 2\<close> \<open>l = 2\<close> pow_two rassoc]
+  from eqd[OF this less_imp_le[OF \<open>\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|\<close>]]
+  obtain p where "x \<cdot> p = z" and "p \<cdot> z = x \<cdot> y"
+    by blast
+  from eqd[OF \<open>p \<cdot> z = x \<cdot> y\<close>[folded \<open>x \<cdot> p = z\<close>, unfolded lassoc, symmetric]]
+  obtain s where "x \<cdot> s = p \<cdot> x" and "s \<cdot> p = y"
+    by auto
+  have "p \<noteq> \<epsilon>"
+    using \<open>x \<cdot> p = z\<close> \<open>\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|\<close> by fastforce
+  have "s \<noteq> \<epsilon>"
+    using \<open>p \<noteq> \<epsilon>\<close> \<open>x \<cdot> s = p \<cdot> x\<close> by force 
+  from  conjug_eqE[OF \<open>x \<cdot> s = p \<cdot> x\<close>[symmetric] \<open>p \<noteq> \<epsilon>\<close>]
+  obtain r q t' where "r \<cdot> q = p" and "q \<cdot> r = s" and "(r \<cdot> q)\<^sup>@t'\<cdot>r = x" and "q \<noteq> \<epsilon>".
+  note \<open>s \<cdot> p = y\<close>[folded \<open>q \<cdot> r = s\<close> \<open>r \<cdot> q = p\<close>, unfolded rassoc]
+  from y_le_x[folded this \<open>(r \<cdot> q)\<^sup>@t'\<cdot>r = x\<close>, unfolded lenmorph pow_len] nemp_len[OF \<open>q \<noteq> \<epsilon>\<close>]
+    add_le_mono1[OF mult_le_mono1[of t' 1 "\<^bold>|r\<^bold>| + \<^bold>|q\<^bold>|", unfolded mult_1], of "\<^bold>|r\<^bold>|"]
+  have "2 \<le> t'"
+    by linarith
+  then obtain t where "t' = Suc (Suc t)"
+    using at_least2_Suc by blast
+  from \<open>p \<cdot> z = x \<cdot> y\<close>[folded \<open>q \<cdot> r \<cdot> r \<cdot> q = y\<close> \<open>(r \<cdot> q)\<^sup>@t'\<cdot>r = x\<close>  \<open>r \<cdot> q = p\<close>, unfolded \<open>t' = Suc (Suc t)\<close> pow_Suc rassoc cancel, symmetric]
+  have z: "(r \<cdot> q) \<^sup>@ Suc (Suc t) \<cdot> r \<cdot> r \<cdot> q = z"
+    unfolding pow_Suc2[of _ "Suc t"] unfolding pow_Suc rassoc.
+
+\<comment> \<open>y is primitive due to the Lyndon-Schutzenberger\<close>
+
+  from comm_drop_exp[OF \<open>j \<noteq> 0\<close>, of y x j, unfolded eq']
+  have "primitive y"
+    using Lyndon_Schutzenberger_prim[OF pow_nemp_imprim[OF \<open>2 \<le>j\<close>], of y x, unfolded eq', OF _ pow_nemp_imprim[OF l_min]] non_comm by argo
+
+  hence "q \<cdot> r \<noteq> r \<cdot> q"
+    using \<open>p \<noteq> \<epsilon>\<close> \<open>q \<cdot> r = s\<close> \<open>r \<cdot> q = p\<close> \<open>s \<cdot> p = y\<close> comm_not_prim[OF \<open>s \<noteq> \<epsilon>\<close> \<open>p \<noteq> \<epsilon>\<close>] by argo
+
+\<comment> \<open>primitivity of x using @{thm per_le_prim_iff}\<close>
+
+  thm per_le_prim_iff[of x p]
+  have "x \<le>p p \<cdot> x"
+    unfolding \<open>(r \<cdot> q)\<^sup>@t'\<cdot>r = x\<close>[symmetric] \<open>r \<cdot> q = p\<close>[symmetric]
+    by comparison
+  have "2*\<^bold>|p\<^bold>| \<le> \<^bold>|x\<^bold>|"
+    unfolding \<open>(r \<cdot> q)\<^sup>@t'\<cdot>r = x\<close>[symmetric] \<open>r \<cdot> q = p\<close>[symmetric] lenmorph pow_len
+    using mult_le_mono1[OF \<open>2 \<le> t'\<close>, of "(\<^bold>|r\<^bold>| + \<^bold>|q\<^bold>|)"] by linarith 
+  have [symmetric]: "p \<cdot> x \<noteq> x \<cdot> p"
+    unfolding \<open>(r \<cdot> q)\<^sup>@t'\<cdot>r = x\<close>[symmetric] \<open>r \<cdot> q = p\<close>[symmetric] lassoc pow_comm[symmetric]
+    unfolding rassoc cancel by fact
+  with per_le_prim_iff[OF \<open>x \<le>p p \<cdot> x\<close> \<open>p \<noteq> \<epsilon>\<close> \<open> 2 * \<^bold>|p\<^bold>| \<le> \<^bold>|x\<^bold>|\<close>] 
+  have "primitive x" 
+    by blast
+
+  from that[OF \<open>(r \<cdot> q)\<^sup>@t'\<cdot>r = x\<close>[unfolded \<open>t' = Suc (Suc t)\<close>] \<open>q \<cdot> r \<cdot> r \<cdot> q = y\<close> z \<open>j = 2\<close> \<open>l = 2\<close> \<open>q\<cdot>r \<noteq> r\<cdot>q\<close>[symmetric]
+      \<open>primitive x\<close> \<open>primitive y\<close>]
+  show thesis.
+qed 
+
+subsubsection \<open>case @{term "j = 1"}\<close>
+
+lemma case_j1k2_primitive: assumes "j = 1" "2 \<le> k"
+  shows "primitive x"
+  using Lyndon_Schutzenberger_prim[OF _ pow_nemp_imprim
+      pow_nemp_imprim[OF l_min, of z, folded eq], OF _ \<open>2 \<le> k\<close>]
+    comm_pow_roots[of j k x y] k_min non_comm
+  unfolding \<open>j = 1\<close> pow_one'
+  by linarith
+
+lemma case_j1k2_a: assumes "j = 1" "2 \<le> k" "z \<le>s y\<^sup>@k"
+  obtains r q t where
+    "x = ((q \<cdot> r) \<cdot> (r \<cdot> (q \<cdot> r) \<^sup>@ Suc t) \<^sup>@ (k - 1)) \<^sup>@ (l - 2) \<cdot>
+      (((q \<cdot> r) \<cdot> (r \<cdot> (q \<cdot> r) \<^sup>@ Suc t) \<^sup>@ (k - 2)) \<cdot> r) \<cdot> q" and
+    "y = r \<cdot> (q \<cdot> r) \<^sup>@ Suc t" and
+    "z = (q \<cdot> r) \<cdot> (r \<cdot> (q \<cdot> r) \<^sup>@ Suc t) \<^sup>@ (k - 1)" and "r\<cdot>q \<noteq> q\<cdot>r"
+proof-
+  have "z \<noteq> \<epsilon>"
+    using assms(1) bin_fst_nemp eq by force
+  have "k \<noteq> 0" "k - 1 \<noteq> 0"
+    using \<open>2 \<le> k\<close> by linarith+
+  have "l \<noteq> 0" "l - 1 \<noteq> 0"
+    using l_min by linarith+
+
+  from LS_per_lemma_case[reversed, OF eq \<open>k \<noteq> 0\<close>, unfolded \<open>j = 1\<close>]
+  have perlem: "\<^bold>|y\<^sup>@k\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|y\<^bold>|"
+    using non_comm
+    by linarith
+
+  obtain v where "y\<^sup>@k = v\<cdot>z"
+    using \<open>z \<le>s y\<^sup>@k\<close> suffix_def by blast
+  have "\<^bold>|v\<^bold>| < \<^bold>|y\<^bold>|"
+    using perlem[unfolded lenarg[OF \<open>y\<^sup>@k = v\<cdot>z\<close>] lenmorph]
+    by simp
+  have "v <p y"
+    using prefI[OF \<open>y\<^sup>@k = v\<cdot>z\<close>[symmetric]]
+    unfolding pop_pow_one[OF \<open>k \<noteq> 0\<close>]
+    using pref_prod_less[OF _ \<open>\<^bold>|v\<^bold>| < \<^bold>|y\<^bold>|\<close>]
+    by blast
+  obtain u where "v\<cdot>u = y" "u \<noteq> \<epsilon>"
+    using \<open>v <p y\<close> unfolding strict_suffix_def suffix_def
+    by blast
+
+  have "z = u\<cdot>y\<^sup>@(k-1)"
+    using \<open>y\<^sup>@k = v\<cdot>z\<close>[unfolded pop_pow_one[OF \<open>k \<noteq> 0\<close>],
+        folded \<open>v \<cdot> u = y\<close>, unfolded rassoc cancel,
+        unfolded \<open>v \<cdot> u = y\<close>, symmetric].
+
+  note eq[unfolded pop_pow_one'[OF \<open>l \<noteq> 0\<close>] \<open>y\<^sup>@k = v\<cdot>z\<close> lassoc cancel_right
+      \<open>j = 1\<close> pow_one']
+
+  obtain u' where "u'\<cdot>v = y"
+  proof-
+    have "v \<le>s z\<^sup>@(l-1)"
+      using \<open>x \<cdot> v = z \<^sup>@ (l - 1)\<close> by blast
+    moreover have "y \<le>s z\<^sup>@(l-1)"
+      unfolding \<open>z = u\<cdot>y\<^sup>@(k-1)\<close> pop_pow_one'[OF \<open>k - 1 \<noteq> 0\<close>]
+        pop_pow_one'[OF \<open>l - 1 \<noteq> 0\<close>] lassoc
+      by blast
+    ultimately have "v \<le>s y"
+      using order_less_imp_le[OF \<open>\<^bold>|v\<^bold>| < \<^bold>|y\<^bold>|\<close>] suffix_length_suffix by blast
+    thus thesis
+      using sufD that by blast
+  qed
+  hence "u' \<noteq> \<epsilon>"
+    using \<open>v <p y\<close> by force
+
+  from conjugation[OF \<open>u'\<cdot>v = y\<close>[folded \<open>v\<cdot>u = y\<close>] \<open>u' \<noteq> \<epsilon>\<close>]
+  obtain r q t where "r \<cdot> q = u'" "q \<cdot> r = u" "(r \<cdot> q) \<^sup>@ t \<cdot> r = v"
+    by blast
+
+  have y: "y = r \<cdot> (q \<cdot> r) \<^sup>@ Suc t"
+    using \<open>u' \<cdot> v = y\<close>[symmetric, folded \<open>(r \<cdot> q) \<^sup>@ t \<cdot> r = v\<close> \<open>r \<cdot> q = u'\<close>]
+    unfolding rassoc pow_slide[symmetric]. 
+  have z: "z = (q \<cdot> r) \<cdot> (r \<cdot> (q \<cdot> r) \<^sup>@ Suc t) \<^sup>@ (k - 1)"
+    using \<open>q \<cdot> r = u\<close> \<open>z = u \<cdot> y \<^sup>@ (k - 1)\<close> y by blast
+
+  from \<open>x \<cdot> v = z \<^sup>@ (l - 1)\<close>[folded z[symmetric] \<open>(r \<cdot> q) \<^sup>@ t \<cdot> r = v\<close>,
+      unfolded pop_pow_one'[OF \<open>k - 1 \<noteq> 0\<close>] pop_pow_one'[OF \<open>l - 1 \<noteq> 0\<close>]]
+  have x: "x = ((q \<cdot> r) \<cdot> (r \<cdot> (q \<cdot> r) \<^sup>@ Suc t) \<^sup>@ (k - 1)) \<^sup>@ (l - 2) \<cdot>
+      (((q \<cdot> r) \<cdot> (r \<cdot> (q \<cdot> r) \<^sup>@ Suc t) \<^sup>@ (k - 2)) \<cdot> r) \<cdot> q"
+    unfolding pop_pow_one[OF Suc_not_Zero] diff_Suc_1 shift_pow
+    unfolding lassoc cancel_right
+    unfolding rassoc pop_pow_one'[OF \<open>k - 1 \<noteq> 0\<close>]
+    unfolding diff_Suc_eq_diff_pred[symmetric] Suc_1.
+
+  (* ALT approach *)
+  (* let ?x = "((q \<cdot> r) \<cdot> (r \<cdot> (q \<cdot> r) \<^sup>@ Suc t) \<^sup>@ (k - 1)) \<^sup>@ (l - 2) \<cdot> *)
+      (* (((q \<cdot> r) \<cdot> (r \<cdot> (q \<cdot> r) \<^sup>@ Suc t) \<^sup>@ (k - 2)) \<cdot> r) \<cdot> q" *)
+  (* have "?x \<cdot> v = z \<^sup>@ (l - 1)" *)
+    (* unfolding z \<open>(r \<cdot> q) \<^sup>@ t \<cdot> r = v\<close>[symmetric] pop_pow_one'[OF \<open>k - 1 \<noteq> 0\<close>] *)
+    (* pop_pow_one'[OF \<open>l - 1 \<noteq> 0\<close>] diff_diff_left nat_1_add_1 *)
+    (* by (simp only: shifts) *)
+  (* from \<open>x \<cdot> v = z \<^sup>@ (l - 1)\<close>[folded this] *)
+  (* have "x = ?x" *)
+    (* by blast *)
+
+
+  have "z\<cdot>y \<noteq> y\<cdot>z"
+    using non_comm
+    using power_commuting_commutes[of z y l, folded eq,
+        unfolded rassoc pow_comm, unfolded lassoc cancel_right
+        \<open>j = 1\<close> pow_one']
+    by blast
+  hence "r\<cdot>q \<noteq> q\<cdot>r"
+    unfolding \<open>q \<cdot> r = u\<close> \<open>r \<cdot> q = u'\<close> \<open>u'\<cdot> v  = y\<close>[symmetric]
+      \<open>z = u \<cdot> y \<^sup>@ (k - 1)\<close> pop_pow_one'[OF \<open>k \<noteq> 0\<close>] rassoc
+      \<open>y \<^sup>@ k = v \<cdot> z\<close>[unfolded \<open>u' \<cdot> v = y\<close>[symmetric]
+        \<open>z = u \<cdot> y \<^sup>@ (k - 1)\<close>, symmetric] cancel_right..
+
+  show thesis
+    using that[OF x y z \<open>r\<cdot>q \<noteq> q\<cdot>r\<close>].
+qed
+
+lemma case_j1k2_b: assumes "j = 1" "2 \<le> k" "y\<^sup>@k <s z"
+  obtains q where 
+    "x = (q\<cdot>y\<^sup>@k)\<^sup>@(l-1)\<cdot>q" and
+    "z = q\<cdot>y\<^sup>@k" and 
+    "q\<cdot>y \<noteq> y\<cdot>q"
+proof-
+  obtain q where "z = q\<cdot>y\<^sup>@k" "q \<noteq> \<epsilon>"
+    using ssufD[OF \<open>y\<^sup>@k <s z\<close>]
+    unfolding suffix_def
+    by blast
+  have "l \<noteq> 0" using l_min by linarith
+  have "x = (q\<cdot>y\<^sup>@k)\<^sup>@(l-1)\<cdot>q"
+    using eq[unfolded pop_pow_one'[OF \<open>l \<noteq> 0\<close>] \<open>j = 1\<close> pow_one',
+        unfolded \<open>z = q\<cdot>y\<^sup>@k\<close> lassoc cancel_right].
+  have "q\<cdot>y \<noteq> y\<cdot>q"
+    using 
+      comm_trans[OF _ _ \<open>q \<noteq> \<epsilon>\<close>, of y x] conjug_pow[of y q y k, symmetric]
+      conjug_pow[of "q \<cdot> y \<^sup>@ k" q  "q \<cdot> y \<^sup>@ k" "l-1"] non_comm 
+    unfolding append_same_eq[symmetric, of \<open>(q \<cdot> y \<^sup>@ k) \<^sup>@ (l - 1) \<cdot> q\<close> \<open>q \<cdot> (q \<cdot> y \<^sup>@ k) \<^sup>@ (l - 1)\<close> q]
+    unfolding \<open>x = (q \<cdot> y \<^sup>@ k) \<^sup>@ (l - 1) \<cdot> q\<close> rassoc
+    by argo  
+  show ?thesis
+    using \<open>x = (q \<cdot> y \<^sup>@ k) \<^sup>@ (l - 1) \<cdot> q\<close> \<open>z = q \<cdot> y \<^sup>@ k\<close> \<open>q\<cdot>y \<noteq> y\<cdot>q\<close> that by blast
+qed
+
+lemma case_j1k1: assumes "j = 1" "k = 1"
+  obtains r q m n where
+    "x = (r\<cdot>q)\<^sup>@m\<cdot>r" and
+    "y = q\<cdot>(r\<cdot>q)\<^sup>@n" and
+    "z = r\<cdot>q" and
+    "Suc (m+n)=l" and "r\<cdot>q \<noteq> q\<cdot>r"
+proof-
+  from eq[unfolded assms pow_one']
+  have "x \<cdot> y = concat ([z] \<^sup>@ l)"
+    by (simp add: concat_pow)
+  hence "x <p concat ([z] \<^sup>@ l)"
+    using bin_snd_nemp by blast
+
+  from pref_mod_list[OF this]
+  obtain m r where "m < \<^bold>|[z] \<^sup>@ l\<^bold>|" "r <p ([z] \<^sup>@ l) ! m"
+    "concat (take m ([z] \<^sup>@ l)) \<cdot> r = x".
+
+  have "m < l"
+    using \<open>m < \<^bold>|[z] \<^sup>@ l\<^bold>|\<close>
+    unfolding sing_pow_len.
+
+  obtain n where "Suc (m + n) = l"
+    using less_imp_Suc_add[OF \<open>m < l\<close>]
+    by blast
+
+  have "z\<^sup>@m\<cdot>r = x"
+    using \<open>concat (take m ([z] \<^sup>@ l)) \<cdot> r = x\<close> 
+    unfolding concat_take_sing[OF less_or_eq_imp_le, OF disjI1, OF \<open>m < l\<close>].
+
+  have "r <p z"
+    using \<open>m < \<^bold>|[z] \<^sup>@ l\<^bold>|\<close> \<open>r <p ([z] \<^sup>@ l) ! m\<close> sing_pow_len sing_pow_nth by metis
+  then obtain q where "z = r\<cdot>q" "q \<noteq> \<epsilon>"
+    by blast
+
+  have "z \<^sup>@ m\<inverse>\<^sup>>z \<^sup>@ l = z\<^sup>@(l-m)"
+    using lq_triv
+      pop_pow[OF less_or_eq_imp_le[OF disjI1, OF \<open>m < \<^bold>|[z] \<^sup>@ l\<^bold>|\<close>], symmetric]
+    unfolding sing_pow_len
+    by auto
+  hence "z \<^sup>@ m\<inverse>\<^sup>>z \<^sup>@ l = z\<cdot>z\<^sup>@n"
+    unfolding pop_pow_one[OF zero_less_diff'[OF \<open>m < l\<close>]]
+    using \<open>Suc (m + n) = l\<close> by force
+  have "y = q\<cdot>(r\<cdot>q)\<^sup>@n"
+    using lqI[OF \<open>x \<cdot> y = z \<^sup>@ l\<close>[folded \<open>z\<^sup>@m\<cdot>r = x\<close>, unfolded rassoc], symmetric]
+    unfolding \<open>z \<^sup>@ m\<inverse>\<^sup>>z \<^sup>@ l = z\<cdot>z\<^sup>@n\<close>
+    unfolding \<open>z = r\<cdot>q\<close> rassoc cancel.
+
+  have "x\<cdot>z \<noteq> z\<cdot>x"
+    using conjug_pow[of z x z l, folded \<open>x \<cdot> y = z \<^sup>@ l\<close>, 
+        unfolded rassoc cancel, OF sym, symmetric]
+      non_comm by blast
+  hence "r\<cdot>q \<noteq> q\<cdot>r"
+    unfolding \<open>z \<^sup>@ m \<cdot> r = x\<close>[symmetric] \<open>z = r \<cdot> q\<close>
+    unfolding lassoc power_commutes[of "r\<cdot>q" m, symmetric]
+    unfolding rassoc cancel.
+
+  show ?thesis
+    using that[OF \<open>z\<^sup>@m\<cdot>r = x\<close>[unfolded \<open>z = r\<cdot>q\<close>, symmetric]
+        \<open>y = q\<cdot>(r\<cdot>q)\<^sup>@n\<close> \<open>z = r\<cdot>q\<close> \<open>Suc (m+n) = l\<close> \<open>r\<cdot>q \<noteq> q\<cdot>r\<close>].
+qed
+
+subsection \<open>Putting things together\<close>
+
+lemma solution_cases: obtains 
+  "j = 2" "k = 1" |
+  "j = 1" "2 \<le> k" "z <s y\<^sup>@k" |
+  "j = 1" "2 \<le> k" "y\<^sup>@k <s z" |
+  "j = 1" "k = 1"
+proof-
+  have "l\<noteq>0" "l-1 \<noteq> 0"
+    using l_min by linarith+
+  have "k \<noteq> 0"
+    using k_min by linarith
+  have "j \<noteq> 0"
+    using j_min by linarith
+  have "z \<noteq> \<epsilon>"
+    using eq nemp_pow_nemp[of z l] bin_fst_nemp[folded nonzero_pow_emp[OF \<open>j \<noteq> 0\<close>, of x], THEN pref_nemp]
+    by force 
+  have "z \<noteq> y\<^sup>@k"
+  proof 
+    assume "z = y\<^sup>@k"
+    with eq[unfolded pop_pow_one'[OF \<open>l\<noteq>0\<close>], folded this, unfolded cancel_right]
+    have "x\<^sup>@j \<cdot> y\<^sup>@k = y\<^sup>@k \<cdot> x\<^sup>@j"
+      using pow_comm by auto
+    with comm_drop_exps[of x "j-1" y "k - 1", unfolded Suc_minus[OF \<open>j \<noteq> 0\<close>] Suc_minus[OF \<open>k \<noteq> 0\<close>]] 
+    show False
+      using non_comm by blast
+  qed
+  consider
+    "2 \<le> j" "k = 1" |
+    "j = 1" "2 \<le> k" |
+    "j = 1" "k = 1"
+    using jk_small j_min k_min le_neq_implies_less
+    unfolding One_less_Two_le_iff[symmetric]
+    by metis
+  moreover consider "z <s y\<^sup>@k" | "y\<^sup>@k <s z"
+    using suffix_order.less_le 
+      triv_suf[of "y\<^sup>@k" "x\<^sup>@j", unfolded eq, THEN suf_prod_root, 
+        THEN ruler_pref'[reversed]] \<open>z \<noteq> y\<^sup>@k\<close>
+    by blast
+  moreover consider "j = 1" | "j = 2"
+    using case_j2k1[of thesis] calculation(1) by blast
+  ultimately show ?thesis
+    using that
+    by metis
+qed
+
+theorem parametric_solutionE: obtains 
+  \<comment>\<open>case @{term "x\<cdot>y"}\<close>
+  r q m n where
+  "x = (r\<cdot>q)\<^sup>@m\<cdot>r" and
+  "y = q\<cdot>(r\<cdot>q)\<^sup>@n" and
+  "z = r\<cdot>q" and
+  "Suc (m+n) = l" and "r\<cdot>q \<noteq> q\<cdot>r"
+|
+  \<comment>\<open>case @{term "x\<cdot>y\<^sup>@k"} with @{term "2 \<le> k"} and @{term "z <s y\<^sup>@k"}\<close>
+  r q t where
+  "x = ((q \<cdot> r) \<cdot> (r \<cdot> (q \<cdot> r) \<^sup>@ Suc t) \<^sup>@ (k - 1)) \<^sup>@ (l - 2) \<cdot>
+      (((q \<cdot> r) \<cdot> (r \<cdot> (q \<cdot> r) \<^sup>@ Suc t) \<^sup>@ (k - 2)) \<cdot> r) \<cdot> q" and
+  "y = r \<cdot> (q \<cdot> r) \<^sup>@ Suc t" and
+  "z = (q \<cdot> r) \<cdot> (r \<cdot> (q \<cdot> r) \<^sup>@ Suc t) \<^sup>@ (k - 1)" and
+  "r\<cdot>q \<noteq> q\<cdot>r"
+|
+  \<comment>\<open>case @{term "x\<cdot>y\<^sup>@k"} with @{term "2 \<le> k"} and @{term "y\<^sup>@k <s z"}\<close>
+  q where 
+  "x = (q\<cdot>y\<^sup>@k)\<^sup>@(l-1)\<cdot>q" and
+  "z = q\<cdot>y\<^sup>@k" and 
+  "q\<cdot>y \<noteq> y\<cdot>q"
+|
+  \<comment>\<open>case @{term "x\<^sup>@j\<cdot>y"} with @{term "2 \<le> j"}\<close>
+  r q t where
+  "x = (r \<cdot> q) \<^sup>@ (Suc (Suc t)) \<cdot> r" and
+  "y  =  q \<cdot> r \<cdot> r \<cdot> q" and
+  "z = (r \<cdot> q) \<^sup>@ (Suc (Suc t)) \<cdot> r \<cdot> r \<cdot> q" and
+  "j = 2" and "l = 2" and "r\<cdot>q \<noteq> q\<cdot>r" and
+  "primitive x" and "primitive y"
+proof-
+  show ?thesis
+    using solution_cases
+  proof(cases)
+    case 1
+    from case_j2k1[OF _ \<open>k = 1\<close>, of thesis] \<open>j = 2\<close>
+    show ?thesis
+      using that(4) by blast
+  next
+    case 2
+    from case_j1k2_a[OF \<open>j = 1\<close> \<open>2 \<le> k\<close>, of thesis]
+    show ?thesis
+      using that(2) \<open>z <s y \<^sup>@ k\<close> unfolding strict_suffix_def
+      by blast
+  next
+    case 3
+    from case_j1k2_b[OF this, of thesis]
+    show ?thesis
+      using that(3) by blast
+  next
+    case 4
+    from case_j1k1[OF this, of thesis]
+    show ?thesis
+      using that(1) by blast
+  qed
+qed
+
+end (* end locale *)
+
+text \<open>Using the solution from locale @{term LS_len_le},
+the following theorem gives the full characterization of the equation in question:
+$$ x^iy^j = z^\ell $$
+\<close>
+
+theorem LS_parametric_solution:
+  assumes y_le_x: "\<^bold>|y\<^bold>| \<le> \<^bold>|x\<^bold>|"
+    and j_min: "1 \<le> j"  and k_min: "1 \<le> k" and l_min: "2 \<le> l"
+  shows 
+    "x\<^sup>@j \<cdot> y\<^sup>@k = z\<^sup>@l
+  \<longleftrightarrow> ( 
+    (\<exists>r m n t. 
+        x = r\<^sup>@m \<and> y = r\<^sup>@n \<and> z = r\<^sup>@t \<and> m*j+n*k=t*l) \<comment>\<open>{x,y} is not a code\<close>
+  \<or> ((j = 1 \<and> k = 1) \<and>
+    (\<exists>r q m n. 
+        x = (r\<cdot>q)\<^sup>@m\<cdot>r \<and> y = q\<cdot>(r\<cdot>q)\<^sup>@n \<and> z = r\<cdot>q \<and> Suc(m+n) = l \<and> r\<cdot>q \<noteq> q\<cdot>r))
+  \<or> ((j = 1 \<and> 2 \<le> k) \<and> 
+      (\<exists>r q t. 
+        x = ((q \<cdot> r) \<cdot> (r \<cdot> (q \<cdot> r) \<^sup>@ Suc t) \<^sup>@ (k - 1)) \<^sup>@ (l - 2)\<cdot>(((q \<cdot> r) \<cdot>
+               (r \<cdot> (q \<cdot> r) \<^sup>@ Suc t) \<^sup>@ (k - 2)) \<cdot> r) \<cdot> q
+      \<and> y = r \<cdot> (q \<cdot> r) \<^sup>@ Suc t
+      \<and> z = (q \<cdot> r) \<cdot> (r \<cdot> (q \<cdot> r) \<^sup>@ Suc t) \<^sup>@ (k - 1)
+      \<and> r\<cdot>q \<noteq> q\<cdot>r))
+  \<or> ((j = 1 \<and> 2 \<le> k) \<and>
+    (\<exists>r q. 
+        x = (q\<cdot>r\<^sup>@k)\<^sup>@(l-1)\<cdot>q \<and> y = r \<and> z = q\<cdot>r\<^sup>@k \<and> r\<cdot>q \<noteq> q\<cdot>r))
+  \<or> ((j = 2 \<and> k = 1 \<and> l = 2) \<and> 
+    (\<exists>r q t. 
+        x = (r \<cdot> q) \<^sup>@ (Suc (Suc t)) \<cdot> r \<and> y = q \<cdot> r \<cdot> r \<cdot> q 
+      \<and> z = (r \<cdot> q) \<^sup>@ (Suc (Suc t)) \<cdot> r \<cdot> r \<cdot> q  \<and> r\<cdot>q \<noteq> q\<cdot>r ))
+  )
+  "
+    (is "?eq =
+   (?sol_per \<or> (?cond_j1k1 \<and> ?sol_j1k1) \<or>
+   (?cond_j1k2 \<and> ?sol_j1k2_a) \<or>
+   (?cond_j1k2 \<and> ?sol_j1k2_b) \<or>
+   (?cond_j2k1l2 \<and> ?sol_j2k1l2))")
+proof(rule iffI)
+  assume eq: "x \<^sup>@ j \<cdot> y \<^sup>@ k = z \<^sup>@ l"
+  show 
+    "(?sol_per \<or> (?cond_j1k1 \<and> ?sol_j1k1) \<or>
+   (?cond_j1k2 \<and> ?sol_j1k2_a) \<or>
+   (?cond_j1k2 \<and> ?sol_j1k2_b) \<or>
+   (?cond_j2k1l2 \<and> ?sol_j2k1l2))"
+  proof(cases)
+    assume "x\<cdot>y = y\<cdot>x"
+    from comm_primrootE[OF this]
+    obtain r m n where "x = r \<^sup>@ m" "y = r \<^sup>@ n" "primitive r"
+      using rootE by metis
+
+    note eqs = eq[unfolded this, folded pow_mult add_exps, symmetric]
+    obtain t where "z = r \<^sup>@ t"
+      using l_min pow_comm_comm[OF eqs,
+          THEN prim_comm_exp[OF \<open>primitive r\<close>]]
+      by auto
+    from eqs[unfolded this, folded pow_mult, symmetric]
+    have "m * j + n * k = t * l"
+      unfolding prim_nemp[OF \<open>primitive r\<close>, THEN eq_pow_exp].
+    hence ?sol_per 
+      using \<open>x = r \<^sup>@ m\<close> \<open>y = r \<^sup>@ n\<close> \<open>z = r \<^sup>@ t\<close> by blast
+    thus ?thesis 
+      by blast
+  next
+    assume "x\<cdot>y \<noteq> y\<cdot>x"
+    interpret LS_len_le x y j k l z
+      using \<open>x \<^sup>@ j \<cdot> y \<^sup>@ k = z \<^sup>@ l\<close> \<open>x\<cdot>y \<noteq> y\<cdot>x\<close> j_min k_min l_min y_le_x
+      by(unfold_locales)
+
+    show ?thesis
+      using solution_cases
+    proof(cases)
+      case 1
+      from case_j2k1[OF less_or_eq_imp_le[of 2 j] \<open>k = 1\<close>, OF disjI2, OF \<open>j = 2\<close>[symmetric], of "?sol_j2k1l2 \<and> l = 2"]
+      have "?sol_j2k1l2" and "l = 2"
+        by blast+
+      thus ?thesis
+        using \<open>k = 1\<close> \<open>j = 2\<close> by blast
+    next
+      case 2
+      have "?sol_j1k2_a"
+        using case_j1k2_a[OF \<open>j = 1\<close> \<open>2 \<le> k\<close> ssufD1[OF \<open>z <s y \<^sup>@ k\<close>], of ?sol_j1k2_a] 
+        by blast
+      thus ?thesis
+        using \<open>j = 1\<close> \<open>2 \<le> k\<close> by blast
+    next
+      case 3
+      with case_j1k2_b[OF this, of "?sol_j1k2_b"] 
+      have "?sol_j1k2_b" by auto 
+      thus ?thesis 
+        using \<open>j = 1\<close> \<open>2 \<le> k\<close> by blast
+    next
+      case 4
+      with case_j1k1[OF this, of ?sol_j1k1]
+      have"?sol_j1k1"
+        by blast 
+      thus ?thesis
+        using \<open>j = 1\<close> \<open>k = 1\<close> by blast
+    qed
+  qed
+next
+  have "l \<noteq> 0" "l - 1 \<noteq> 0"
+    using l_min by auto
+  have "k \<noteq> 0" using k_min by auto
+  have "j \<noteq> 0" using j_min by auto
+  assume   "(?sol_per \<or> (?cond_j1k1 \<and> ?sol_j1k1) \<or>
+   (?cond_j1k2 \<and> ?sol_j1k2_a) \<or>
+   (?cond_j1k2 \<and> ?sol_j1k2_b) \<or>
+   (?cond_j2k1l2 \<and> ?sol_j2k1l2))"
+  then show ?eq
+  proof(elim disjE conjE exE)
+    fix r m n t
+    assume sol: "x = r \<^sup>@ m" "y = r \<^sup>@ n" "z = r \<^sup>@ t" 
+      and "m * j + n * k = t * l"
+    show ?thesis
+      unfolding sol
+      unfolding power_mult[symmetric] power_add[symmetric] 
+      unfolding \<open>m * j + n * k = t * l\<close>..
+  next
+    fix r q m n
+    assume "j = 1" "k = 1" and sol: "x = (r\<cdot>q)\<^sup>@m\<cdot>r"
+      "y = q\<cdot>(r\<cdot>q)\<^sup>@n" "z = r\<cdot>q"
+      and "Suc(m+n) = l"
+    show ?thesis
+      unfolding sol
+      unfolding \<open>j = 1\<close> \<open>k = 1\<close> \<open>Suc(m+n) = l\<close>[symmetric] pow_one'
+      unfolding lassoc pow_Suc add_exps
+      unfolding power_commutes[of _ m, symmetric] lassoc..
+  next
+    fix r q t
+    assume "j = 1" "2 \<le> k" and sol:
+      "x =
+        ((q \<cdot> r) \<cdot> (r \<cdot> (q \<cdot> r) \<^sup>@ Suc t) \<^sup>@ (k - 1)) \<^sup>@ (l - 2) \<cdot>
+        (((q \<cdot> r) \<cdot> (r \<cdot> (q \<cdot> r) \<^sup>@ Suc t) \<^sup>@ (k - 2)) \<cdot> r) \<cdot> q"
+      "y = r \<cdot> (q \<cdot> r) \<^sup>@ Suc t"
+      "z = (q \<cdot> r) \<cdot> (r \<cdot> (q \<cdot> r) \<^sup>@ Suc t) \<^sup>@ (k - 1)"
+    obtain k' where  "Suc (Suc k') = k" using  Suc_minus2[OF \<open>2 \<le> k\<close>] by blast
+    hence k1: "k - 1 = Suc k'" and k2: "k - 2 = k'" and k: "k = k'+ 2" by fastforce+ 
+    obtain l' where "Suc (Suc l') = l" using  Suc_minus2[OF \<open>2 \<le> l\<close>] by blast 
+    hence l2: "l - 2 = l'" and l: "l  = l' + 2"  by fastforce+
+    show "x \<^sup>@ j \<cdot> y \<^sup>@ k = z \<^sup>@ l"
+      unfolding sol \<open>j = 1\<close> k1 k2 l2 unfolding k l by comparison
+  next
+    fix r q
+    assume "j = 1" "2 \<le> k" and sol: "x = (q \<cdot> r \<^sup>@ k) \<^sup>@ (l - 1) \<cdot> q" "y = r" "z = q \<cdot> r \<^sup>@ k"
+    show ?thesis
+      unfolding sol \<open>j = 1\<close> pow_one'
+      unfolding pop_pow_one'[OF \<open>l \<noteq> 0\<close>] rassoc..
+  next
+    fix r q t
+    assume "j = 2" "k = 1" "l = 2" and  sol:
+      "x = (r \<cdot> q) \<^sup>@ Suc (Suc t) \<cdot> r"
+      "y = q \<cdot> r \<cdot> r \<cdot> q" "z = (r \<cdot> q) \<^sup>@ Suc (Suc t) \<cdot> r \<cdot> r \<cdot> q"
+    show "x \<^sup>@ j \<cdot> y \<^sup>@ k = z \<^sup>@ l"
+      unfolding \<open>j = 2\<close> \<open>k = 1\<close> \<open>l = 2\<close> sol pow_one' pow_two
+      by comparison
+  qed
+qed
+
+subsection \<open>Uniqueness of the imprimitivity witness\<close>
+
+text\<open>In this section, we show that given a binary code @{term "{x,y}"} and
+two imprimitive words @{term "x\<^sup>@j\<cdot>y\<^sup>@k"} and @{term "x\<^sup>@j'\<cdot>y\<^sup>@k'"} is possible
+only if the two words are equals, that is, if @{term "j=j'"} and @{term "k=k'"}.\<close>
+
+lemma LS_unique_same: assumes "x \<cdot> y \<noteq> y \<cdot> x"
+  and "1 \<le> j" and "1 \<le> k" and "\<not> primitive(x\<^sup>@j\<cdot>y\<^sup>@k)" 
+  and "1 \<le> k'" and "\<not> primitive(x\<^sup>@j\<cdot>y\<^sup>@k')"
+shows "k = k'"
+proof(rule ccontr)
+  assume "k \<noteq> k'"
+
+  define ka where "ka = (if k < k' then k else k')"
+  define ka' where "ka' = (if k < k' then k' else k)"
+
+  have "ka < ka'" and "ka \<noteq> ka'"
+    unfolding ka_def ka'_def using \<open>k \<noteq> k'\<close> by auto
+  then obtain dif where [symmetric]: "ka + dif = ka'" and "dif \<noteq> 0"
+    using less_imp_add_positive by blast
+  have "ka \<noteq> 0" and "ka' \<noteq> 0" and \<open>j \<noteq> 0\<close>
+    unfolding ka_def ka'_def using \<open>1 \<le> k\<close> \<open>1 \<le> k'\<close> \<open>1 \<le> j\<close> by force+
+
+  have "\<not> primitive(x\<^sup>@j\<cdot>y\<^sup>@ka)" "\<not> primitive(x\<^sup>@j\<cdot>y\<^sup>@ka')"
+    unfolding ka_def ka'_def using assms(4) assms(6) by presburger+
+
+  have "x\<^sup>@j\<cdot>y\<^sup>@ka' = x\<^sup>@j\<cdot>y\<^sup>@ka\<cdot>y\<^sup>@dif"
+    unfolding add_exps[symmetric] \<open>ka' = ka + dif\<close>..
+
+  consider "dif = 1" | "2 \<le> dif"
+    using \<open>ka < ka'\<close> \<open>ka' = ka + dif\<close> by fastforce
+  hence "x \<cdot> y = y \<cdot> x"
+  proof(cases)
+    assume "dif = 1"
+    define u where "u = x\<^sup>@j\<cdot>y\<^sup>@(ka - 1)"
+    have "\<not> primitive (u \<cdot> y)"
+      unfolding u_def rassoc pow_Suc2[symmetric]  Suc_minus[OF \<open>ka \<noteq> 0\<close>] by fact
+    have "\<not> primitive (u \<cdot> y \<cdot> y)"
+      unfolding u_def rassoc using \<open>\<not> primitive(x\<^sup>@j\<cdot>y\<^sup>@ka')\<close>[unfolded \<open>x\<^sup>@j\<cdot>y\<^sup>@ka' = x\<^sup>@j\<cdot>y\<^sup>@ka\<cdot>y\<^sup>@dif\<close> \<open>dif = 1\<close> pow_one'] 
+      unfolding pow_Suc2[of y "ka - 1", unfolded Suc_minus[OF \<open>ka \<noteq> 0\<close>]] rassoc.
+    from imprim_ext_suf_comm[OF \<open>\<not> primitive (u \<cdot> y)\<close> \<open>\<not> primitive (u \<cdot> y \<cdot> y)\<close>]
+    have "(x \<^sup>@ j \<cdot> y \<^sup>@ (ka - 1)) \<cdot> y = y \<cdot> x \<^sup>@ j \<cdot> y \<^sup>@ (ka - 1)"
+      unfolding u_def.
+    thus "x \<cdot> y = y \<cdot> x"
+      using \<open>j \<noteq> 0\<close> by mismatch
+  next
+    assume "2 \<le> dif"
+    hence "\<not> primitive (y\<^sup>@dif)"..
+    from Lyndon_Schutzenberger_prim[OF \<open>\<not> primitive (x \<^sup>@ j \<cdot> y \<^sup>@ ka)\<close> this  \<open>\<not> primitive (x \<^sup>@ j \<cdot> y \<^sup>@ ka')\<close>[unfolded \<open>x \<^sup>@ j \<cdot> y \<^sup>@ ka' = x \<^sup>@ j \<cdot> y \<^sup>@ ka\<cdot> y\<^sup>@dif\<close> lassoc]]
+    show "x \<cdot> y = y \<cdot> x"
+      using \<open>dif \<noteq> 0\<close> \<open>j \<noteq> 0\<close> by mismatch
+  qed
+  thus False
+    using \<open>x \<cdot> y \<noteq> y \<cdot> x\<close> by blast
+qed
+
+lemma LS_unique_distinct_le: assumes "x \<cdot> y \<noteq> y \<cdot> x"
+  and "2 \<le> j" and "\<not> primitive(x\<^sup>@j\<cdot>y)" 
+  and "2 \<le> k" and "\<not> primitive(x\<cdot>y\<^sup>@k)"
+  and "\<^bold>|y\<^bold>| \<le> \<^bold>|x\<^bold>|"
+shows False
+proof-
+
+  obtain l z where [symmetric]:"z\<^sup>@l = x\<^sup>@j\<cdot>y" and "2 \<le> l"
+    using  not_prim_pow[OF \<open>\<not> primitive(x\<^sup>@j\<cdot>y)\<close>].
+  have "x\<^sup>@j\<cdot>y\<^sup>@1 = z\<^sup>@l"
+    by (simp add: \<open>x \<^sup>@ j \<cdot> y = z \<^sup>@ l\<close>)
+  interpret eq1: LS_len_le x y j 1 l z
+    using \<open>x \<cdot> y \<noteq> y \<cdot> x\<close> \<open>\<^bold>|y\<^bold>| \<le> \<^bold>|x\<^bold>|\<close> \<open>x\<^sup>@j\<cdot>y\<^sup>@1 = z\<^sup>@l\<close> \<open>2 \<le> l\<close> \<open>2 \<le> j\<close>
+    by(unfold_locales, linarith+)
+
+  from eq1.case_j2k1[OF \<open>2 \<le> j\<close>]
+  obtain r q t where
+    xrq: "(r \<cdot> q) \<^sup>@ (Suc (Suc t)) \<cdot> r = x" and
+    yrq: "q \<cdot> r \<cdot> r \<cdot> q  =  y" and
+    "(r \<cdot> q) \<^sup>@ (Suc (Suc t)) \<cdot> r \<cdot> r \<cdot> q = z" and
+    "j = 2" and "l = 2" and "r\<cdot>q \<noteq> q\<cdot>r" and
+    "primitive x" and "primitive y"
+    by blast
+
+  have "q\<cdot>r \<noteq> \<epsilon>" "r\<cdot>q \<noteq> \<epsilon>"
+    using eq1.bin_snd_nemp yrq by fastforce+
+
+  obtain z' l' where "x\<cdot>y\<^sup>@k = z'\<^sup>@l'" "2 \<le> l'"
+    using not_prim_pow[OF \<open>\<not> primitive (x \<cdot> y \<^sup>@ k)\<close>] by metis
+  have "l' \<noteq> 0" and "l' - 1 \<noteq> 0"
+    using \<open>2 \<le> l'\<close> by auto
+
+  have "k \<noteq> 0"
+    using \<open>2 \<le> k\<close> by linarith
+
+  let ?w = "(r \<cdot> q) \<^sup>@ (Suc (Suc t)) \<cdot> (r \<cdot> q) \<cdot> r" 
+
+  have "(r \<cdot> q) \<^sup>@ (Suc (Suc t)) \<cdot> (r \<cdot> q) \<cdot> r \<le>p ((r \<cdot> q) \<cdot> (r \<cdot> q) \<^sup>@ (Suc (Suc t))) \<cdot> (r \<cdot> q) \<cdot> r"
+    unfolding pow_comm[symmetric] rassoc pref_cancel_conv using triv_pref.
+  hence per1: "?w \<le>p (r \<cdot> q) \<cdot> ?w"
+    unfolding rassoc.
+
+  have "((r \<cdot> q) \<^sup>@ (Suc (Suc t)) \<cdot> r) \<cdot> q \<cdot> r \<le>p z'\<^sup>@l'"
+    unfolding \<open>x\<cdot>y\<^sup>@k = z'\<^sup>@l'\<close>[folded xrq yrq, unfolded rassoc, symmetric]
+    unfolding rassoc pop_pow_one[OF \<open>k \<noteq> 0\<close>]
+    by simp
+  hence per2: "?w \<le>p z' \<cdot> ?w"
+    using pref_prod_root by auto
+
+  have "(r \<cdot> q) \<cdot> z' \<noteq> z' \<cdot> (r \<cdot> q)"
+  proof
+    have "k \<noteq> 0"
+      using \<open>2 \<le> k\<close> by simp
+    have "y\<^sup>@k = y\<^sup>@Suc (k - 1)"
+      unfolding Suc_minus[OF \<open>k \<noteq> 0\<close>]..
+    assume "(r \<cdot> q) \<cdot> z' = z' \<cdot> (r \<cdot> q)"
+    hence "(r \<cdot> q) \<cdot> z'\<^sup>@l' = z'\<^sup>@l' \<cdot> r \<cdot> q"
+      by (simp add: power_commuting_commutes)
+    from this[folded \<open>x\<cdot>y\<^sup>@k = z'\<^sup>@l'\<close>[unfolded \<open>y\<^sup>@k = y\<^sup>@Suc (k - 1)\<close>] xrq yrq] 
+    have "q \<cdot> r = r \<cdot> q"
+      unfolding shifts by mismatch 
+    thus False
+      using \<open>r \<cdot> q \<noteq> q \<cdot> r\<close> by presburger
+  qed
+  with two_pers[OF _ per2, of "r\<cdot>q"] per1
+  have "\<^bold>|?w\<^bold>| < \<^bold>|r \<cdot> q\<^bold>| + \<^bold>|z'\<^bold>|"
+    unfolding rassoc using leI by blast
+  hence "\<^bold>|x\<^bold>| \<le> \<^bold>|z'\<^bold>|"
+    unfolding xrq[symmetric]
+    by simp
+  note eq2 = eqd[OF \<open>x\<cdot>y\<^sup>@k = z'\<^sup>@l'\<close>[unfolded pop_pow_one[OF \<open>l' \<noteq> 0\<close>]] this,
+      folded xrq, unfolded pow_Suc pop_pow_one'[OF \<open>l' - 1 \<noteq> 0\<close>]]
+  hence "z' \<le>s y\<^sup>@k" 
+    unfolding lassoc by blast
+  have  "r \<cdot> q \<cdot> r \<cdot> q \<le>p z'" 
+    using eq2 by force
+  hence "r\<cdot>q\<cdot>r\<cdot>q \<le>f (q\<cdot>r\<cdot>r\<cdot>q)\<^sup>@k"
+    using \<open>z' \<le>s y\<^sup>@k\<close>[folded yrq]
+    by blast
+
+  have "\<^bold>|r \<cdot> q \<cdot> r \<cdot> q\<^bold>| = \<^bold>|q \<cdot> r \<cdot> r \<cdot> q\<^bold>|"
+    by simp
+  from xyxy_conj_yxxy[OF fac_pow_len_conjug[OF this \<open>r\<cdot>q\<cdot>r\<cdot>q \<le>f (q\<cdot>r\<cdot>r\<cdot>q)\<^sup>@k\<close>, symmetric]]
+  have "r \<cdot> q = q \<cdot> r".
+  thus False
+    using \<open>r \<cdot> q \<noteq> q \<cdot> r\<close> by blast
+qed
+
+lemma LS_unique_distinct: assumes "x \<cdot> y \<noteq> y \<cdot> x"
+  and "2 \<le> j" and "\<not> primitive(x\<^sup>@j\<cdot>y)" 
+  and "2 \<le> k" and "\<not> primitive(x\<cdot>y\<^sup>@k)"
+shows False
+  using LS_unique_distinct_le[OF assms] LS_unique_distinct_le[reversed, OF assms(1,4-5,2-3)] by fastforce
+
+lemma LS_unique': assumes "x \<cdot> y \<noteq> y \<cdot> x"
+  and "1 \<le> j" and "1 \<le> k"  and "\<not> primitive(x\<^sup>@j\<cdot>y\<^sup>@k)" 
+  and "1 \<le> j'" and "1 \<le> k'"  and "\<not> primitive(x\<^sup>@j'\<cdot>y\<^sup>@k')"
+shows "k = k'"
+proof-
+  have "j = 1 \<or> k = 1"
+    using Lyndon_Schutzenberger_prim[OF pow_non_prim pow_non_prim,
+        OF _ _  \<open>\<not> primitive (x \<^sup>@ j \<cdot> y \<^sup>@ k)\<close>]
+      comm_drop_exps[of x "j - 1" y "k - 1", unfolded Suc_minus'[OF \<open>1 \<le> j\<close>] Suc_minus'[OF \<open>1 \<le> k\<close>]]
+      \<open>x \<cdot> y \<noteq> y \<cdot> x\<close> by blast
+
+  have "j' = 1 \<or> k' = 1"
+    using Lyndon_Schutzenberger_prim[OF pow_non_prim pow_non_prim,
+        OF _ _  \<open>\<not> primitive (x \<^sup>@ j' \<cdot> y \<^sup>@ k')\<close>]
+      comm_drop_exps[of x "j' - 1" y "k' - 1", unfolded Suc_minus'[OF \<open>1 \<le> j'\<close>] Suc_minus'[OF \<open>1 \<le> k'\<close>]]
+      \<open>x \<cdot> y \<noteq> y \<cdot> x\<close> by blast
+
+  show "k = k'"
+  proof (cases "j = j'")
+    assume "j = j'"
+    from LS_unique_same[OF assms(1-4,6,7)[folded this]]
+    show "k = k'".
+  next
+    assume "j \<noteq> j'"
+    show "k = k'"
+    proof(rule ccontr, cases "j = 1")
+      assume "k \<noteq> k'" and  "j = 1"
+      hence "2 \<le> j'" and "k' = 1" and "2 \<le> k"
+        using \<open>j \<noteq> j'\<close> \<open>1 \<le> j'\<close> \<open>k \<noteq> k'\<close> \<open>1 \<le> k\<close>  \<open>j' = 1 \<or> k' = 1\<close> by auto 
+      from LS_unique_distinct[OF \<open>x \<cdot> y \<noteq> y \<cdot> x\<close>  \<open>2 \<le> j'\<close> _ \<open>2 \<le> k\<close>]
+      show False
+        using \<open>\<not> primitive(x\<^sup>@j'\<cdot>y\<^sup>@k')\<close>[unfolded \<open>k'=1\<close> pow_one'] \<open>\<not> primitive(x\<^sup>@j\<cdot>y\<^sup>@k)\<close>[unfolded \<open>j=1\<close> pow_one']
+        by blast
+    next
+      assume "k \<noteq> k'" and  "j \<noteq> 1"
+      hence "2 \<le> j" and "k = 1" and "2 \<le> k'" and "j' = 1"
+        using \<open>1 \<le> j\<close> \<open>j = 1 \<or> k = 1\<close> \<open>1 \<le> k'\<close> \<open>j' = 1 \<or> k' = 1\<close> by auto 
+      from LS_unique_distinct[OF \<open>x \<cdot> y \<noteq> y \<cdot> x\<close> \<open>2 \<le> j\<close> _ \<open>2 \<le> k'\<close>] 
+      show False
+        using \<open>\<not> primitive(x\<^sup>@j'\<cdot>y\<^sup>@k')\<close>[unfolded \<open>j'=1\<close> pow_one'] \<open>\<not> primitive(x\<^sup>@j\<cdot>y\<^sup>@k)\<close>[unfolded \<open>k=1\<close> pow_one']
+        by blast
+    qed
+  qed
+qed
+
+lemma LS_unique: assumes "x \<cdot> y \<noteq> y \<cdot> x"
+  and "1 \<le> j" and "1 \<le> k"  and "\<not> primitive(x\<^sup>@j\<cdot>y\<^sup>@k)" 
+  and "1 \<le> j'" and "1 \<le> k'"  and "\<not> primitive(x\<^sup>@j'\<cdot>y\<^sup>@k')"
+shows "j = j'" and "k = k'" 
+  using  LS_unique'[OF \<open>x \<cdot> y \<noteq> y \<cdot> x\<close> 
+      \<open>1 \<le> j\<close> \<open>1 \<le> k\<close>  \<open>\<not> primitive (x \<^sup>@ j \<cdot> y \<^sup>@ k)\<close>
+      \<open>1 \<le> j'\<close> \<open>1 \<le> k'\<close> \<open>\<not> primitive (x \<^sup>@ j'\<cdot> y \<^sup>@ k')\<close>]
+    LS_unique'[reversed, OF \<open>x \<cdot> y \<noteq> y \<cdot> x\<close> 
+      \<open>1 \<le> k\<close> \<open>1 \<le> j\<close>   \<open>\<not> primitive (x \<^sup>@ j \<cdot> y \<^sup>@ k)\<close>
+      \<open>1 \<le> k'\<close> \<open>1 \<le> j'\<close> \<open>\<not> primitive (x \<^sup>@ j'\<cdot> y \<^sup>@ k')\<close>]
+  by blast+
+
 end
\ No newline at end of file
diff --git a/thys/Combinatorics_Words/Morphisms.thy b/thys/Combinatorics_Words/Morphisms.thy
new file mode 100644
--- /dev/null
+++ b/thys/Combinatorics_Words/Morphisms.thy
@@ -0,0 +1,1621 @@
+(*  Title:      Morphisms
+    File:       CoW.Morphisms
+    Author:     Štěpán Holub, Charles University
+
+Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/
+*)
+
+theory Morphisms
+
+imports CoWBasic Submonoids
+
+begin
+
+chapter "Morphisms"
+
+section \<open>One morphism\<close>
+
+subsection  \<open>Morphism, core map and extension\<close> 
+
+definition list_extension :: "('a \<Rightarrow> 'b list) \<Rightarrow> ('a list \<Rightarrow> 'b list)" ("_\<^sup>\<L>" [1000] 1000)
+  where "t\<^sup>\<L> \<equiv> (\<lambda> x. concat (map t x))"
+
+definition morphism_core :: "('a list \<Rightarrow> 'b list) \<Rightarrow> ('a  \<Rightarrow> 'b list)" ("_\<^sup>\<C>" [1000] 1000)
+  where core_def: "f\<^sup>\<C> \<equiv> (\<lambda> x. f [x])"
+
+lemma core_sing: "f\<^sup>\<C> a = f [a]" 
+  unfolding core_def..
+
+lemma range_map_core: "range (map f\<^sup>\<C>) = lists (range f\<^sup>\<C>)"
+    using lists_image[of "\<lambda>x. f [x]" UNIV, folded core_def, symmetric]
+    unfolding lists_UNIV. 
+
+lemma map_core_lists: "(map f\<^sup>\<C> w) \<in> lists (range f\<^sup>\<C>)"
+  by auto
+
+locale morphism_on = 
+  fixes f :: "'a list \<Rightarrow> 'b list" and A :: "'a list set"
+  assumes morph_on: "\<And> u v. u \<in> \<langle>A\<rangle> \<Longrightarrow> v \<in> \<langle>A\<rangle> \<Longrightarrow> f (u \<cdot> v) = f u \<cdot> f v"
+
+begin
+
+lemma emp_to_emp[simp]: "f \<epsilon> = \<epsilon>"
+  using morph_on[of \<epsilon> \<epsilon>] self_append_conv2[of "f \<epsilon>" "f \<epsilon>"] by simp
+
+lemma emp_to_emp': "w = \<epsilon> \<Longrightarrow> f w = \<epsilon>"
+  using morph_on[of \<epsilon> \<epsilon>] self_append_conv2[of "f \<epsilon>" "f \<epsilon>"] by simp
+
+lemma morph_concat_concat_map: "ws \<in> lists \<langle>A\<rangle> \<Longrightarrow> f (concat ws) = concat (map f ws)"
+  by (induct ws, simp_all add: morph_on hull_closed_lists)
+
+lemma hull_im_hull:
+  shows "\<langle>f ` A\<rangle> = f ` \<langle>A\<rangle>"
+proof
+  show " \<langle>f ` A\<rangle> \<subseteq> f ` \<langle>A\<rangle>"
+  proof (rule)
+    fix x 
+    show "x \<in> \<langle>f ` A\<rangle> \<Longrightarrow> x \<in> f ` \<langle>A\<rangle>"
+    proof (induction rule: hull.induct)
+      show "\<epsilon> \<in> f ` \<langle>A\<rangle>"
+        using  hull.emp_in emp_to_emp by force
+      show "w1 \<cdot> w2 \<in> f ` \<langle>A\<rangle>" if "w1 \<in> f ` A" and  "w2 \<in> f ` \<langle>A\<rangle>" for w1 w2 
+      proof- 
+        from that
+        obtain pre1 pre2 where "pre1 \<in> \<langle>A\<rangle>" and "pre2 \<in> \<langle>A\<rangle>" and "f pre1 = w1" and "f pre2 = w2"
+          using imageE by blast+ 
+        from hull_closed[OF this(1-2)] morph_on[OF \<open>pre1 \<in> \<langle>A\<rangle>\<close> \<open>pre2 \<in> \<langle>A\<rangle>\<close>, unfolded this(3-4)]
+        show "w1 \<cdot> w2 \<in> f ` \<langle>A\<rangle>"
+          by force  
+      qed
+    qed
+  qed
+  show "f ` \<langle>A\<rangle> \<subseteq> \<langle>f ` A\<rangle>" 
+  proof 
+    fix x
+    assume "x \<in> f ` \<langle>A\<rangle>"
+    then obtain xs where "f (concat xs) = x" and "xs \<in> lists A"
+      using hull_concat_lists0 by blast
+    from this[unfolded morph_concat_concat_map]
+        morph_concat_concat_map[OF genset_sub_lists[OF this(2)]] 
+    show "x \<in> \<langle>f ` A\<rangle>"
+      by fastforce
+  qed
+qed
+
+lemma inj_basis_to_basis: assumes "inj_on f \<langle>A\<rangle>"
+            shows "f ` (\<BB> \<langle>A\<rangle>) = \<BB> (f`\<langle>A\<rangle>)"
+proof
+  interpret basis: morphism_on f "\<BB> \<langle>A\<rangle>"
+    by (rule morph_on morphism_on.intro, unfold basis_gen_hull'[of A])
+    (simp only: morph_on) 
+  show "\<BB> (f ` \<langle>A\<rangle>) \<subseteq> f ` \<BB> \<langle>A\<rangle>"
+    using basis.hull_im_hull unfolding basis_gen_hull unfolding self_gen using basis_hull_sub[of "f ` \<BB> \<langle>A\<rangle>"] by argo  
+  show "f ` \<BB> \<langle>A\<rangle> \<subseteq> \<BB> (f ` \<langle>A\<rangle>)"
+  proof
+    fix x
+    assume "x \<in> f ` \<BB> \<langle>A\<rangle>"
+    then obtain y where "y \<in> \<BB> \<langle>A\<rangle>" and "x = f y" by blast
+    hence "x \<in> f ` \<langle>A\<rangle>"
+      using basis_sub by blast
+    from basis_concat_listsE[OF this]
+    obtain xs where "xs \<in> lists \<BB> (f `\<langle>A\<rangle>)" and "concat xs = x".
+    hence "\<epsilon> \<notin>  set xs"
+      using emp_not_basis  by blast 
+    have "xs \<in> lists (f `\<langle>A\<rangle>)"
+      using \<open>xs \<in> lists \<BB> (f `\<langle>A\<rangle>)\<close> basis_sub by blast 
+    then obtain ys where "map f ys = xs" and "ys \<in> lists \<langle>A\<rangle>"
+      unfolding lists_image by blast
+    have "\<epsilon> \<notin> set ys"       
+      using emp_to_emp \<open>\<epsilon> \<notin>  set xs\<close>
+       imageI[of \<epsilon> "set ys" f] unfolding list.set_map[of f ys, unfolded \<open>map f ys = xs\<close>] by presburger 
+    hence "ys \<in> lists \<langle>A\<rangle>\<^sub>+"
+      using \<open>ys \<in> lists \<langle>A\<rangle>\<close> by fast
+    have "f (concat ys) = x"
+      unfolding morph_concat_concat_map[OF \<open>ys \<in> lists \<langle>A\<rangle>\<close>] \<open>map f ys = xs\<close> by fact 
+    from \<open>inj_on f \<langle>A\<rangle>\<close> this[unfolded  \<open>x = f y\<close>]  
+    have "concat ys = y"
+      unfolding inj_on_def using subsetD[OF basis_sub \<open>y \<in> \<BB> \<langle>A\<rangle>\<close>] hull_closed_lists[OF \<open>ys \<in> lists \<langle>A\<rangle>\<close>] by blast
+    hence "\<^bold>|ys\<^bold>| = 1"  
+      using \<open>y \<in> \<BB> \<langle>A\<rangle>\<close>  \<open>ys \<in> lists \<langle>A\<rangle>\<^sub>+\<close> unfolding basis_def simple_element_def mem_Collect_eq by fast
+    hence "\<^bold>|xs\<^bold>| = 1"
+      using \<open>map f ys = xs\<close> by fastforce
+    with \<open>concat xs = x\<close> \<open>xs \<in> lists \<BB> (f `\<langle>A\<rangle>)\<close>
+    show "x \<in> \<BB> (f ` \<langle>A\<rangle>)"
+      using len_one_concat_in by blast
+  qed
+qed
+
+lemma inj_code_to_code: assumes "inj_on f \<langle>A\<rangle>" and "code A"
+            shows "code (f ` A)"
+proof
+  fix xs ys
+  assume "xs \<in> lists (f ` A)" and "ys \<in> lists (f ` A)"
+  then obtain xs' ys' where "xs' \<in> lists A" and "map f xs' = xs" and "ys' \<in> lists A" and "map f ys' = ys" 
+    unfolding lists_image by blast
+  assume "concat xs = concat ys"
+  hence "f (concat xs') = f (concat ys')"
+    by (simp add: \<open>map f xs' = xs\<close> \<open>map f ys' = ys\<close> \<open>xs' \<in> lists A\<close> \<open>ys' \<in> lists A\<close> genset_sub_lists morph_concat_concat_map)
+  hence "concat xs' = concat ys'"
+    using \<open>inj_on f \<langle>A\<rangle>\<close>[unfolded inj_on_def] \<open>xs' \<in> lists A\<close> \<open>ys' \<in> lists A\<close> by auto
+  hence "xs' = ys'"
+    using \<open>code A\<close>[unfolded code_def] \<open>xs' \<in> lists A\<close> \<open>ys' \<in> lists A\<close> by simp
+  thus "xs = ys"
+    using \<open>map f xs' = xs\<close> \<open>map f ys' = ys\<close> by blast
+qed
+
+end
+
+locale  morphism =
+  fixes f :: "'a list \<Rightarrow> 'b list"
+  assumes morph: "f (u \<cdot> v) = f u \<cdot> f v"
+begin
+
+sublocale morphism_on f UNIV
+  by (simp add: morph morphism_on.intro)
+
+lemma map_core_lists[simp]: "map f\<^sup>\<C> xs \<in> lists (range f\<^sup>\<C>)"
+  by auto
+
+lemma pow_morph: "f (x\<^sup>@k) = (f x)\<^sup>@k"
+  by (induction k) (simp add: morph)+
+
+lemma rev_map_pow:  "(rev_map f) (w\<^sup>@n) = rev ((f (rev w))\<^sup>@n)"
+  by (simp add: pow_morph rev_map_arg rev_pow)  
+
+lemma pop_hd: "f (a#u) = f [a] \<cdot> f u"
+  unfolding hd_word[of a u] using morph. 
+
+lemma pop_hd_nemp: "u \<noteq> \<epsilon> \<Longrightarrow> f (u) = f [hd u] \<cdot> f (tl u)"
+  using list.exhaust_sel pop_hd[of "hd u" "tl u"] by force
+
+lemma pop_last_nemp: "u \<noteq> \<epsilon> \<Longrightarrow> f (u) = f (butlast u) \<cdot> f [last u]"
+  unfolding morph[symmetric] append_butlast_last_id ..
+
+lemma pref_mono: "u \<le>p v \<Longrightarrow> f u \<le>p f v"
+  using morph by (auto simp add: prefix_def)
+
+lemma suf_mono: "u \<le>s v \<Longrightarrow> f u \<le>s f v"
+  using morph by (auto simp add: suf_def)
+
+lemma morph_concat_map: "concat (map f\<^sup>\<C> x) = f x"
+  unfolding core_def
+proof (induction x, simp)
+  case (Cons a x)
+  then show ?case 
+    unfolding pop_hd[of a x] by auto 
+qed
+
+lemma morph_concat_map': "(\<lambda> x. concat (map f\<^sup>\<C> x)) = f"
+  using morph_concat_map by simp
+
+lemma morph_to_concat: 
+  obtains xs where "xs \<in> lists (range f\<^sup>\<C>)" and "f x = concat xs"
+proof-
+  have "map f\<^sup>\<C> x \<in> lists (range f\<^sup>\<C>)"
+    by (simp add: lists_image)
+  from that[OF this morph_concat_map[symmetric]]
+  show thesis.
+qed  
+
+lemma range_hull: "range f = \<langle>(range f\<^sup>\<C>)\<rangle>"
+  using arg_cong[OF range_map_core[of f], of "image concat", unfolded image_comp, folded hull_concat_lists] morph_concat_map by auto
+
+lemma im_in_hull: "f w \<in> \<langle>(range f\<^sup>\<C>)\<rangle>"
+  using range_hull by blast
+
+lemma core_ext_id: "f\<^sup>\<C>\<^sup>\<L> = f"
+using morph_concat_map unfolding list_extension_def core_def by simp
+
+lemma  rev_map_morph: "morphism (rev_map f)"
+  by (standard, auto simp add: rev_map_def morph)
+
+lemma morph_rev_len:  "\<^bold>|f (rev u)\<^bold>| = \<^bold>|f u\<^bold>|"
+proof (induction u, simp)
+  case (Cons a u)
+  then show ?case 
+    unfolding rev.simps(2) pop_hd[of a u] morph lenmorph by force
+qed
+
+lemma  rev_map_len: "\<^bold>|rev_map f u\<^bold>| = \<^bold>|f u\<^bold>|"
+  unfolding rev_map_def
+  by (simp add: morph_rev_len) 
+
+lemma in_set_morph_len: assumes "a \<in> set w" shows "\<^bold>|f [a]\<^bold>| \<le> \<^bold>|f w\<^bold>|"
+proof-
+  from split_listE[OF assms]
+  obtain p s where "w = p \<cdot> [a] \<cdot> s".
+  from lenarg[OF arg_cong[of _ _ f, OF this], unfolded morph lenmorph]
+  show ?thesis by linarith
+qed
+
+lemma morph_lq_comm: "u \<le>p v \<Longrightarrow> f (u\<inverse>\<^sup>>v) = (f u)\<inverse>\<^sup>>(f v)"
+  using morph by (auto simp add: prefix_def)
+
+lemma morph_rq_comm: "v \<le>s u \<Longrightarrow> f (u\<^sup><\<inverse>v) = (f u)\<^sup><\<inverse>(f v)"
+  using morph by (auto simp add: suf_def)
+
+lemma code_set_morph: assumes c: "code (f\<^sup>\<C> `(set (u \<cdot> v)))" and i: "inj_on f\<^sup>\<C> (set (u \<cdot> v))"
+ and "f u = f v"
+  shows "u = v"
+proof-
+  let ?C = "f\<^sup>\<C> `(set (u \<cdot> v))"
+  interpret code ?C
+    using c by blast
+  have "(map f\<^sup>\<C> u) \<in> lists ?C" and "(map f\<^sup>\<C> v) \<in> lists ?C"
+    by (simp_all add: in_listsI)  
+  from is_code[OF this \<open>f u = f v\<close>[folded morph_concat_map]]
+  show "u = v"
+    using  inj_on_map_lists[OF i] unfolding inj_on_def
+    by (simp add: in_listsI)
+qed
+
+lemma morph_concat_concat_map: "f (concat ws) = concat (map f ws)"
+  by (induct ws, simp_all add: morph)
+
+lemma morph_on: "morphism_on f A"
+  unfolding morphism_on_def using morph by blast
+
+lemma noner_sings_conv: "(\<forall> w. w = \<epsilon> \<longleftrightarrow> f w = \<epsilon>) \<longleftrightarrow> (\<forall> a. f [a] \<noteq> \<epsilon>)"
+  by (rule, blast)
+   (metis Nil_is_append_conv emp_to_emp' hd_tlE pop_hd) 
+
+end
+
+lemma morph_map: "morphism (map f)"
+  by (simp add: morphism_def)
+
+lemma list_ext_morph: "morphism t\<^sup>\<L>"
+  unfolding list_extension_def by (simp add: morphism_def)
+
+lemma ext_def_on_set: "(\<And> a. a \<in> set u \<Longrightarrow> g a = f a) \<Longrightarrow> g\<^sup>\<L> u = f\<^sup>\<L> u"
+  unfolding list_extension_def using map_ext by metis
+
+lemma morph_def_on_set: "morphism f \<Longrightarrow> morphism g \<Longrightarrow> (\<And> a. a \<in> set u \<Longrightarrow> g\<^sup>\<C> a = f\<^sup>\<C> a) \<Longrightarrow> g u = f u"
+  using ext_def_on_set morphism.core_ext_id by metis
+
+lemma morph_compose: "morphism f \<Longrightarrow> morphism g \<Longrightarrow> morphism (f \<circ> g)"
+  by (simp add: morphism_def)
+
+subsection  \<open>Non-erasing morphism\<close>
+
+locale nonerasing_morphism = morphism  +
+  assumes nonerasing: "f w = \<epsilon> \<Longrightarrow> w = \<epsilon>"
+begin
+
+lemma core_nemp: "f\<^sup>\<C> a \<noteq> \<epsilon>"
+  unfolding core_def using nonerasing not_Cons_self2 by blast
+
+lemma nemp_to_nemp: "w \<noteq> \<epsilon> \<Longrightarrow> f w \<noteq> \<epsilon>"
+  using nonerasing by blast
+
+lemma sing_to_nemp: "f [a] \<noteq> \<epsilon>"
+  by (simp add: nemp_to_nemp) 
+
+lemma pref_morph_pref_eq: "u \<le>p v \<Longrightarrow> f v \<le>p f u \<Longrightarrow> u = v"
+  using nonerasing morph[of u "u\<inverse>\<^sup>>v"] unfolding prefix_def by fastforce 
+
+lemma rev_map_nonerasing: "nonerasing_morphism (rev_map f)"
+proof
+  show "rev_map f (u \<cdot> v) = rev_map f u \<cdot> rev_map f v" for u v
+    by (simp add: morphism.morph rev_map_morph)
+  show "rev_map f w = \<epsilon> \<Longrightarrow> w = \<epsilon>" for w
+    unfolding rev_map_arg using rev_is_Nil_conv nonerasing by fast
+qed
+
+lemma first_of_first: "(f (a # ws))!0 = f [a]!0"
+  unfolding pop_hd[of a ws] using  hd_prod[of "f[a]" "f ws", OF
+      nonerasing[of "[a]", THEN contrapos_nn[OF not_Cons_self2[of a \<epsilon>], of \<open>f (a # \<epsilon>) = \<epsilon>\<close>]]].
+
+lemma hd_im_hd_hd: assumes "u \<noteq> \<epsilon>" shows "hd (f u) = hd (f [hd u])"
+  unfolding hd_append2[OF sing_to_nemp] pop_hd_nemp[OF \<open>u \<noteq> \<epsilon>\<close>]..
+
+lemma ssuf_mono: "u <s v \<Longrightarrow> f u <s f v"
+  by (elim strict_suffixE')
+  (use morph sing_to_nemp ssufI1 suf_nemp in metis) 
+
+lemma im_len_le: "\<^bold>|u\<^bold>| \<le> \<^bold>|f u\<^bold>|"
+proof (induct u, simp)
+  case (Cons a u)
+  show ?case 
+    unfolding hd_word[of a u] morph lenmorph sing_len
+    by (rule add_mono[OF _ \<open>\<^bold>|u\<^bold>| \<le> \<^bold>|f u\<^bold>|\<close>], use nemp_le_len[OF sing_to_nemp] in force) 
+qed
+
+lemma im_len_eq_iff: "\<^bold>|u\<^bold>| = \<^bold>|f u\<^bold>| \<longleftrightarrow> (\<forall> c. c \<in> set u \<longrightarrow> \<^bold>|f [c]\<^bold>| = 1)"
+proof (induct u, simp)
+  case (Cons a u)
+  show ?case 
+  proof
+    assume "\<^bold>|a # u\<^bold>| = \<^bold>|f (a # u)\<^bold>|"
+    from this[unfolded  hd_word[of a u] morph lenmorph sing_len]
+    have "\<^bold>|f [a]\<^bold>| = 1" and "\<^bold>|u\<^bold>| = \<^bold>|f u\<^bold>|"
+      unfolding sing_len[of a, symmetric] using  im_len_le[of "[a]"] im_len_le[of u] by auto
+    from this(2)[unfolded Cons.hyps] this(1)
+    show "\<forall>c. c \<in> set (a # u) \<longrightarrow> \<^bold>|f [c]\<^bold>| = 1" by auto
+  next
+    assume "\<forall>c. c \<in> set (a # u) \<longrightarrow> \<^bold>|f [c]\<^bold>| = 1"
+    hence all: "\<forall>c. c \<in> set u \<longrightarrow> \<^bold>|f [c]\<^bold>| = 1" and "\<^bold>|f [a]\<^bold>| = 1"
+      by simp_all
+    show "\<^bold>|a # u\<^bold>| = \<^bold>|f (a # u)\<^bold>|"
+      unfolding hd_word[of a u] morph lenmorph sing_len \<open>\<^bold>|f [a]\<^bold>| = 1\<close> all[folded Cons.hyps]..
+  qed
+qed
+
+lemma im_len_less: "a \<in> set u \<Longrightarrow> \<^bold>|f [a]\<^bold>| \<noteq> 1 \<Longrightarrow> \<^bold>|u\<^bold>| < \<^bold>|f u\<^bold>|"
+  using im_len_le im_len_eq_iff order_le_neq_trans by auto 
+ 
+end
+
+lemma (in morphism) nonerI[intro]: assumes "(\<And> a. f\<^sup>\<C> a \<noteq> \<epsilon>)" 
+  shows "nonerasing_morphism f" 
+proof
+  from assms[unfolded core_def] noner_sings_conv
+  show "\<And>w. f w = \<epsilon> \<Longrightarrow> w = \<epsilon>" by presburger
+qed
+
+subsection \<open>Code morphism\<close>
+
+text \<open>The term ``Code morphism'' is equivalent to ``injective morphism''.\<close> 
+
+text \<open>Note that this is not equivalent to @{term "code (range f\<^sup>\<C>)"}, since the core can be not injective.\<close>
+
+lemma (in morphism) code_core_range_inj: "inj f \<longleftrightarrow> code (range f\<^sup>\<C>) \<and> inj f\<^sup>\<C>"
+proof
+  assume "inj f"
+  show "code (range f\<^sup>\<C>) \<and> inj f\<^sup>\<C>"
+  proof
+    show "inj f\<^sup>\<C>"
+      using \<open>inj f\<close> unfolding inj_on_def core_def by blast
+    show "code (range f\<^sup>\<C>)"
+    proof
+      show 
+        "xs \<in> lists (range f\<^sup>\<C>) \<Longrightarrow> ys \<in> lists (range f\<^sup>\<C>) \<Longrightarrow> concat xs = concat ys \<Longrightarrow> xs = ys" for xs ys
+        unfolding range_map_core[symmetric] using \<open>inj f\<close>[unfolded inj_on_def core_def] morph_concat_map
+        by force 
+    qed
+  qed
+next
+  assume "code (range f\<^sup>\<C>) \<and> inj f\<^sup>\<C>" hence "code (range f\<^sup>\<C>)" and "inj f\<^sup>\<C>" by blast+
+  show "inj f"
+  proof
+    fix x y assume "f x = f y"
+    with code.is_code[OF \<open>code (range f\<^sup>\<C>)\<close>, folded range_map_core, OF rangeI rangeI, unfolded morph_concat_map]  
+    have "map f\<^sup>\<C> x = map f\<^sup>\<C> y" by blast
+    with \<open>inj f\<^sup>\<C>\<close>  
+    show "x = y" by simp
+  qed
+qed
+
+locale code_morphism = morphism f for f + 
+   assumes code_morph: "inj f"
+
+begin
+
+lemma inj_core: "inj f\<^sup>\<C>" 
+  using code_morph unfolding core_def inj_on_def by blast
+
+lemma sing_im_core: "f [a] \<in> (range f\<^sup>\<C>)" 
+  unfolding core_def by simp
+
+lemma code_im: "code (range f\<^sup>\<C>)"
+  using code_morph morph_concat_map unfolding inj_on_def code_def core_def
+  unfolding lists_image lists_UNIV by fastforce
+
+sublocale code "range f\<^sup>\<C>"
+  using code_im.
+
+sublocale nonerasing_morphism
+   by (rule, simp add: in_code_nemp)
+
+lemma code_morph_code: assumes "f r = f s" shows "r = s" 
+proof-
+  from code.is_code[OF code_im, of "map f\<^sup>\<C> r" "map f\<^sup>\<C> s"]
+  have "map f\<^sup>\<C> r = map f\<^sup>\<C> s"
+    unfolding morph_concat_map using range_map_core assms by blast
+  thus "r = s"
+    unfolding inj_map_eq_map[OF inj_core].
+qed
+
+lemma code_morph_bij: "bij_betw f UNIV \<langle>(range f\<^sup>\<C>)\<rangle>"
+  unfolding bij_betw_def
+  by (rule, simp_all add: range_hull, rule, simp add: code_morph_code)
+
+lemma code_morphism_rev_map: "code_morphism (rev_map f)"
+  unfolding code_morphism_def code_morphism_axioms_def
+proof (rule conjI, simp add: rev_map_morph)
+  show "inj (rev_map f)"
+    using code_morph
+    unfolding inj_def rev_map_arg rev_is_rev_conv
+    using  rev_is_rev_conv by blast
+qed
+
+lemma morph_on_inj_on: 
+  "morphism_on f A" "inj_on f A"
+  using morph code_morph_code unfolding morphism_on_def inj_on_def 
+  by blast+
+
+end
+
+lemma code_morphismI: "morphism f \<Longrightarrow> inj f \<Longrightarrow> code_morphism f"
+  unfolding code_morphism_def code_morphism_axioms_def by blast  
+
+subsection \<open>Prefix code morphism\<close>
+
+locale pref_code_morphism = nonerasing_morphism  + 
+  assumes
+          pref_free: "f\<^sup>\<C> a \<le>p f\<^sup>\<C> b \<Longrightarrow> a = b"
+
+begin
+
+interpretation prefrange: pref_code "(range f\<^sup>\<C>)"
+  unfolding pref_code_def using core_nemp pref_free by fast
+
+lemma inj_core: "inj f\<^sup>\<C>" 
+  unfolding inj_on_def using pref_free by force
+
+sublocale code_morphism  
+proof
+  show "inj f"
+    unfolding inj_on_def
+  proof (standard+)
+    fix x y
+    assume "f x =  f y" 
+    hence "map f\<^sup>\<C> x = map f\<^sup>\<C> y"
+      using prefrange.is_code[folded range_map_core, of "map f\<^sup>\<C> x" "map f\<^sup>\<C> y"] 
+      unfolding morph_concat_map by fast 
+    with inj_core[folded inj_map[of "f\<^sup>\<C>"], unfolded inj_on_def]
+    show "x = y" 
+      by fast
+  qed
+qed
+
+thm nonerasing
+
+lemma pref_free_morph: assumes "f r \<le>p f s" shows "r \<le>p s" 
+  using assms
+proof (induction r s rule: list_induct2', simp)
+  case (2 x xs)
+  then show ?case
+    using emp_to_emp nonerasing prefix_bot.extremum_unique by auto
+next
+  case (3 y ys)
+  then show ?case 
+    using emp_to_emp nonerasing prefix_bot.extremum_unique by blast
+next
+  case (4 x xs y ys)
+  then show ?case 
+  proof-
+    have "f\<^sup>\<C> x \<le>p f\<^sup>\<C> y \<cdot> f ys"
+      unfolding core_def using "4.prems"[unfolded pop_hd[of x xs] pop_hd[of y ys], THEN  append_prefixD]. 
+    from ruler_pref'[OF this] prefrange.pref_free[OF rangeI rangeI] inj_core
+    have "x = y"  
+      unfolding inj_on_def by fastforce
+    show ?case
+      using "4.IH" "4.prems" unfolding  pop_hd[of x xs] pop_hd[of y ys]
+      unfolding \<open>x = y\<close> by fastforce 
+  qed
+qed
+
+end
+
+subsection \<open>Marked morphism\<close>
+
+locale marked_morphism = nonerasing_morphism  + 
+  assumes 
+          marked_core: "hd (f\<^sup>\<C> a) = hd (f\<^sup>\<C> b) \<Longrightarrow> a = b"
+
+begin
+
+lemma marked_im: "marked_code (range f\<^sup>\<C>)"
+  unfolding marked_code_def using image_iff marked_core core_nemp by fast
+
+interpretation marked_code "(range f\<^sup>\<C>)"
+  using marked_im.
+
+lemmas marked_morph = marked_core[unfolded core_sing]
+
+sublocale pref_code_morphism
+  by (unfold_locales, simp_all add: core_nemp marked_core pref_hd_eq)
+  
+lemma hd_im_eq_hd_eq: assumes "u \<noteq> \<epsilon>" and "v \<noteq> \<epsilon>"  and "hd (f u) = hd (f v)"  
+ shows "hd u = hd v"
+  using   marked_morph[OF \<open>hd (f u) = hd (f v)\<close>[unfolded hd_im_hd_hd[OF \<open>u \<noteq> \<epsilon>\<close>] hd_im_hd_hd[OF \<open>v \<noteq> \<epsilon>\<close>]]].
+
+lemma marked_morph_lcp: "f (r \<and>\<^sub>p s) = f r \<and>\<^sub>p f s"
+  by (simp add:
+      marked_concat_lcp[of "map f\<^sup>\<C> r" "map f\<^sup>\<C> s", unfolded map_lcp_conv[OF inj_core] morph_concat_map])
+
+lemma marked_inj_map: "inj e \<Longrightarrow> marked_morphism ((map e) \<circ> f)"
+  unfolding inj_on_def
+  by (unfold_locales, use morph in force, unfold core_def, simp add: core_nemp[unfolded core_def], use nemp_to_nemp in blast)
+   (rule marked_core[unfolded core_def], simp add: list.map_sel(1) sing_to_nemp)
+
+end
+
+thm morphism.nonerI
+
+lemma (in morphism) marked_morphismI:
+  "(\<And> a. f[a] \<noteq> \<epsilon>) \<Longrightarrow> (\<And> a b. a \<noteq> b) \<Longrightarrow> hd (f[a]) \<noteq> hd (f[b]) \<Longrightarrow> marked_morphism f" 
+  by (standard, blast, unfold core_def, blast)
+
+section \<open>Two morphisms\<close>
+
+text \<open>Solutions and the coincidence pairs are defined for any two mappings\<close>
+
+subsection \<open>Solutions\<close>
+
+definition minimal_solution :: "'a list \<Rightarrow> ('a list \<Rightarrow> 'b list) \<Rightarrow> ('a list \<Rightarrow> 'b list) \<Rightarrow> bool" ("_ \<in> _ =\<^sub>M _" [80,80,80] 51 )
+  where minsoldef:  "minimal_solution s g h \<equiv> s \<noteq> \<epsilon> \<and> g s = h s \<and> (\<forall> s'. s' \<le>np s \<and> g s' = h s' \<longrightarrow> s' = s)"
+
+lemma minsolD: "s \<in> g =\<^sub>M h \<Longrightarrow> g s = h s"
+  using minsoldef by blast
+
+lemma minsolD': "s \<in> g =\<^sub>M h \<Longrightarrow> s \<noteq> \<epsilon>"
+  using minsoldef by blast
+
+lemma minsolD_min: "s \<in> g =\<^sub>M h \<Longrightarrow> p \<noteq> \<epsilon> \<Longrightarrow> p \<le>p s \<Longrightarrow> g p = h p \<Longrightarrow> p = s"
+  by (simp add: minsoldef) 
+
+lemma minsolI: "s \<noteq> \<epsilon> \<Longrightarrow> g s = h s \<Longrightarrow> (\<And> s'. s' \<le>np s  \<Longrightarrow>  g s' = h s' \<Longrightarrow> s' = s) \<Longrightarrow> s \<in> g =\<^sub>M h"
+  using minsoldef by blast
+
+lemma minsol_sym_iff: "s \<in> g =\<^sub>M h  \<longleftrightarrow> s \<in> h =\<^sub>M g" 
+  unfolding minsoldef  eq_commute[of "g _" "h _"] by blast 
+
+lemma minsol_sym[sym]: "s \<in> g =\<^sub>M h  \<Longrightarrow> s \<in> h =\<^sub>M g" 
+  unfolding minsoldef eq_commute[of "g _"].
+
+lemma min_sol_prefE:
+  assumes "g r = h r" and "r \<noteq> \<epsilon>"  
+  obtains e where  "e \<in> g =\<^sub>M h" and "e \<le>p r"
+proof-
+  let ?P = "\<lambda> n. g (take (Suc n) r) = h (take (Suc n) r)"
+  define n where "n = (LEAST n. ?P n)"
+  define e where "e = take (Suc n) r"
+  hence "e \<le>p r"
+    using take_is_prefix by blast 
+  have "e \<noteq> \<epsilon>"
+    unfolding e_def using \<open>r \<noteq> \<epsilon>\<close> by simp
+  note * = Least_le[of ?P "\<^bold>|r\<^bold>| - 1", unfolded Suc_minus[OF nemp_len[OF \<open>r \<noteq> \<epsilon>\<close>]] take_self, OF \<open>g r = h r\<close>, folded n_def]
+  have "\<^bold>|e\<^bold>| = Suc n"
+   unfolding e_def by (rule take_len)
+   (use * Suc_le_mono Suc_minus'[OF nemp_le_len[OF \<open>r \<noteq> \<epsilon>\<close>]] in linarith) 
+  
+  have min: "s \<le>np e \<Longrightarrow> g s = h s \<Longrightarrow> s = e" for s
+  proof (rule ccontr)
+    assume "s \<le>np e" and "g s = h s" and "s \<noteq> e" 
+    have "\<^bold>|s\<^bold>| - 1 < n" 
+      using \<open>\<^bold>|e\<^bold>| = Suc n\<close>   long_pref[OF npD[OF \<open>s \<le>np e\<close>]] \<open>s \<noteq> e\<close>
+      Suc_le_lessD  nemp_le_len[OF npD'[OF \<open>s \<le>np e\<close>], THEN Suc_minus'] not_less_eq_eq by metis  
+    have "s = take (Suc (\<^bold>|s\<^bold>| - 1)) r"
+      unfolding Suc_minus Suc_minus[OF nemp_len[OF npD'[OF \<open>s \<le>np e\<close>]]]
+      using pref_trans[OF npD[OF \<open>s \<le>np e\<close>] \<open>e \<le>p r\<close>] using pref_take[of s r] by simp
+    from not_less_Least[of "\<^bold>|s\<^bold>| - 1" ?P, folded n_def this, OF \<open>\<^bold>|s\<^bold>| - 1 < n\<close>]   
+    show False
+      using \<open>g s = h s\<close> by blast
+  qed
+
+  from LeastI[of ?P "\<^bold>|r\<^bold>| - 1", unfolded Suc_minus[OF nemp_len[OF \<open>r \<noteq> \<epsilon>\<close>]] take_self, OF \<open>g r = h r\<close>]
+  have "g e = h e"
+    unfolding e_def n_def.
+  from minsolI[OF \<open>e \<noteq> \<epsilon>\<close>, of g h, OF this min]
+  have "e \<in> g =\<^sub>M h" by blast 
+  from that[OF this \<open>e \<le>p r\<close>]
+  show thesis.
+qed
+
+subsection \<open>Coincidence pairs\<close>
+
+definition coincidence_set :: "('a list \<Rightarrow> 'b list) \<Rightarrow> ('a list \<Rightarrow> 'b list) \<Rightarrow> ('a list \<times> 'a list) set" ("\<CC>")
+  where "coincidence_set g h \<equiv> {(r,s). g r = h s}"
+
+lemma coin_set_eq: "(g \<circ> fst)`(\<CC> g h) = (h \<circ> snd)`(\<CC> g h)"
+  unfolding coincidence_set_def comp_apply using Product_Type.Collect_case_prodD[of _ "\<lambda> x y. g x = h y"] image_cong by auto
+
+lemma coin_setD: "pair \<in> \<CC> g h \<Longrightarrow> g (fst pair) = h (snd pair)"
+  unfolding coincidence_set_def by force
+
+lemma coin_setD_iff: "pair \<in> \<CC> g h \<longleftrightarrow> g (fst pair) = h (snd pair)"
+  unfolding coincidence_set_def by force
+
+lemma coin_set_sym: "fst`(\<CC> g h) = snd `(\<CC> h g)" 
+  unfolding coincidence_set_def 
+  by (rule, rule, auto simp add: image_iff, metis) 
+
+lemma coin_set_inter_fst: "(g \<circ> fst)`(\<CC> g h) = range g \<inter> range h"
+proof
+  show "(g \<circ> fst) ` \<CC> g h \<subseteq> range g \<inter> range h"
+  proof
+    fix x assume "x \<in> (g \<circ> fst) ` \<CC> g h"
+    then obtain pair where "x = g (fst pair)" and "pair \<in> \<CC> g h" 
+      by force
+    from this(1)[unfolded coin_setD[OF this(2)]] this(1)
+    show "x \<in> range g \<inter> range h" by blast
+  qed
+next
+  show "range g \<inter> range h \<subseteq> (g \<circ> fst) ` \<CC> g h"
+  proof
+    fix x assume "x \<in> range g \<inter> range h"
+    then obtain r s where "g r = h s" and "x = g r" by blast
+    hence "(r,s) \<in> \<CC> g h"
+      unfolding coincidence_set_def by blast
+    thus "x \<in> (g \<circ> fst) ` \<CC> g h" 
+      unfolding \<open>x = g r\<close> by force
+  qed
+qed
+
+lemmas coin_set_inter_snd = coin_set_inter_fst[unfolded coin_set_eq]
+
+definition minimal_coincidence :: "('a list \<Rightarrow> 'b list) \<Rightarrow> 'a list \<Rightarrow> ('a list \<Rightarrow> 'b list) \<Rightarrow>  'a list \<Rightarrow> bool" ("(_ _) =\<^sub>m (_ _)" [80,81,80,81] 51 )
+  where min_coin_def:  "minimal_coincidence g r h s \<equiv> r \<noteq> \<epsilon> \<and> s \<noteq> \<epsilon> \<and> g r = h s \<and> (\<forall> r' s'. r' \<le>np r \<and> s' \<le>np s \<and> g r' = h s' \<longrightarrow> r' = r \<and> s' = s)"
+
+definition min_coincidence_set :: "('a list \<Rightarrow> 'b list) \<Rightarrow> ('a list \<Rightarrow> 'b list) \<Rightarrow> ('a list \<times> 'a list) set" ("\<CC>\<^sub>m")   
+  where "min_coincidence_set g h \<equiv> ({(r,s) . g r =\<^sub>m h s})"
+
+lemma min_coin_minD: "g r =\<^sub>m h s \<Longrightarrow> r' \<le>np r \<Longrightarrow> s' \<le>np s \<Longrightarrow>  g r' = h s' \<Longrightarrow> r' = r \<and> s' = s"
+  using min_coin_def by blast
+
+lemma min_coin_setD: "p \<in> \<CC>\<^sub>m g h \<Longrightarrow> g (fst p) =\<^sub>m h (snd p)"
+  unfolding min_coincidence_set_def by force
+
+lemma min_coinD: "g r =\<^sub>m h s \<Longrightarrow> g r = h s"
+  using min_coin_def by blast
+
+lemma min_coinD': "g r =\<^sub>m h s \<Longrightarrow> r \<noteq> \<epsilon> \<and> s \<noteq> \<epsilon>"
+  using min_coin_def by blast
+
+lemma min_coin_sub: "\<CC>\<^sub>m g h \<subseteq> \<CC> g h" 
+  unfolding coincidence_set_def min_coincidence_set_def
+  using  min_coinD by blast
+
+lemma min_coin_defI: assumes "r \<noteq> \<epsilon>" and "s \<noteq> \<epsilon>" and  "g r = h s" and 
+      "(\<And> r' s'. r' \<le>np r \<Longrightarrow> s' \<le>np s \<Longrightarrow> g r' = h s' \<Longrightarrow> r' = r \<and> s' = s)" 
+   shows "g r =\<^sub>m h s"
+  unfolding min_coin_def[rule_format] using assms by blast
+
+lemma min_coin_sym[sym]: "g r =\<^sub>m h s \<Longrightarrow> h s =\<^sub>m g r" 
+  unfolding min_coin_def eq_commute[of "g _" "h _"] by blast 
+
+lemma min_coin_sym_iff: "g r =\<^sub>m h s \<longleftrightarrow> h s =\<^sub>m g r"
+  using min_coin_sym by auto
+
+lemma min_coin_set_sym: "fst`(\<CC>\<^sub>m g h) = snd `(\<CC>\<^sub>m h g)" 
+  unfolding min_coincidence_set_def image_iff
+  by (rule, rule, simp add: image_iff min_coin_sym_iff) 
+     (rule, simp add: image_iff min_coin_sym_iff) 
+
+subsection \<open>Basics\<close>
+
+locale two_morphisms = g: morphism g + h: morphism h for g h :: "'a list \<Rightarrow> 'b list"
+
+begin
+
+lemma def_on_sings:
+  assumes "\<And>a. a \<in> set u \<Longrightarrow> g [a] = h [a]"
+  shows "g u = h u"
+using assms
+proof (induct u, simp)
+next
+  case (Cons a u)
+  then show ?case
+    unfolding g.pop_hd[of a u] h.pop_hd[of a u] using assms by simp
+qed
+
+lemma def_on_sings_eq:
+  assumes "\<And>a. g [a] = h [a]"
+  shows "g = h"
+  using def_on_sings[OF assms]
+  by (simp add: ext)
+
+lemma ims_prefs_comp:
+  assumes "u \<le>p u'" and "v \<le>p v'" and "g u' \<bowtie> h v'" shows  "g u \<bowtie> h v"
+  using ruler_comp[OF g.pref_mono h.pref_mono, OF assms].
+
+lemma ims_sufs_comp:
+  assumes "u \<le>s u'" and "v \<le>s v'" and "g u' \<bowtie>\<^sub>s h v'" shows  "g u \<bowtie>\<^sub>s h v"
+  using suf_ruler_comp[OF g.suf_mono h.suf_mono, OF assms].
+
+lemma ims_hd_eq_comp:
+  assumes "u \<noteq> \<epsilon>" and "g u = h u" shows "g [hd u] \<bowtie> h [hd u]"
+  using ims_prefs_comp[OF hd_pref[OF \<open>u \<noteq> \<epsilon>\<close>] hd_pref[OF \<open>u \<noteq> \<epsilon>\<close>]]
+  unfolding \<open>g u = h u\<close> by blast
+
+lemma ims_last_eq_suf_comp:
+  assumes "u \<noteq> \<epsilon>" and "g u = h u" shows "g [last u] \<bowtie>\<^sub>s h [last u]"
+  using ims_sufs_comp[OF hd_pref[reversed, OF \<open>u \<noteq> \<epsilon>\<close>] hd_pref[reversed, OF \<open>u \<noteq> \<epsilon>\<close>]]
+  unfolding \<open>g u = h u\<close> using comp_refl[reversed] by blast
+
+lemma len_im_le:
+  assumes "(\<And>a. a \<in> set s \<Longrightarrow> \<^bold>|g [a]\<^bold>| \<le> \<^bold>|h [a]\<^bold>|)"
+  shows "\<^bold>|g s\<^bold>| \<le> \<^bold>|h s\<^bold>|"
+using assms proof (induction s)
+  case (Cons a s)
+    have IH_prem: "\<And>a. a \<in> set s \<Longrightarrow> \<^bold>|g [a]\<^bold>| \<le> \<^bold>|h [a]\<^bold>|" using Cons.prems by simp
+    show "\<^bold>|g (a # s)\<^bold>| \<le> \<^bold>|h (a # s)\<^bold>|"
+      unfolding g.pop_hd[of _ s] h.pop_hd[of _ s] lenmorph
+      using Cons.prems[of a, simplified] Cons.IH[OF IH_prem]
+      by (rule add_le_mono)
+qed simp
+
+lemma len_im_less:
+  assumes "\<And>a. a \<in> set s \<Longrightarrow> \<^bold>|g [a]\<^bold>| \<le> \<^bold>|h [a]\<^bold>|" and
+          "b \<in> set s" and "\<^bold>|g [b]\<^bold>| < \<^bold>|h [b]\<^bold>|"
+  shows "\<^bold>|g s\<^bold>| < \<^bold>|h s\<^bold>|"
+using assms proof (induction s arbitrary: b)
+  case (Cons a s)
+    have IH_prem: "\<And>a. a \<in> set s \<Longrightarrow> \<^bold>|g [a]\<^bold>| \<le> \<^bold>|h [a]\<^bold>|" using Cons.prems(1)[OF list.set_intros(2)].
+    note split = g.pop_hd[of _ s] h.pop_hd[of _ s] lenmorph
+    show "\<^bold>|g (a # s)\<^bold>| < \<^bold>|h (a # s)\<^bold>|"
+    proof (cases)
+      assume "a = b" show "\<^bold>|g (a # s)\<^bold>| < \<^bold>|h (a # s)\<^bold>|"
+        unfolding split \<open>a = b\<close> using \<open>\<^bold>|g [b]\<^bold>| < \<^bold>|h [b]\<^bold>|\<close> len_im_le[OF IH_prem]
+        by (rule add_less_le_mono)
+    next
+      assume "a \<noteq> b"
+      then have "b \<in> set s" using \<open>b \<in> set (a # s)\<close> by simp
+      show "\<^bold>|g (a # s)\<^bold>| < \<^bold>|h (a # s)\<^bold>|"
+        unfolding split using Cons.prems(1)[OF list.set_intros(1)]
+          Cons.IH[OF IH_prem \<open>b \<in> set s\<close> \<open>\<^bold>|g [b]\<^bold>| < \<^bold>|h [b]\<^bold>|\<close>]
+        by (rule add_le_less_mono)
+    qed
+qed simp
+
+lemma solution_eq_len_eq:
+  assumes "g s = h s" and "\<And>a. a \<in> set s \<Longrightarrow> \<^bold>|g [a]\<^bold>| = \<^bold>|h [a]\<^bold>|"
+  shows "\<And>a. a \<in> set s \<Longrightarrow> g [a] = h [a]"
+using assms proof (induction s)
+  case (Cons b s)
+  have nemp: "b # s \<noteq> \<epsilon>" using list.distinct(2).
+  from ims_hd_eq_comp[OF nemp \<open>g (b # s) = h (b # s)\<close>] Cons.prems(3)[OF list.set_intros(1)]
+  have *: "g [b] = h [b]" unfolding list.sel(1) by (fact pref_comp_eq)
+  moreover have "g s = h s"
+    using \<open>g (b # s) = h (b # s)\<close>
+    unfolding g.pop_hd_nemp[OF nemp] h.pop_hd_nemp[OF nemp] list.sel * ..
+  from Cons.IH[OF _ this Cons.prems(3)[OF list.set_intros(2)]]
+  have "a \<in> set s \<Longrightarrow> g [a] = h [a]" for a.
+  ultimately show "\<And>a. a \<in> set (b # s) \<Longrightarrow> g [a] = h [a]" by auto
+qed auto
+
+lemma rev_maps: "two_morphisms (rev_map g) (rev_map h)"
+  using g.rev_map_morph h.rev_map_morph by (intro two_morphisms.intro)
+
+lemma minsol_rev: 
+  assumes "s \<in> g =\<^sub>M h"
+  shows "(rev s) \<in> (rev_map g) =\<^sub>M (rev_map h)"
+proof (rule minsolI)
+  show "rev s \<noteq> \<epsilon>"
+    using minsolD'[OF \<open>s \<in> g =\<^sub>M h\<close>] by simp
+  show "rev_map g (rev s) = rev_map h (rev s)" 
+    unfolding rev_map_def using minsolD[OF \<open>s \<in> g =\<^sub>M h\<close>] by auto
+next
+  fix s'
+  assume "s' \<le>np rev s" and "rev_map g s' = rev_map h s'"
+  hence "g (rev s') = h (rev s')"
+    unfolding rev_map_def  by simp       
+  obtain s'' where "s = s''\<cdot> rev s'"
+    using  npD[OF \<open>s' \<le>np rev s\<close>, unfolded pref_rev_suf_iff rev_rev_ident] by (auto simp add: suf_def)   
+  hence "s'' \<noteq> s" 
+    using npD'[OF \<open>s' \<le>np rev s\<close>] by simp
+  have "g (rev s') = h (rev s')"
+    by (simp add: \<open>g (rev s') = h (rev s')\<close>) 
+  hence  "g s'' = h s''"
+    using  minsolD[OF \<open>s \<in> g =\<^sub>M h\<close>, unfolded \<open>s = s''\<cdot> rev s'\<close> h.morph g.morph] by simp 
+  hence "s'' = \<epsilon>" 
+    using \<open>s'' \<noteq> s\<close> \<open>s \<in> g =\<^sub>M h\<close>[unfolded minsoldef] \<open>s = s''\<cdot> rev s'\<close> by blast
+  thus  "s' = rev s"
+    by (simp add: \<open>s = s'' \<cdot> rev s'\<close>)
+qed     
+
+lemma coin_set_lists_concat: "ps \<in> lists (\<CC> g h) \<Longrightarrow> g (concat (map fst ps)) = h (concat (map snd ps))"
+  unfolding coincidence_set_def
+  by (induct ps, simp, auto simp add: g.morph h.morph)
+
+lemma coin_set_hull: "\<langle>snd `(\<CC> g h)\<rangle> = snd `(\<CC> g h)" 
+proof (rule equalityI, rule subsetI)
+  fix x assume "x \<in> \<langle>snd ` \<CC> g h\<rangle>"
+  then obtain xs where "xs \<in> lists (snd ` \<CC> g h)" and "concat xs = x"
+    using hull_concat_lists0 by blast 
+  then obtain ps where "ps \<in> lists (\<CC> g h)" and "map snd ps = xs"
+    unfolding image_iff lists_image by blast
+  from coin_set_lists_concat[OF this(1), unfolded this(2) \<open>concat xs = x\<close>]
+  show "x \<in> snd ` \<CC> g h"
+    unfolding coincidence_set_def by force
+qed simp  
+
+lemma min_sol_sufE:
+  assumes "g r = h r" and "r \<noteq> \<epsilon>"  
+  obtains e where  "e \<in> g =\<^sub>M h" and "e \<le>s r"
+  using assms
+proof (induction "\<^bold>|r\<^bold>|" arbitrary: r thesis rule: less_induct)
+    case less
+    then show thesis
+    proof-
+     from min_sol_prefE[of g r h, OF \<open>g r = h r\<close> \<open>r \<noteq> \<epsilon>\<close>] 
+  obtain p where "p \<in> g =\<^sub>M h" and "p \<le>p r".
+  show thesis
+    proof (cases "p = r", (use less.prems(1)[OF \<open>p \<in> g =\<^sub>M h\<close>] in fast))
+      assume "p \<noteq> r"
+      from prefE[OF \<open>p \<le>p r\<close>]
+      obtain r' where "r = p \<cdot> r'".
+      have "g r' = h r'" 
+        using \<open>g r = h r\<close>[unfolded \<open>r = p \<cdot> r'\<close> g.morph h.morph minsolD[OF \<open>p \<in> g =\<^sub>M h\<close>] cancel]. 
+      from \<open>p \<noteq> r\<close> \<open>r = p \<cdot> r'\<close> 
+      have "r' \<noteq> \<epsilon>" by fast 
+      from minsolD'[OF \<open>p \<in> g =\<^sub>M h\<close>] \<open>r = p \<cdot> r'\<close>
+      have "\<^bold>|r'\<^bold>| < \<^bold>|r\<^bold>|" by fastforce
+      from less.hyps[OF this _ \<open>g r' = h r'\<close> \<open>r' \<noteq> \<epsilon>\<close>]
+      obtain e where "e \<in> g =\<^sub>M h" "e \<le>s r'".
+      from less.prems(1)[OF this(1), unfolded \<open>r = p \<cdot> r'\<close>, OF suf_ext, OF this(2)] 
+      show thesis. 
+    qed
+  qed
+qed
+
+lemma min_sol_primitive: assumes "sol \<in> g =\<^sub>M h" shows "primitive sol"
+proof (rule ccontr)
+  have "sol \<noteq> \<epsilon>" 
+    using assms minsoldef by auto 
+  assume "\<not> primitive sol"
+  from not_prim_primroot_expE[OF this \<open>sol\<noteq> \<epsilon>\<close>] 
+  obtain k where "(\<rho> sol)\<^sup>@(Suc (Suc k)) = sol".
+  with minsolD[OF assms] 
+  have "g (\<rho> sol) = h (\<rho> sol)"
+    using Suc_pow_eq_eq g.pow_morph h.pow_morph by metis
+  thus False
+    using \<open>\<not> primitive sol\<close> \<open>sol \<noteq> \<epsilon>\<close> assms minsolD_min prim_primroot_conv by blast 
+qed
+
+end
+
+subsection \<open>Two nonerasing morphisms\<close>
+
+text \<open>Minimal coincidence pairs and minimal solutions make good sense for nonerasing morphisms only.\<close>
+
+locale two_nonerasing_morphisms = two_morphisms + 
+  g: nonerasing_morphism g  + 
+  h: nonerasing_morphism h 
+
+begin
+
+thm g.morph
+thm g.emp_to_emp
+
+lemma two_nonerasing_morphisms_swap: "two_nonerasing_morphisms h g"
+  by unfold_locales
+
+lemma noner_eq_emp_iff: "g u = h v \<Longrightarrow> u = \<epsilon> \<longleftrightarrow> v = \<epsilon>"
+  by (metis g.emp_to_emp g.nonerasing h.emp_to_emp h.nonerasing)
+
+lemma min_coin_rev: 
+  assumes "g r =\<^sub>m h s"
+  shows "(rev_map g) (rev r) =\<^sub>m (rev_map h) (rev s)"
+proof (rule min_coin_defI)
+  show "rev r \<noteq> \<epsilon>" and "rev s \<noteq> \<epsilon>"
+    using min_coinD'[OF \<open>g r =\<^sub>m h s\<close>] by simp_all
+  show "rev_map g (rev r) = rev_map h (rev s)" 
+    unfolding rev_map_def using min_coinD[OF \<open>g r =\<^sub>m h s\<close>] by auto
+next 
+  fix r' s' assume "r' \<le>np rev r" "s' \<le>np rev s" "rev_map g r' = rev_map h s'" 
+  then obtain r'' s'' where "r''\<cdot> rev r' = r" and "s''\<cdot> rev s' = s" 
+    using npD[OF \<open>s' \<le>np rev s\<close>] npD[OF \<open>r' \<le>np rev r\<close>]
+    unfolding pref_rev_suf_iff rev_rev_ident using sufD by (auto simp add: suf_def)
+  have "g (rev r') = h (rev s')"
+    using \<open>rev_map g r' = rev_map h s'\<close>[unfolded rev_map_def rev_is_rev_conv] by simp 
+  hence "g r'' = h s''" 
+    using min_coinD[OF \<open>g r =\<^sub>m h s\<close>, folded \<open>r''\<cdot> rev r' = r\<close> \<open>s''\<cdot> rev s' = s\<close>,
+        unfolded  g.morph h.morph] by simp
+  have "r'' \<noteq> r"
+    using \<open>r' \<le>np rev r\<close> \<open>r'' \<cdot> rev r' = r\<close> by auto  
+  hence "r'' = \<epsilon> \<or> s'' = \<epsilon>"
+    using \<open>g r =\<^sub>m h s\<close>[unfolded min_coin_def nonempty_prefix_def]
+      \<open>r''\<cdot> rev r' = r\<close> \<open>s''\<cdot> rev s' = s\<close> \<open>g r'' = h s''\<close>
+    by blast
+  hence "r'' = \<epsilon>" and  "s'' = \<epsilon>" 
+    using noner_eq_emp_iff[OF \<open>g r'' = h s''\<close>] by force+
+  thus "r' = rev r \<and> s' = rev s"
+    using  \<open>r''\<cdot> rev r' = r\<close> \<open>s''\<cdot> rev s' = s\<close> by auto
+qed
+
+lemma min_coin_pref_eq:  
+  assumes "g e =\<^sub>m h f" and "g e' = h f'" and "e' \<le>np e" and "f' \<bowtie> f"
+  shows "e' = e" and "f' = f"
+proof-
+  note npD'[OF \<open>e' \<le>np e\<close>] npD[OF \<open>e' \<le>np e\<close>]
+  have "f \<noteq> \<epsilon>" and "g e  = h f"
+    using \<open>g e =\<^sub>m h f\<close>[unfolded min_coin_def] by blast+
+  have "f' \<noteq> \<epsilon>" 
+    using \<open>g e' = h f'\<close> \<open>e' \<noteq> \<epsilon>\<close> by (simp add: noner_eq_emp_iff) 
+  from g.pref_mono[OF \<open>e' \<le>p e\<close>, unfolded \<open>g e = h f\<close> \<open>g e' = h f'\<close>] 
+  have "f' \<le>p f"
+    using pref_compE[OF \<open>f' \<bowtie> f\<close>] \<open>f' \<noteq> \<epsilon>\<close> h.pref_mono h.pref_morph_pref_eq  by metis             
+  hence "f' \<le>np f"
+    using \<open>f' \<noteq> \<epsilon>\<close> by blast
+  with \<open>g e =\<^sub>m h f\<close>[unfolded min_coin_def]
+  show "e' = e" and "f' = f"
+    using \<open>g e' = h f'\<close> \<open>e' \<le>np e\<close> by blast+ 
+qed  
+
+lemma min_coin_prefE:
+  assumes "g r = h s" and "r \<noteq> \<epsilon>"  
+  obtains e f where  "g e =\<^sub>m h f" and "e \<le>p r" and  "f \<le>p s" and "hd e = hd r"
+proof-
+  define P where "P = (\<lambda> k. \<exists> e f. g e = h f \<and> e \<noteq> \<epsilon> \<and>  e \<le>p r \<and> f \<le>p s \<and> \<^bold>|e\<^bold>| = k)"
+  define d where "d = (LEAST k. P k)"
+  obtain e f where "g e = h f" and "e \<noteq> \<epsilon>" and  "e \<le>p r" and  "f \<le>p s" and "\<^bold>|e\<^bold>| = d"
+    using \<open>g r = h s\<close> LeastI[of P "\<^bold>|r\<^bold>|"]  P_def assms(2) d_def by blast
+  hence "f \<noteq> \<epsilon>"
+    using noner_eq_emp_iff by blast 
+  have "r' \<le>np e \<Longrightarrow> s' \<le>np f \<Longrightarrow> g r' = h s' \<Longrightarrow> r' = e \<and> s' = f" for r' s'
+  proof-
+    assume "r' \<le>np e" and "s' \<le>np f" and "g r' = h s'" 
+    hence "P \<^bold>|r'\<^bold>|" 
+      unfolding P_def using \<open>e \<le>p r\<close> \<open>f \<le>p s\<close> npD'[OF \<open>r' \<le>np e\<close>]
+          pref_trans[OF npD[OF \<open>r' \<le>np e\<close>] \<open>e \<le>p r\<close>]
+          pref_trans[OF npD[OF \<open>s' \<le>np f\<close>] \<open>f \<le>p s\<close>] by blast
+    from Least_le[of P, OF this, folded \<open>\<^bold>|e\<^bold>| = d\<close> d_def]
+    have "r' = e"
+      using  long_pref[OF npD[OF \<open>r' \<le>np e\<close>]] by blast 
+    from \<open>g e = h f\<close>[folded this, unfolded \<open>g r' = h s'\<close>] this
+    show  ?thesis
+      using conjunct2[OF \<open>s' \<le>np f\<close>[unfolded nonempty_prefix_def]] h.pref_morph_pref_eq 
+      by simp
+  qed
+  hence "g e =\<^sub>m h f"
+    unfolding min_coin_def using \<open>e \<noteq> \<epsilon>\<close> \<open>f \<noteq> \<epsilon>\<close> \<open>g e = h f\<close> by blast
+  from that[OF this \<open>e \<le>p r\<close> \<open>f \<le>p s\<close> pref_hd_eq[OF \<open>e \<le>p r\<close> \<open>e \<noteq> \<epsilon>\<close>]]
+  show thesis.
+qed
+
+lemma min_coin_dec: assumes "g e = h f" 
+  obtains ps where "concat (map fst ps) = e" and "concat (map snd ps) = f" and
+    "\<And> p. p \<in> set ps \<Longrightarrow> g (fst p) =\<^sub>m h (snd p)"
+  using assms
+proof (induct "\<^bold>|e\<^bold>|" arbitrary: e f thesis rule: less_induct)
+  case less
+  then show ?case 
+  proof-
+    show thesis
+    proof (cases "e = \<epsilon>")
+      assume "e = \<epsilon>"
+      hence "f = \<epsilon>" using \<open>g e = h f\<close>
+        using noner_eq_emp_iff by auto
+      from less.prems(1)[of \<epsilon>] \<open>e = \<epsilon>\<close> \<open>f = \<epsilon>\<close>
+      show thesis by simp
+    next
+      assume "e \<noteq> \<epsilon>"
+      from min_coin_prefE[OF \<open>g e  = h f\<close> this]  
+      obtain e\<^sub>1 e\<^sub>2 f\<^sub>1 f\<^sub>2 where "g e\<^sub>1 =\<^sub>m h f\<^sub>1" and "e\<^sub>1 \<cdot> e\<^sub>2 = e" and "f\<^sub>1 \<cdot> f\<^sub>2 = f" and "e\<^sub>1 \<noteq> \<epsilon>" and "f\<^sub>1 \<noteq> \<epsilon>"
+        using min_coinD' prefD by metis
+      have "g e\<^sub>2 = h f\<^sub>2"
+        using \<open>g e  = h f\<close>[folded \<open>e\<^sub>1 \<cdot> e\<^sub>2 = e\<close> \<open>f\<^sub>1 \<cdot> f\<^sub>2 = f\<close>, unfolded g.morph h.morph min_coinD[OF \<open>g e\<^sub>1 =\<^sub>m h f\<^sub>1\<close>] cancel].
+      have "\<^bold>|e\<^sub>2\<^bold>| < \<^bold>|e\<^bold>|"
+        using lenarg[OF \<open>e\<^sub>1 \<cdot> e\<^sub>2 = e\<close>] nemp_pos_len[OF \<open>e\<^sub>1 \<noteq> \<epsilon>\<close>] unfolding lenmorph by linarith  
+      from less.hyps[OF \<open>\<^bold>|e\<^sub>2\<^bold>| < \<^bold>|e\<^bold>|\<close> _ \<open>g e\<^sub>2 = h f\<^sub>2\<close>]
+      obtain ps' where "concat (map fst ps') = e\<^sub>2" and "concat (map snd ps') = f\<^sub>2" and "\<And>p. p \<in> set ps' \<Longrightarrow> g (fst p) =\<^sub>m h (snd p)"
+        by blast
+      show thesis 
+      proof(rule less.prems(1)[of "(e\<^sub>1,f\<^sub>1)#ps'"])
+        show "concat (map fst ((e\<^sub>1, f\<^sub>1) # ps')) = e"
+          using \<open>concat (map fst ps') = e\<^sub>2\<close> \<open>e\<^sub>1 \<cdot> e\<^sub>2 = e\<close> by simp
+        show "concat (map snd ((e\<^sub>1, f\<^sub>1) # ps')) = f"
+          using \<open>concat (map snd ps') = f\<^sub>2\<close> \<open>f\<^sub>1 \<cdot> f\<^sub>2 = f\<close> by simp
+        show "\<And>p. p \<in> set ((e\<^sub>1, f\<^sub>1) # ps') \<Longrightarrow> g (fst p) =\<^sub>m h (snd p)"
+          using \<open>\<And>p. p \<in> set ps' \<Longrightarrow> g (fst p) =\<^sub>m h (snd p)\<close> \<open>g e\<^sub>1 =\<^sub>m h f\<^sub>1\<close> by auto
+      qed
+    qed
+  qed
+qed
+
+lemma min_coin_code:
+  assumes "xs \<in> lists (\<CC>\<^sub>m g h)" and "ys \<in> lists (\<CC>\<^sub>m g h)" and 
+           "concat (map fst xs) = concat (map fst ys)" and
+           "concat (map snd xs) = concat (map snd ys)"
+         shows "xs = ys"
+  using assms
+proof (induction xs ys rule: list_induct2', simp)
+  case (2 x xs)
+  then show ?case 
+    using min_coin_setD[THEN min_coinD', of x g h] listsE[OF \<open>x # xs \<in> lists (\<CC>\<^sub>m g h)\<close>] by force 
+next
+  case (3 y ys)
+  then show ?case
+    using min_coin_setD[of y g h, THEN min_coinD'] listsE[OF \<open>y # ys \<in> lists (\<CC>\<^sub>m g h)\<close>]  by auto
+next
+  case (4 x xs y ys)   
+  then show ?case
+  proof-
+    have "concat (map fst (x#xs)) = fst x \<cdot> concat (map fst xs)" 
+         "concat (map fst (y#ys)) = fst y \<cdot> concat (map fst ys)"
+         "concat (map snd (x#xs)) = snd x \<cdot> concat (map snd xs)" 
+         "concat (map snd (y#ys)) = snd y \<cdot> concat (map snd ys)"
+      by auto 
+    from eqd_comp[OF \<open>concat (map fst (x#xs)) = concat (map fst (y#ys))\<close>[unfolded this]] eqd_comp[OF \<open>concat (map snd (x#xs)) = concat (map snd (y#ys))\<close>[unfolded this]] 
+    have "fst x \<bowtie> fst y" and "snd x \<bowtie> snd y".
+    have "g (fst y) =\<^sub>m h (snd y)" and "g (fst x) =\<^sub>m h (snd x)"
+      by  (use min_coin_setD  listsE[OF \<open>y # ys \<in> lists (\<CC>\<^sub>m g h)\<close>] in blast)
+          (use  min_coin_setD listsE[OF \<open>x # xs \<in> lists (\<CC>\<^sub>m g h)\<close>] in blast)
+    from min_coin_pref_eq[OF this(1) min_coinD[OF this(2)] _ \<open>snd x \<bowtie> snd y\<close>]
+         min_coin_pref_eq[OF this(2) min_coinD[OF this(1)] _ pref_comp_sym[OF \<open>snd x \<bowtie> snd y\<close>]] min_coinD'[OF this(1)] min_coinD'[OF this(2)]
+    have "fst x = fst y" and "snd x = snd y" 
+      using  npI pref_compE[OF \<open>fst x \<bowtie> fst y\<close>] by metis+ 
+    hence eq: "concat (map fst xs) = concat (map fst ys)"
+                  "concat (map snd xs) = concat (map snd ys)"
+      using "4.prems"(3-4) by fastforce+ 
+    have "xs \<in> lists (\<CC>\<^sub>m g h)" "ys \<in> lists (\<CC>\<^sub>m g h)"  
+      using "4.prems"(1-2) by fastforce+
+    from "4.IH"(1)[OF this eq] prod_eqI[OF \<open>fst x = fst y\<close> \<open>snd x = snd y\<close>]
+    show "x # xs = y # ys"
+      by blast    
+  qed
+qed
+
+lemma  coin_closed: "ps \<in> lists (\<CC> g h) \<Longrightarrow> (concat (map fst ps), concat (map snd ps)) \<in> \<CC> g h"
+  unfolding coincidence_set_def
+  by (induct ps, simp, auto simp add: g.morph h.morph)
+
+lemma min_coin_gen_snd: "\<langle>snd ` (\<CC>\<^sub>m g h)\<rangle> = snd `(\<CC> g h)"
+proof
+  show "\<langle>snd ` \<CC>\<^sub>m g h\<rangle> \<subseteq> snd ` \<CC> g h"
+  proof
+    fix x assume "x \<in> \<langle>snd ` \<CC>\<^sub>m g h\<rangle>"
+    then obtain xs where "xs \<in> lists (snd ` \<CC>\<^sub>m g h)" and "x = concat xs"
+      using hull_concat_lists0 by blast
+    then obtain ps where "ps \<in> lists (\<CC>\<^sub>m g h)" and "xs = map snd ps"
+      unfolding lists_image image_iff by blast
+    from min_coin_sub coin_closed this(1) 
+    have "(concat (map fst ps), x) \<in> \<CC> g h"
+       unfolding \<open>x = concat xs\<close> \<open>xs = map snd ps\<close> by fast
+    thus "x \<in> snd ` \<CC> g h" by force 
+  qed
+  show "snd ` \<CC> g h \<subseteq> \<langle>snd ` \<CC>\<^sub>m g h\<rangle>"
+  proof
+    fix x assume "x \<in> snd ` \<CC> g h"
+    then obtain r where "g r = h x"
+      unfolding image_iff coincidence_set_def by force
+    from min_coin_dec[OF this]
+    obtain ps where "concat (map snd ps) = x" and "\<And>p. p \<in> set ps \<Longrightarrow> g (fst p) =\<^sub>m h (snd p)" by metis
+    thus "x \<in> \<langle>snd ` \<CC>\<^sub>m g h\<rangle>"
+      unfolding min_coincidence_set_def image_def by fastforce
+  qed
+qed
+
+lemma min_coin_gen_fst: "\<langle>fst ` (\<CC>\<^sub>m g h)\<rangle> = fst `(\<CC> g h)"
+  using two_nonerasing_morphisms.min_coin_gen_snd[folded coin_set_sym min_coin_set_sym, OF two_nonerasing_morphisms_swap].      
+
+lemma min_coin_code_snd: 
+  assumes "code_morphism g" shows "code (snd ` (\<CC>\<^sub>m g h))"
+proof
+  fix xs ys assume "xs \<in> lists (snd ` \<CC>\<^sub>m g h)" and "ys \<in> lists (snd ` \<CC>\<^sub>m g h)"
+  then obtain psx psy where "psx \<in> lists (\<CC>\<^sub>m g h)" and "xs = map snd psx" and
+                            "psy \<in> lists (\<CC>\<^sub>m g h)" and "ys = map snd psy"
+    unfolding image_iff lists_image by blast+
+  have eq1: "g (concat (map fst psx)) = h (concat xs)"
+    using \<open>psx \<in> lists (\<CC>\<^sub>m g h)\<close> \<open>xs = map snd psx\<close> min_coin_sub[of g h]
+    coin_set_lists_concat by fastforce 
+  have eq2: "g (concat (map fst psy)) = h (concat ys)"
+    using \<open>psy \<in> lists (\<CC>\<^sub>m g h)\<close> \<open>ys = map snd psy\<close> min_coin_sub[of g h]
+    coin_set_lists_concat by fastforce 
+  assume "concat xs = concat ys"  
+  from arg_cong[OF this, of h, folded eq1 eq2]
+  have "concat (map fst psx) = concat (map fst psy)"
+    using code_morphism.code_morph_code[OF \<open>code_morphism g\<close>] by auto
+  have "concat (map snd psx) = concat (map snd psy)"
+    using \<open>concat xs = concat ys\<close> \<open>xs = map snd psx\<close> \<open>ys = map snd psy\<close> by auto
+  from min_coin_code[OF \<open>psx \<in> lists (\<CC>\<^sub>m g h)\<close> \<open>psy \<in> lists (\<CC>\<^sub>m g h)\<close> \<open>concat (map fst psx) = concat (map fst psy)\<close> this] 
+  show  "xs = ys"
+    unfolding \<open>xs = map snd psx\<close> \<open>ys = map snd psy\<close> by blast
+ qed
+
+lemma min_coin_code_fst: 
+  "code_morphism h \<Longrightarrow> code (fst ` (\<CC>\<^sub>m g h))"
+    using two_nonerasing_morphisms.min_coin_code_snd[OF two_nonerasing_morphisms_swap, folded min_coin_set_sym]. 
+
+lemma min_coin_basis_snd: 
+  assumes "code_morphism g"
+  shows "\<BB> (snd `(\<CC> g h)) = snd ` (\<CC>\<^sub>m g h)"
+  unfolding min_coin_gen_snd[symmetric] basis_of_hull
+  using min_coin_code_snd[OF assms] code.code_is_basis by blast  
+
+lemma min_coin_basis_fst:
+  "code_morphism h \<Longrightarrow> \<BB> (fst `(\<CC> g h)) = fst ` (\<CC>\<^sub>m g h)"
+  using two_nonerasing_morphisms.min_coin_basis_snd[folded coin_set_sym min_coin_set_sym, OF two_nonerasing_morphisms_swap].
+
+lemma sol_im_len_less: assumes "g u = h u" and "g \<noteq> h" and "set u = UNIV"
+  shows "\<^bold>|u\<^bold>| < \<^bold>|g u\<^bold>|"
+proof (rule ccontr)
+  assume "\<not> \<^bold>|u\<^bold>| < \<^bold>|g u\<^bold>|"
+  hence "\<^bold>|u\<^bold>| = \<^bold>|g u\<^bold>|" and "\<^bold>|u\<^bold>| = \<^bold>|h u\<^bold>|"
+    unfolding \<open>g u = h u\<close> using h.im_len_le le_neq_implies_less by blast+ 
+  from this(1)[unfolded g.im_len_eq_iff] this(2)[unfolded h.im_len_eq_iff] \<open>set u = UNIV\<close>
+  have "\<^bold>|g [c]\<^bold>| = 1" and "\<^bold>|h [c]\<^bold>| = 1" for c by blast+
+  hence "g  = h"
+    using solution_eq_len_eq[OF \<open>g u = h u\<close>, THEN  def_on_sings_eq, unfolded \<open>set u = UNIV\<close>, OF _ UNIV_I]
+    by force
+  thus False using \<open>g \<noteq> h\<close> by contradiction 
+qed
+
+end
+
+locale two_code_morphisms = g: code_morphism g + h: code_morphism h
+  for g h :: "'a list \<Rightarrow> 'b list"
+
+begin
+
+sublocale two_nonerasing_morphisms g h
+  by unfold_locales
+
+lemmas code_morphs = g.code_morphism_axioms h.code_morphism_axioms  
+
+lemma revs_two_code_morphisms: "two_code_morphisms (rev_map g) (rev_map h)"
+  by (simp add: g.code_morphism_rev_map h.code_morphism_rev_map two_code_morphisms.intro)
+
+lemma min_coin_im_basis:
+  "\<BB> (h` (snd `(\<CC> g h))) = h ` snd ` (\<CC>\<^sub>m g h)"
+        "\<BB> (g` (fst `(\<CC> g h))) = g ` fst ` (\<CC>\<^sub>m g h)"
+proof-
+  thm   morphism_on.inj_basis_to_basis
+        code_morphism.morph_on_inj_on
+        min_coin_basis_snd
+
+  note basis_morph_swap = morphism_on.inj_basis_to_basis[OF code_morphism.morph_on_inj_on, symmetric]
+  thm basis_morph_swap
+      coin_set_hull
+      basis_morph_swap[OF code_morphs(2) code_morphs(2), of "snd ` \<CC> g h",   unfolded coin_set_hull]
+  show "\<BB> (h ` snd ` \<CC> g h) = h ` snd ` \<CC>\<^sub>m g h"
+    unfolding basis_morph_swap[OF code_morphs(2) code_morphs(2), of "snd ` \<CC> g h",   unfolded coin_set_hull]
+    unfolding min_coin_basis_snd[OF code_morphs(1)]..
+
+  interpret swap: two_code_morphisms h g
+    using two_code_morphisms_def code_morphs by blast
+  
+  thm basis_morph_swap[OF code_morphs(1) code_morphs(1), of "fst ` \<CC> g h"]
+      swap.coin_set_hull
+      coin_set_hull
+      coin_set_sym
+      swap.coin_set_hull[folded coin_set_sym]
+      basis_morph_swap[OF code_morphs(1) code_morphs(1), of "fst ` \<CC> g h", unfolded swap.coin_set_hull[folded coin_set_sym]]
+      min_coin_basis_fst
+
+  show "\<BB> (g ` fst ` \<CC> g h) = g ` fst ` \<CC>\<^sub>m g h"
+    unfolding basis_morph_swap[OF code_morphs(1) code_morphs(1), of "fst ` \<CC> g h", unfolded swap.coin_set_hull[folded coin_set_sym]]
+    unfolding min_coin_basis_fst[OF code_morphs(2)] 
+    unfolding min_coin_gen_fst..
+qed
+
+lemma range_inter_basis_snd:
+  shows "\<BB> (range g \<inter> range h) = h ` (snd ` \<CC>\<^sub>m g h)"
+        "\<BB> (range g \<inter> range h) = g ` (fst ` \<CC>\<^sub>m g h)"
+proof-
+  show "\<BB> (range g \<inter> range h) = h ` (snd ` \<CC>\<^sub>m g h)"
+  unfolding coin_set_inter_snd[folded image_comp, symmetric]
+  using  min_coin_im_basis(1).
+  show "\<BB> (range g \<inter> range h) = g ` (fst ` \<CC>\<^sub>m g h)"
+  unfolding coin_set_inter_fst[folded image_comp, symmetric]
+  using min_coin_im_basis(2).
+qed
+
+lemma range_inter_code: 
+  shows  "code \<BB> (range g \<inter> range h)" 
+  unfolding range_inter_basis_snd  
+  thm morphism_on.inj_code_to_code
+  by (rule morphism_on.inj_code_to_code) 
+   (simp_all add:  h.morph_on  h.morph_on_inj_on(2) code_morphs(1) min_coin_code_snd)
+
+end
+
+subsection \<open>Two marked morphisms\<close>
+
+locale two_marked_morphisms = two_nonerasing_morphisms + 
+       g: marked_morphism g +  h: marked_morphism h
+
+begin
+
+sublocale revs: two_code_morphisms g h
+  by (simp add: g.code_morphism_axioms h.code_morphism_axioms two_code_morphisms.intro) 
+
+lemmas ne_g = g.nonerasing and
+       ne_h = h.nonerasing
+
+lemma unique_continuation:
+  "z \<cdot> g r = z' \<cdot> h s \<Longrightarrow>  z \<cdot> g r' = z' \<cdot> h s' \<Longrightarrow> z \<cdot> g (r \<and>\<^sub>p r') = z' \<cdot> h (s \<and>\<^sub>p s')"
+  using lcp_ext_left g.marked_morph_lcp h.marked_morph_lcp by metis
+
+lemmas empty_sol = noner_eq_emp_iff
+
+lemma comparable_min_sol_eq: assumes "r \<le>p r'" and "g r =\<^sub>m h s" and "g r' =\<^sub>m h s'" 
+  shows  "r = r'" and "s = s'"
+proof-
+  have "s \<le>p s'"                                                 
+    using  g.pref_mono[OF \<open>r \<le>p r'\<close>] 
+           h.pref_free_morph
+    unfolding min_coinD[OF \<open>g r =\<^sub>m h s\<close>] min_coinD[OF \<open>g r' =\<^sub>m h s'\<close>] by simp 
+  thus "r = r'"and "s = s'" 
+    using \<open>g r' =\<^sub>m h s'\<close>[unfolded  min_coin_def] min_coinD[OF \<open>g r =\<^sub>m h s\<close>] min_coinD'[OF \<open>g r =\<^sub>m h s\<close>] \<open>r \<le>p r'\<close>
+     by blast+    
+qed
+
+lemma first_letter_determines:
+  assumes "g e =\<^sub>m h f" and "g e' = h f'" and "hd e = hd e'" and "e' \<noteq> \<epsilon>"
+  shows "e \<le>p e'" and  "f \<le>p f'"
+proof-
+  have "g (e \<and>\<^sub>p e') = h (f \<and>\<^sub>p f')"
+    using unique_continuation[of \<epsilon> e \<epsilon> f e' f', unfolded clean_emp, OF min_coinD[OF\<open>g e =\<^sub>m h f\<close>] \<open>g e' = h f'\<close>]. 
+  have "e \<noteq> \<epsilon>"
+    using \<open>g e =\<^sub>m h f\<close> min_coinD' by auto
+  hence eq1: "e = [hd e] \<cdot> tl e" and eq2: "e' = [hd e'] \<cdot> tl e'" using \<open>e' \<noteq> \<epsilon>\<close> by simp+
+  from lcp_ext_left[of "[hd e]" "tl e" "tl e'", folded  eq1 eq2[folded \<open>hd e = hd e'\<close>]]
+  have "e \<and>\<^sub>p e' \<noteq> \<epsilon>" by force
+  from this
+  have "f \<and>\<^sub>p f' \<noteq> \<epsilon>"
+    using \<open>g (e \<and>\<^sub>p e') = h (f \<and>\<^sub>p f')\<close> g.nonerasing h.emp_to_emp by force
+  from npI[OF \<open>e \<and>\<^sub>p e' \<noteq> \<epsilon>\<close> lcp_pref] npI[OF \<open>f \<and>\<^sub>p f' \<noteq> \<epsilon>\<close> lcp_pref]
+  show  "e \<le>p e'" and  "f \<le>p f'"
+    using min_coin_minD[OF assms(1) \<open>e \<and>\<^sub>p e' \<le>np e\<close> \<open>f \<and>\<^sub>p f' \<le>np f\<close> \<open>g (e \<and>\<^sub>p e') = h (f \<and>\<^sub>p f')\<close>, 
+          unfolded lcp_sym[of e] lcp_sym[of f]] lcp_pref by metis+
+qed
+
+corollary first_letter_determines':
+  assumes "g e =\<^sub>m h f" and "g e' =\<^sub>m h f'" and "hd e = hd e'"
+  shows "e = e'" and "f = f'"
+proof-
+  have "e \<noteq> \<epsilon>" and "e' \<noteq> \<epsilon>"
+     using \<open>g e =\<^sub>m h f\<close> \<open>g e' =\<^sub>m h f'\<close> min_coinD' by blast+
+   have "g e' = h f'" and "g e = h f"
+     using \<open>g e =\<^sub>m h f\<close> \<open>g e' =\<^sub>m h f'\<close> min_coinD by blast+
+   show "e = e'" and "f = f'" 
+    using first_letter_determines[OF \<open>g e =\<^sub>m h f\<close> \<open>g e' = h f'\<close> \<open>hd e = hd e'\<close> \<open>e' \<noteq> \<epsilon>\<close>]
+          first_letter_determines[OF \<open>g e' =\<^sub>m h f'\<close> \<open>g e = h f\<close> \<open>hd e = hd e'\<close>[symmetric] \<open>e \<noteq> \<epsilon>\<close>]
+    by force+
+qed
+
+definition pre_block :: "'a \<Rightarrow> 'a list \<times> 'a list" 
+  where  "pre_block a = (THE p. (g (fst p) =\<^sub>m h (snd p)) \<and> hd (fst p) = a)"
+\<comment> \<open>@{term "pre_block a"} may not be a block, if no such exists\<close>
+
+definition blockP :: "'a \<Rightarrow> bool"
+  where  "blockP a \<equiv> g (fst (pre_block a)) =\<^sub>m h (snd (pre_block a)) \<and> hd (fst (pre_block a)) = a"
+\<comment> \<open>Predicate: the @{term pre_block} of the letter @{term a} is indeed a block\<close>
+
+lemma pre_blockI: "g u =\<^sub>m h v \<Longrightarrow> pre_block (hd u) = (u,v)"
+  unfolding pre_block_def
+proof (rule the_equality, simp)
+  show "\<And>p. g u =\<^sub>m h v \<Longrightarrow> g (fst p) =\<^sub>m h (snd p) \<and> hd (fst p) = hd u \<Longrightarrow> p = (u, v)"
+    using first_letter_determines' by force
+qed
+
+lemma blockI: assumes "g u =\<^sub>m h v" and "hd u = a" 
+  shows "blockP a"
+proof-
+  from pre_blockI[OF \<open>g u =\<^sub>m h v\<close>, unfolded \<open>hd u = a\<close>]
+  show "blockP a"
+    unfolding blockP_def using assms by simp
+qed
+
+lemma hd_im_comm_eq_aux:
+  assumes "g w = h w" and "w \<noteq> \<epsilon>" and comm: "g\<^sup>\<C> (hd w) \<cdot> h\<^sup>\<C>(hd w) = h\<^sup>\<C> (hd w) \<cdot> g\<^sup>\<C>(hd w)" and len: "\<^bold>|g\<^sup>\<C> (hd w)\<^bold>| \<le> \<^bold>|h\<^sup>\<C>(hd w)\<^bold>|"
+  shows "g\<^sup>\<C> (hd w) = h\<^sup>\<C> (hd w)"
+proof(cases "w \<in> [hd w]*")
+  assume  "w \<in> [hd w]*"
+  then obtain l where "w = [hd w]\<^sup>@l"
+    unfolding root_def by metis
+  from nemp_exp_pos[OF \<open>w \<noteq> \<epsilon>\<close>, of "[hd w]" l, folded this]
+  have "l \<noteq> 0"
+    by fast 
+  from \<open>g w = h w\<close>
+  have "(g [hd w])\<^sup>@l = (h [hd w])\<^sup>@l"
+    unfolding g.pow_morph[symmetric] h.pow_morph[symmetric] \<open>w = [hd w]\<^sup>@l\<close>[symmetric].
+  with \<open>l \<noteq> 0\<close>
+  have "g [hd w] = h [hd w]"
+    using pow_eq_eq by blast 
+  thus "g\<^sup>\<C> (hd w) = h\<^sup>\<C> (hd w)"
+    unfolding core_def.
+next
+  assume  "w \<notin> [hd w]*"
+  from distinct_letter_in_hd[OF this]
+  obtain b l w' where "[hd w]\<^sup>@l \<cdot> [b] \<cdot> w' = w" and "b \<noteq> hd w" and "l \<noteq> 0".
+  from commE[OF comm]
+  obtain t m k where "g\<^sup>\<C> (hd w) = t\<^sup>@m" and "h\<^sup>\<C> (hd w) = t\<^sup>@k".
+  have "\<^bold>|t\<^bold>| \<noteq> 0" and "t \<noteq> \<epsilon>" and "m \<noteq> 0"
+    using \<open>g\<^sup>\<C> (hd w) = t\<^sup>@m\<close> g.core_nemp pow_zero[of t] by (fastforce, fastforce, metis)  
+  with lenarg[OF \<open>g\<^sup>\<C> (hd w) = t\<^sup>@m\<close>] lenarg[OF \<open>h\<^sup>\<C> (hd w) = t\<^sup>@k\<close>]
+  have "m \<le> k"
+    unfolding pow_len lenmorph using len by auto
+  have "m = k"
+  proof(rule ccontr)
+    assume "m \<noteq> k" hence "m < k" using \<open>m \<le> k\<close> by simp
+    have "k*l-m*l \<noteq> 0"
+      using \<open>m < k\<close> \<open>l \<noteq> 0\<close> by force
+    have "g w = t\<^sup>@(m*l) \<cdot> g [b] \<cdot> g w'"
+      unfolding arg_cong[OF \<open>[hd w]\<^sup>@l \<cdot> [b] \<cdot> w' = w\<close>, of g, symmetric] g.morph
+        g.pow_morph  \<open>g\<^sup>\<C> (hd w) = t\<^sup>@m\<close>[unfolded core_def] pow_mult[symmetric]..
+    moreover have "h w = t\<^sup>@(k*l) \<cdot> h [b] \<cdot> h w'"
+      unfolding arg_cong[OF \<open>[hd w]\<^sup>@l \<cdot> [b] \<cdot> w' = w\<close>, of h, symmetric] h.morph
+        h.pow_morph  \<open>h\<^sup>\<C> (hd w) = t\<^sup>@k\<close>[unfolded core_def] pow_mult[symmetric]..
+    ultimately have "g [b] \<cdot>  g w' = t\<^sup>@(k*l-m*l) \<cdot> h [b] \<cdot> h w'" 
+      using \<open>g w = h w\<close> pop_pow_cancel[OF _ mult_le_mono1[OF \<open>m \<le> k\<close>]]
+      unfolding  g.morph[symmetric] h.morph[symmetric] by metis 
+    hence "hd t = hd (g [b])"
+      using \<open>t \<noteq> \<epsilon>\<close> \<open>k * l - m * l \<noteq> 0\<close> h.emp_to_emp h.sing_to_nemp hd_append2 hd_pow noner_eq_emp_iff nonzero_pow_emp by metis  
+    have "hd t = hd (g [hd w])"
+      using g.hd_im_hd_hd[OF \<open>w \<noteq> \<epsilon>\<close>, unfolded  \<open>g\<^sup>\<C> (hd w) = t \<^sup>@ m\<close>[unfolded core_def]]
+            hd_append2[OF \<open>t \<noteq> \<epsilon>\<close>, of "t\<^sup>@(m-1)", unfolded pow_Suc, folded pow_Suc[of t "m-1", unfolded Suc_minus[OF \<open>m \<noteq> 0\<close>]]] 
+            g.hd_im_hd_hd[OF \<open>w \<noteq> \<epsilon>\<close>] by force
+    thus False
+      unfolding \<open>hd t = hd (g [b])\<close> using \<open>b \<noteq> hd w\<close> g.marked_morph by blast
+  qed
+  show "g\<^sup>\<C> (hd w) = h\<^sup>\<C> (hd w)"
+    unfolding \<open>g\<^sup>\<C> (hd w) = t\<^sup>@m\<close> \<open>h\<^sup>\<C> (hd w) = t\<^sup>@k\<close> \<open>m = k\<close>..
+qed
+ 
+lemma hd_im_comm_eq:
+  assumes "g w = h w" and "w \<noteq> \<epsilon>" and comm: "g\<^sup>\<C> (hd w) \<cdot> h\<^sup>\<C>(hd w) = h\<^sup>\<C> (hd w) \<cdot> g\<^sup>\<C>(hd w)"
+  shows "g\<^sup>\<C> (hd w) = h\<^sup>\<C> (hd w)"
+proof-
+  interpret swap: two_marked_morphisms h g by unfold_locales
+  show "g\<^sup>\<C> (hd w) = h\<^sup>\<C> (hd w)" 
+  using hd_im_comm_eq_aux[OF assms] swap.hd_im_comm_eq_aux[OF assms(1)[symmetric] assms(2) assms(3)[symmetric], symmetric]
+  by force
+qed
+
+lemma block_ex: assumes "g u =\<^sub>m h v"  shows "blockP (hd u)"
+  unfolding blockP_def using pre_blockI[OF assms] assms by simp
+ 
+lemma sol_block_ex: assumes "g u = h v" and "u \<noteq> \<epsilon>"  shows "blockP (hd u)"
+  using min_coin_prefE[OF assms]  block_ex by metis
+
+\<comment> \<open>Successor morphisms\<close>
+
+definition suc_fst where  "suc_fst  \<equiv> \<lambda> x. concat(map (\<lambda> y. fst (pre_block y)) x)" 
+definition suc_snd where  "suc_snd  \<equiv> \<lambda> x. concat(map (\<lambda> y. snd (pre_block y)) x)" 
+
+lemma blockP_D: "blockP a \<Longrightarrow> g (suc_fst [a]) =\<^sub>m h (suc_snd [a])"
+  unfolding blockP_def suc_fst_def suc_snd_def by simp
+
+lemma blockP_D_hd: "blockP a \<Longrightarrow> hd (suc_fst [a]) = a"
+  unfolding blockP_def suc_fst_def by simp
+                            
+abbreviation "blocks \<tau> \<equiv> (\<forall> a. a \<in> set \<tau> \<longrightarrow> blockP a)" 
+
+sublocale sucs: two_morphisms suc_fst suc_snd
+  by (standard)  (simp_all add: suc_fst_def suc_snd_def)
+
+(* sublocale sg: morphism suc_fst *)
+  (* by unfold_locales (simp add: suc_fst_def) *) 
+
+(* sublocale sh: morphism suc_snd *)
+  (* by unfold_locales (simp add: suc_snd_def) *) 
+
+lemma blockP_D_hd_hd: assumes "blockP a"
+  shows "hd (h\<^sup>\<C> (hd (suc_snd [a]))) = hd (g\<^sup>\<C> a)"
+proof-
+  from hd_tlE[OF conjunct2[OF min_coinD'[OF blockP_D[OF \<open>blockP a\<close>]]]]
+  obtain b where "hd (suc_snd [a]) = b" by blast
+  have "suc_fst [a] \<noteq> \<epsilon>" and "suc_snd [a] \<noteq> \<epsilon>"
+   using min_coinD'[OF  blockP_D[OF \<open>blockP a\<close>]] by blast+
+  from  g.hd_im_hd_hd[OF this(1)] h.hd_im_hd_hd[OF this(2)]  
+  have "hd (h\<^sup>\<C> (hd (suc_snd [a]))) = hd (g\<^sup>\<C> (hd (suc_fst [a])))"
+    unfolding core_def min_coinD[OF  blockP_D[OF \<open>blockP a\<close>]] by argo 
+  thus ?thesis
+    unfolding blockP_D_hd[OF assms].
+qed
+
+lemma suc_morph_sings: assumes "g e =\<^sub>m h f"
+  shows "suc_fst [hd e] = e" and "suc_snd [hd e] = f" 
+  unfolding suc_fst_def suc_snd_def using pre_blockI[OF assms] by simp_all
+
+lemma blocks_eq: "blocks \<tau> \<Longrightarrow> g (suc_fst \<tau>)  = h (suc_snd \<tau>)"
+proof (induct \<tau>, simp)
+  case (Cons a \<tau>)
+  have "blocks \<tau>" and "blockP a"
+    using \<open>blocks (a # \<tau>)\<close> by simp_all
+  from Cons.hyps[OF this(1)]
+  show ?case
+    unfolding sucs.g.pop_hd[of a \<tau>] sucs.h.pop_hd[of a \<tau>] g.morph h.morph
+    using min_coinD[OF blockP_D, OF \<open>blockP a\<close>] by simp          
+qed
+
+lemma suc_eq': assumes "\<And> a. blockP a" shows "g(suc_fst w) = h(suc_snd w)" 
+  by (simp add: assms blocks_eq) 
+
+lemma suc_eq: assumes all_blocks: "\<And> a. blockP a" shows "g \<circ> suc_fst = h \<circ> suc_snd"  
+  using suc_eq'[OF assms] by fastforce 
+
+lemma block_eq: "blockP a \<Longrightarrow> g (suc_fst [a]) = h (suc_snd [a])"
+  using blockP_D min_coinD by blast 
+
+lemma blocks_inj_suc: assumes "blocks \<tau>" shows "inj_on suc_fst\<^sup>\<C> (set \<tau>)"
+  unfolding inj_on_def core_def using blockP_D_hd[OF \<open>blocks \<tau>\<close>[rule_format]] 
+  by metis
+
+lemma blocks_inj_suc': assumes "blocks \<tau>" shows "inj_on suc_snd\<^sup>\<C> (set \<tau>)"
+   using  g.marked_core blockP_D_hd_hd[OF \<open>blocks \<tau>\<close>[rule_format]]
+   unfolding inj_on_def core_def by metis 
+
+lemma blocks_marked_code: assumes "blocks \<tau>"
+  shows "marked_code (suc_fst\<^sup>\<C> `(set \<tau>))"
+proof
+  show "\<And>u. u \<in> suc_fst\<^sup>\<C> ` set \<tau> \<Longrightarrow> u \<noteq> \<epsilon>"
+    unfolding core_def using min_coinD'[OF blockP_D[OF \<open>blocks \<tau>\<close>[rule_format]]] by fast+
+  show "\<And>u v. u \<in> suc_fst\<^sup>\<C> ` set \<tau> \<Longrightarrow>
+           v \<in> suc_fst\<^sup>\<C> ` set \<tau> \<Longrightarrow> hd u = hd v \<Longrightarrow> u = v"
+    using blockP_D_hd[OF \<open>blocks \<tau>\<close>[rule_format]] unfolding core_def by fastforce
+qed
+
+lemma blocks_marked_code': assumes all_blocks: "\<And> a. a \<in> set \<tau> \<Longrightarrow> blockP a"
+  shows "marked_code (suc_snd\<^sup>\<C> `(set \<tau>))"
+proof
+  show "\<And>u. u \<in> suc_snd\<^sup>\<C> ` set \<tau> \<Longrightarrow> u \<noteq> \<epsilon>"
+    unfolding core_def using min_coinD'[OF all_blocks[THEN blockP_D]] by fast+
+  show "u = v" if "u \<in> suc_snd\<^sup>\<C> ` set \<tau>" and "v \<in> suc_snd\<^sup>\<C> ` set \<tau>" and "hd u = hd v"  for u v
+  proof-
+    obtain a b where "u = suc_snd [a]" and "v = suc_snd [b]" and "a \<in> set \<tau>" and "b \<in> set \<tau>"
+      using \<open>v \<in> suc_snd\<^sup>\<C> ` set \<tau>\<close> \<open>u \<in> suc_snd\<^sup>\<C> ` set \<tau>\<close> unfolding core_def by fast+ 
+    from g.marked_core[of a b, 
+         folded blockP_D_hd_hd[OF all_blocks, OF \<open>a \<in> set \<tau>\<close>] blockP_D_hd_hd[OF all_blocks, OF \<open>b \<in> set \<tau>\<close>]
+         this(1-2) \<open>hd u = hd v\<close>,OF refl]
+    show "u = v"
+      unfolding \<open>u = suc_snd [a]\<close> \<open>v = suc_snd [b]\<close> by blast 
+  qed
+qed
+
+lemma sucs_marked_morphs: assumes all_blocks: "\<And> a. blockP a"
+  shows "two_marked_morphisms suc_fst suc_snd"
+proof
+  show "hd (suc_fst\<^sup>\<C> a) = hd (suc_fst\<^sup>\<C> b) \<Longrightarrow> a = b" for a b
+   using blockP_D_hd[OF all_blocks] unfolding core_def by force
+  show "hd (suc_snd\<^sup>\<C> a) = hd (suc_snd\<^sup>\<C> b) \<Longrightarrow> a = b" for a b
+    using blockP_D_hd_hd[OF all_blocks, folded core_sing] g.marked_core by metis
+  show "suc_fst w = \<epsilon> \<Longrightarrow> w = \<epsilon>" for w
+    using assms blockP_D min_coinD' sucs.g.noner_sings_conv by blast  
+  show  "suc_snd w = \<epsilon> \<Longrightarrow> w = \<epsilon>" for w
+    using blockP_D[OF assms(1), THEN min_coinD'] sucs.h.noner_sings_conv by blast  
+qed
+  
+lemma pre_blocks_range: "{(e,f). g e =\<^sub>m h f } \<subseteq> range pre_block"
+  using pre_blockI case_prodE by blast
+
+corollary card_blocks: assumes "finite (UNIV :: 'a set)" shows "card {(e,f). g e =\<^sub>m h f } \<le> card (UNIV :: 'a set)"
+    using le_trans[OF card_mono[OF finite_imageI pre_blocks_range, OF assms] card_image_le[of _ pre_block, OF assms]]. 
+
+lemma block_decomposition: assumes "g e = h f" 
+  obtains \<tau> where  "suc_fst \<tau> = e" and  "suc_snd \<tau> = f" and "blocks \<tau>"  
+using assms
+proof (induct "\<^bold>|e\<^bold>|" arbitrary: e f thesis rule: less_induct)
+  case less
+    show ?case
+  proof (cases "e = \<epsilon>")
+    assume "e = \<epsilon>"
+    hence  "f = \<epsilon>" 
+      using less.hyps empty_sol[OF \<open>g e = h f\<close>] by blast
+    hence "suc_fst \<epsilon> = e" and "suc_snd \<epsilon> = f"  
+      unfolding suc_fst_def suc_snd_def by (simp add: \<open>e = \<epsilon>\<close>)+
+    from less.prems(1)[OF this]
+    show thesis
+      by simp 
+  next
+    assume "e \<noteq> \<epsilon>"
+    from min_coin_prefE[OF \<open>g e = h f\<close> this]
+    obtain  e\<^sub>1 e\<^sub>2 f\<^sub>1 f\<^sub>2
+      where "g e\<^sub>1 =\<^sub>m h f\<^sub>1" and "e\<^sub>1\<cdot>e\<^sub>2 = e" and "f\<^sub>1\<cdot>f\<^sub>2 = f" and "e\<^sub>1 \<noteq> \<epsilon>" and "f\<^sub>1 \<noteq> \<epsilon>"
+      by (metis min_coinD' prefD)
+    from \<open>g e = h f\<close>[folded \<open>e\<^sub>1\<cdot>e\<^sub>2 = e\<close> \<open>f\<^sub>1\<cdot>f\<^sub>2 = f\<close>, unfolded g.morph h.morph]
+    have "g e\<^sub>2 = h f\<^sub>2"
+      using min_coinD[OF \<open>g e\<^sub>1 =\<^sub>m h f\<^sub>1\<close>] by simp
+    have "\<^bold>|e\<^sub>2\<^bold>| < \<^bold>|e\<^bold>|" 
+      using \<open>e\<^sub>1\<cdot>e\<^sub>2 = e\<close> \<open>e\<^sub>1 \<noteq> \<epsilon>\<close> by auto
+    from less.hyps[OF this _ \<open>g e\<^sub>2 = h f\<^sub>2\<close>] 
+    obtain \<tau>' where "suc_fst \<tau>' = e\<^sub>2" and "suc_snd \<tau>' = f\<^sub>2" and "blocks \<tau>'".
+    have "suc_fst [hd e] = e\<^sub>1" and "suc_snd [hd e] = f\<^sub>1"
+      using suc_morph_sings \<open>e\<^sub>1 \<cdot> e\<^sub>2 = e\<close> \<open>g e\<^sub>1 =\<^sub>m h f\<^sub>1\<close> \<open>e\<^sub>1 \<noteq> \<epsilon>\<close>  by auto
+    hence "suc_fst (hd e # \<tau>') = e" and "suc_snd (hd e # \<tau>') = f"
+      using   \<open>e\<^sub>1 \<cdot> e\<^sub>2 = e\<close> \<open>f\<^sub>1 \<cdot> f\<^sub>2 = f\<close> 
+      unfolding hd_word[of "hd e" \<tau>'] sucs.g.morph sucs.h.morph \<open>suc_fst \<tau>' = e\<^sub>2\<close> \<open>suc_snd \<tau>' = f\<^sub>2\<close> \<open>suc_fst [hd e] = e\<^sub>1\<close> \<open>suc_snd [hd e] = f\<^sub>1\<close> by force+  
+    have "blocks (hd e # \<tau>')"
+      using \<open>blocks \<tau>'\<close> \<open>e\<^sub>1 \<cdot> e\<^sub>2 = e\<close> \<open>e\<^sub>1 \<noteq> \<epsilon>\<close> \<open>g e\<^sub>1 =\<^sub>m h f\<^sub>1\<close> block_ex by force 
+    from less.prems(1)[OF _ _ this]
+    show thesis
+      by (simp add: \<open>suc_fst (hd e # \<tau>') = e\<close> \<open>suc_snd (hd e # \<tau>') = f\<close>)
+  qed
+qed 
+
+lemma block_decomposition_unique: assumes "g e = h f" and
+   "suc_fst \<tau> = e" and "suc_fst \<tau>' = e" and "blocks \<tau>" and "blocks \<tau>'" shows "\<tau> = \<tau>'"
+proof-
+  let ?C = "suc_fst\<^sup>\<C>`(set (\<tau>  \<cdot> \<tau>'))"
+  have "blocks (\<tau> \<cdot> \<tau>')"
+    using \<open>blocks \<tau>\<close> \<open>blocks \<tau>'\<close> by auto 
+  interpret marked_code ?C
+    by (rule blocks_marked_code) (simp add: \<open>blocks (\<tau> \<cdot> \<tau>')\<close>)
+  have "inj_on suc_fst\<^sup>\<C> (set (\<tau>   \<cdot> \<tau>'))"
+    using \<open>blocks (\<tau> \<cdot> \<tau>')\<close> blocks_inj_suc by blast 
+  from sucs.g.code_set_morph[OF code_axioms this \<open>suc_fst \<tau> = e\<close>[folded \<open>suc_fst \<tau>' = e\<close>]]
+  show "\<tau> = \<tau>'".
+qed
+
+lemma block_decomposition_unique': assumes "g e = h f" and
+   "suc_snd \<tau> = f" and "suc_snd \<tau>' = f" and "blocks \<tau>" and "blocks \<tau>'"
+ shows "\<tau> = \<tau>'"
+proof-
+  have "suc_fst \<tau> = e" and "suc_fst \<tau>' = e" 
+    using assms blocks_eq g.code_morph_code by presburger+ 
+ from block_decomposition_unique[OF assms(1) this assms(4-5)] 
+  show "\<tau> = \<tau>'".
+qed
+
+lemma comm_sings_block: assumes "g[a] \<cdot> h[b] = h[b] \<cdot> g[a]"
+  obtains m n where "suc_fst [a] = [a]\<^sup>@Suc m" and "suc_snd [a] = [b]\<^sup>@Suc n"
+proof-
+  have "[a] \<^sup>@ \<^bold>|h [b]\<^bold>| \<noteq> \<epsilon>"
+    using nemp_len[OF h.sing_to_nemp, of b, folded sing_pow_empty[of a "\<^bold>|h [b]\<^bold>|"]].
+  obtain e f where "g e =\<^sub>m h f" and "e \<le>p [a] \<^sup>@ \<^bold>|h [b]\<^bold>|" and "f \<le>p [b] \<^sup>@ \<^bold>|g [a]\<^bold>|"    
+    using   min_coin_prefE[OF comm_common_power[OF assms,folded g.pow_morph h.pow_morph] \<open>[a] \<^sup>@ \<^bold>|h [b]\<^bold>| \<noteq> \<epsilon>\<close>, of thesis] by blast
+  note e =  pref_sing_pow[OF \<open>e \<le>p [a] \<^sup>@ \<^bold>|h [b]\<^bold>|\<close>]
+  note f = pref_sing_pow[OF \<open>f \<le>p [b] \<^sup>@ \<^bold>|g [a]\<^bold>|\<close>]
+  from min_coinD'[OF \<open>g e =\<^sub>m h f\<close>] 
+  have exps: "\<^bold>|e\<^bold>| = Suc (\<^bold>|e\<^bold>| - 1)" "\<^bold>|f\<^bold>| = Suc (\<^bold>|f\<^bold>| - 1)" 
+    by auto
+  have "hd e = a"
+    using \<open>e = [a] \<^sup>@ \<^bold>|e\<^bold>|\<close>[unfolded pow_Suc[of "[a]" "\<^bold>|e\<^bold>| - 1", folded \<open>\<^bold>|e\<^bold>| = Suc (\<^bold>|e\<^bold>| - 1)\<close>], folded hd_word[of a "[a] \<^sup>@ (\<^bold>|e\<^bold>| - 1)"]] 
+    list.sel(1)[of a "[a] \<^sup>@ (\<^bold>|e\<^bold>| - 1)"] by argo 
+  from that suc_morph_sings[OF \<open>g e =\<^sub>m h f\<close>, unfolded this] e f exps 
+  show thesis 
+    by metis
+qed
+
+\<comment> \<open>a variant of successor morphisms: target alphabet encoded to be the same as for original morphisms\<close>
+
+definition sucs_encoding where "sucs_encoding = (\<lambda> a. hd (g [a]))"
+definition sucs_decoding where "sucs_decoding = (\<lambda> a. SOME c. hd (g[c]) = a)"
+
+
+lemma sucs_encoding_inv: "sucs_decoding \<circ> sucs_encoding = id"
+  by (rule, unfold sucs_encoding_def sucs_decoding_def comp_apply id_apply)
+  (use g.marked_core[unfolded core_def] in blast)
+ 
+
+lemma encoding_inj: "inj sucs_encoding"
+  unfolding sucs_encoding_def inj_on_def using g.marked_core[unfolded core_def] by blast
+
+lemma map_encoding_inj: "inj (map sucs_encoding)" 
+  using encoding_inj by simp
+
+definition suc_fst' where "suc_fst' = (map sucs_encoding) \<circ> suc_fst"
+definition suc_snd' where "suc_snd' = (map sucs_encoding) \<circ> suc_snd"
+
+lemma encoded_sucs_eq_conv: "suc_fst w = suc_snd w' \<longleftrightarrow> suc_fst' w = suc_snd' w'"
+  unfolding suc_fst'_def suc_snd'_def  using encoding_inj by force
+
+lemma encoded_sucs_eq_conv': "suc_fst = suc_snd \<longleftrightarrow> suc_fst' = suc_snd'"
+  unfolding suc_fst'_def suc_snd'_def  using inj_comp_eq[OF map_encoding_inj] by blast 
+
+lemma encoded_sucs: assumes "\<And> c. blockP c" shows "two_marked_morphisms suc_fst' suc_snd'"
+unfolding suc_fst'_def suc_snd'_def
+proof-
+  from sucs_marked_morphs[OF assms]
+  interpret sucs: two_marked_morphisms suc_fst suc_snd
+    by force
+  interpret nonerasing_morphism "(map sucs_encoding) \<circ> suc_fst" 
+    unfolding comp_apply  by (standard, simp add: sucs.g.morph, use  sucs.g.nemp_to_nemp in fast) 
+  interpret nonerasing_morphism "(map sucs_encoding) \<circ> suc_snd" 
+    unfolding comp_apply  by (standard, simp add: sucs.h.morph, use  sucs.h.nemp_to_nemp in fast) 
+  interpret marked_morphism "(map sucs_encoding) \<circ> suc_fst" 
+  proof
+    show "hd ((map sucs_encoding \<circ> suc_fst)\<^sup>\<C> a) = hd ((map sucs_encoding \<circ> suc_fst)\<^sup>\<C> b) \<Longrightarrow> a = b" for a b
+      unfolding comp_apply core_def sucs_encoding_def hd_map[OF sucs.g.sing_to_nemp]
+      unfolding  blockP_D_hd[OF assms] using  g.marked_morph. 
+  qed
+  interpret marked_morphism "(map sucs_encoding) \<circ> suc_snd" 
+  proof
+    show "hd ((map sucs_encoding \<circ> suc_snd)\<^sup>\<C> a) = hd ((map sucs_encoding \<circ> suc_snd)\<^sup>\<C> b) \<Longrightarrow> a = b" for a b
+      unfolding comp_apply core_def sucs_encoding_def hd_map[OF sucs.h.sing_to_nemp]
+      using g.marked_morph[THEN sucs.h.marked_morph].
+  qed
+  show "two_marked_morphisms ((map sucs_encoding) \<circ> suc_fst) ((map sucs_encoding) \<circ> suc_snd)"..
+qed
+
+lemma encoded_sucs_len: "\<^bold>|suc_fst w\<^bold>| = \<^bold>|suc_fst' w\<^bold>|" and "\<^bold>|suc_snd w\<^bold>| = \<^bold>|suc_snd' w\<^bold>|"
+  unfolding suc_fst'_def suc_snd'_def sucs_encoding_def comp_apply by force+
+
+end
+
+end
\ No newline at end of file
diff --git a/thys/Combinatorics_Words/Periodicity_Lemma.thy b/thys/Combinatorics_Words/Periodicity_Lemma.thy
--- a/thys/Combinatorics_Words/Periodicity_Lemma.thy
+++ b/thys/Combinatorics_Words/Periodicity_Lemma.thy
@@ -1,437 +1,503 @@
 (*  Title:      CoW/Periodicity_Lemma.thy
     Author:     Štěpán Holub, Charles University
+
+Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/
 *)
 
 theory Periodicity_Lemma
   imports CoWBasic
 begin
 
 chapter "The Periodicity Lemma"
 
-text\<open>The Periodicity Lemma says that if a sufficiently long word has two periods p and q,
-then the period can be refined to @{term "gcd p q"}.
-The consequence is equivalent to the fact that the corresponding periodic roots commute.
+text\<open>The Periodicity Lemma says that if a sufficiently long word has two periods p and q, 
+then the period can be refined to @{term "gcd p q"}. 
+The consequence is equivalent to the fact that the corresponding periodic roots commute. 
 ``Sufficiently long'' here means at least @{term "p + q - gcd p q"}.
 It is also known as the Fine and Wilf theorem due to its authors @{cite FineWilf}.\<close>
 
 text\<open>
-If we relax the requirement to @{term "p + q"}, then the claim becomes easy, and it is proved in theory @{theory Combinatorics_Words.CoWBasic} as @{term two_pers}: @{thm[names_long] two_pers[no_vars]}.
+If we relax the requirement to @{term "p + q"}, then the claim becomes easy, and it is proved in theory @{theory Combinatorics_Words.CoWBasic} as @{term two_pers_root}: @{thm[names_long] two_pers_root[no_vars]}.
 \<close>
 
 theorem per_lemma_relaxed:
-  assumes "periodN w p" and  "periodN w q" and  "p + q \<le> \<^bold>|w\<^bold>|"
+  assumes "period w p" and  "period w q" and  "p + q \<le> \<^bold>|w\<^bold>|"
   shows "(take p w)\<cdot>(take q w) = (take q w)\<cdot>(take p w)"
-  using   two_pers[OF
-      \<open>periodN w p\<close>[unfolded periodN_def[of w p]]
-      \<open>periodN w q\<close>[unfolded periodN_def[of w q]], unfolded
-      take_len[OF add_leD1[OF \<open>p + q \<le> \<^bold>|w\<^bold>|\<close>]]
-      take_len[OF add_leD2[OF \<open>p + q \<le> \<^bold>|w\<^bold>|\<close>]], OF \<open>p + q \<le> \<^bold>|w\<^bold>|\<close>].
+  using   two_pers_root[OF
+      \<open>period w p\<close>[unfolded period_def[of w p]]
+      \<open>period w q\<close>[unfolded period_def[of w q]], unfolded    
+      take_len[OF add_leD1[OF \<open>p + q \<le> \<^bold>|w\<^bold>|\<close>]] 
+      take_len[OF add_leD2[OF \<open>p + q \<le> \<^bold>|w\<^bold>|\<close>]], OF \<open>p + q \<le> \<^bold>|w\<^bold>|\<close>]. 
 
 text\<open>Also in terms of the numeric period:\<close>
 
-thm two_periodsN
+thm two_periods
 
 section \<open>Main claim\<close>
 
 text\<open>We first formulate the claim of the Periodicity lemma in terms of commutation of two periodic roots.
 For trivial reasons we can also drop the requirement that the roots are nonempty.
 \<close>
-lemma per_lemma_comm:
-  assumes "w \<le>p r \<cdot> w" and "w \<le>p s \<cdot> w"
+theorem per_lemma_comm:
+  assumes "w \<le>p r \<cdot> w" and "w \<le>p s \<cdot> w" 
     and len: "\<^bold>|s\<^bold>| + \<^bold>|r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|r\<^bold>|) \<le> \<^bold>|w\<^bold>|"
   shows "s \<cdot> r = r \<cdot> s"
   using assms
 proof (induction "\<^bold>|s\<^bold>| + \<^bold>|s\<^bold>| + \<^bold>|r\<^bold>|" arbitrary: w r s rule: less_induct)
   case less
   consider (empty) "s = \<epsilon>" | (short)  "\<^bold>|r\<^bold>| < \<^bold>|s\<^bold>|" | (step) "s \<noteq> \<epsilon> \<and> \<^bold>|s\<^bold>| \<le> \<^bold>|r\<^bold>|" by force
-  then show ?case
+  then show ?case 
   proof (cases)
-    case (empty)
+    case (empty) 
     thus "s \<cdot> r = r \<cdot> s" by fastforce
   next
     case (short)
     thus "s \<cdot> r = r \<cdot> s"
-      using  "less.hyps"[OF  _ \<open> w \<le>p s \<cdot> w\<close> \<open> w \<le>p r \<cdot> w\<close>
+      using  "less.hyps"[OF  _ \<open> w \<le>p s \<cdot> w\<close> \<open> w \<le>p r \<cdot> w\<close> 
       \<open>\<^bold>|s\<^bold>| + \<^bold>|r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|r\<^bold>|) \<le> \<^bold>|w\<^bold>|\<close>[unfolded gcd.commute[of "\<^bold>|s\<^bold>|"] add.commute[of "\<^bold>|s\<^bold>|"]]] by fastforce
    next
      case (step)
     hence  "s \<noteq> \<epsilon>" and "\<^bold>|s\<^bold>| \<le> \<^bold>|r\<^bold>|" by blast+
     from le_add_diff[OF gcd_le2_nat[OF \<open>s \<noteq> \<epsilon>\<close>[folded length_0_conv], of "\<^bold>|r\<^bold>|"], unfolded gcd.commute[of "\<^bold>|r\<^bold>|"]]
-    have "\<^bold>|r\<^bold>| \<le> \<^bold>|w\<^bold>|"
+    have "\<^bold>|r\<^bold>| \<le> \<^bold>|w\<^bold>|" 
       using  \<open>\<^bold>|s\<^bold>| + \<^bold>|r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|r\<^bold>|) \<le> \<^bold>|w\<^bold>|\<close> order.trans by fast
     hence "\<^bold>|s\<^bold>| \<le> \<^bold>|w\<^bold>|"
       using \<open>\<^bold>|s\<^bold>| \<le> \<^bold>|r\<^bold>|\<close> order.trans by blast
-    from pref_prod_long[OF  \<open>w \<le>p s \<cdot> w\<close> this]
+    from pref_prod_long[OF  \<open>w \<le>p s \<cdot> w\<close> this] 
     have "s \<le>p w".
-
-    obtain w' where "s \<cdot> w' = w" and "\<^bold>|w'\<^bold>| < \<^bold>|w\<^bold>|" using \<open>s \<noteq> \<epsilon>\<close> \<open>s \<le>p w\<close> by auto
+    
+    obtain w' where "s \<cdot> w' = w" and "\<^bold>|w'\<^bold>| < \<^bold>|w\<^bold>|" 
+      using \<open>s \<noteq> \<epsilon>\<close> \<open>s \<le>p w\<close>[unfolded prefix_def] 
+      by force
     have "w' \<le>p w"
       using \<open>w \<le>p s \<cdot> w\<close> unfolding \<open>s \<cdot> w' = w\<close>[symmetric] pref_cancel_conv.
     from this[folded \<open>s \<cdot> w' = w\<close>]
     have "w' \<le>p s\<cdot>w'".
 
     have "s \<le>p r"
-      using pref_prod_short[OF prefix_order.trans[OF \<open>s \<le>p w\<close> \<open>w \<le>p r \<cdot> w\<close>] \<open>\<^bold>|s\<^bold>| \<le> \<^bold>|r\<^bold>|\<close>].
+      using pref_prod_le[OF prefix_order.trans[OF \<open>s \<le>p w\<close> \<open>w \<le>p r \<cdot> w\<close>] \<open>\<^bold>|s\<^bold>| \<le> \<^bold>|r\<^bold>|\<close>].
     hence  "w' \<le>p (s\<inverse>\<^sup>>r) \<cdot> w'"
-      using \<open>w \<le>p r \<cdot> w\<close> \<open>s \<cdot> w' = w\<close> pref_prod_pref[OF _ \<open>w' \<le>p w\<close>, of "s\<inverse>\<^sup>>r"]  by fastforce
+      using \<open>w \<le>p r \<cdot> w\<close> \<open>s \<cdot> w' = w\<close> pref_prod_pref[OF _ \<open>w' \<le>p w\<close>, of "s\<inverse>\<^sup>>r"] 
+      unfolding prefix_def by fastforce
 
-    have ind_len: "\<^bold>|s\<^bold>| + \<^bold>|s\<inverse>\<^sup>>r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|s\<inverse>\<^sup>>r\<^bold>|) \<le> \<^bold>|w'\<^bold>|"
-      using \<open>\<^bold>|s\<^bold>| + \<^bold>|r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|r\<^bold>|) \<le> \<^bold>|w\<^bold>|\<close> \<open>s \<cdot> w' = w\<close> \<open>s \<le>p r\<close> by auto
+   have ind_len: "\<^bold>|s\<^bold>| + \<^bold>|s\<inverse>\<^sup>>r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|s\<inverse>\<^sup>>r\<^bold>|) \<le> \<^bold>|w'\<^bold>|"
+      using \<open>\<^bold>|s\<^bold>| + \<^bold>|r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|r\<^bold>|) \<le> \<^bold>|w\<^bold>|\<close>[folded \<open>s \<cdot> w' = w\<close>] 
+      unfolding pref_gcd_lq[OF \<open>s \<le>p r\<close>] lenmorph lq_len[OF \<open>s \<le>p r\<close>] by force
 
-    have "s \<cdot> s\<inverse>\<^sup>>r = s\<inverse>\<^sup>>r \<cdot> s"
-      using "less.hyps"[OF  _ \<open>w' \<le>p (s\<inverse>\<^sup>>r) \<cdot> w'\<close>  \<open>w' \<le>p s \<cdot> w'\<close> ind_len] \<open>s \<le>p r\<close> \<open>\<^bold>|w'\<^bold>| < \<^bold>|w\<^bold>|\<close>  by force
+    have "s \<cdot> s\<inverse>\<^sup>>r = s\<inverse>\<^sup>>r \<cdot> s" 
+      using "less.hyps"[OF  _ \<open>w' \<le>p (s\<inverse>\<^sup>>r) \<cdot> w'\<close>  \<open>w' \<le>p s \<cdot> w'\<close> ind_len] \<open>s \<le>p r\<close> \<open>\<^bold>|w'\<^bold>| < \<^bold>|w\<^bold>|\<close> 
+        unfolding prefix_def by force 
 
     thus "s \<cdot> r = r \<cdot> s"
-       using \<open>s \<le>p r\<close> by auto
-  qed
+       using \<open>s \<le>p r\<close> by (fastforce simp add: prefix_def)
+  qed 
 qed
 
+lemma per_lemma_comm_pref:
+  assumes "u \<le>p r\<^sup>@k" "u \<le>p s\<^sup>@l"
+      and len: "\<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| - gcd (\<^bold>|r\<^bold>|) (\<^bold>|s\<^bold>|) \<le> \<^bold>|u\<^bold>|"
+    shows "r \<cdot> s = s \<cdot> r"
+  using  pref_prod_root[OF assms(2)] pref_prod_root[OF assms(1)] per_lemma_comm[OF _ _ len] by blast
+
 text\<open>We can now prove the numeric version.\<close>
 
-theorem per_lemma: assumes "periodN w p" and "periodN w q" and len: "p + q - gcd p q \<le> \<^bold>|w\<^bold>|"
-  shows  "periodN w (gcd p q)"
+theorem per_lemma: assumes "period w p" and "period w q" and len: "p + q - gcd p q \<le> \<^bold>|w\<^bold>|"
+  shows  "period w (gcd p q)"
 proof-
   have takep: "w \<le>p (take p w) \<cdot> w" and takeq: "w \<le>p (take q w) \<cdot> w"
-    using \<open>periodN w p\<close> \<open>periodN w q\<close> periodN_D3 by blast+
+    using \<open>period w p\<close> \<open>period w q\<close> period_D3 by blast+
   have lenp: "\<^bold>|take p w\<^bold>| = p"
-    using gcd_le2_nat[OF per_positive[OF \<open>periodN w q\<close>], of p] len take_len
+    using gcd_le2_nat[OF per_positive[OF \<open>period w q\<close>], of p] len take_len
     by auto
   have lenq: "\<^bold>|take q w\<^bold>| = q"
-    using gcd_le1_nat[OF per_positive[OF \<open>periodN w p\<close>], of q] len take_len
+    using gcd_le1_nat[OF per_positive[OF \<open>period w p\<close>], of q] len take_len
     by simp
-  obtain t where "take p w \<in> t*" and "take q w \<in> t*"
+  obtain t where "take p w \<in> t*" and "take q w \<in> t*" 
     using comm_rootE[OF per_lemma_comm[OF takeq takep, unfolded lenp lenq, OF len], of thesis] by blast
   hence "w \<le>p t\<^sup>\<omega>"
-    using \<open>periodN w p\<close> periodN_def per_root_trans by blast
-  have "periodN w \<^bold>|t\<^bold>|"
-    using  root_periodN[OF  per_nemp[OF \<open>periodN w p\<close>] \<open>w \<le>p t\<^sup>\<omega>\<close>].
+    using \<open>period w p\<close> period_def per_root_trans by blast
+  have "period w \<^bold>|t\<^bold>|"
+    using  root_period[OF  per_nemp[OF \<open>period w p\<close>] \<open>w \<le>p t\<^sup>\<omega>\<close>]. 
   have "\<^bold>|t\<^bold>| dvd (gcd p q)"
     using  common_root_len_gcd[OF \<open>take p w \<in> t*\<close> \<open>take q w \<in> t*\<close>] unfolding  lenp lenq.
   from dvd_div_mult_self[OF this]
   have "gcd p q div \<^bold>|t\<^bold>| * \<^bold>|t\<^bold>| = gcd p q".
   have "gcd p q \<noteq> 0"
-    using \<open>periodN w p\<close> by auto
+    using \<open>period w p\<close> by auto 
   from this[folded dvd_div_eq_0_iff[OF \<open>\<^bold>|t\<^bold>| dvd (gcd p q)\<close>]]
-  show "periodN w (gcd p q)"
-    using  per_mult[OF \<open>periodN w \<^bold>|t\<^bold>|\<close>, of "gcd p q div \<^bold>|t\<^bold>|", unfolded dvd_div_mult_self[OF \<open>\<^bold>|t\<^bold>| dvd (gcd p q)\<close>]] by blast
+  show "period w (gcd p q)"
+    using  per_mult[OF \<open>period w \<^bold>|t\<^bold>|\<close>, of "gcd p q div \<^bold>|t\<^bold>|", unfolded dvd_div_mult_self[OF \<open>\<^bold>|t\<^bold>| dvd (gcd p q)\<close>]] by blast
 qed
 
 section \<open>Optimality\<close>
 
-text\<open>@{term "FW_word"} (where FW stands for  Fine and Wilf) yields a word which show the optimality of the bound in the Periodicity lemma.
+text\<open>@{term "FW_word"} (where FW stands for  Fine and Wilf) yields a word which show the optimality of the bound in the Periodicity lemma. 
     Moreover, the obtained word has maximum possible letters (each equality of letters is forced by periods). The latter is not proved here.\<close>
 
 term "butlast ([0..<(gcd p q)]\<^sup>@(p div (gcd p q)))\<cdot>[gcd p q]\<cdot>(butlast ([0..<(gcd p q)]\<^sup>@(p div (gcd p q))))"
 
 \<comment> \<open>an auxiliary claim\<close>
-lemma ext_per_sum: assumes "periodN w p" and "periodN w q" and  "p \<le> \<^bold>|w\<^bold>|"
-  shows "periodN ((take p w) \<cdot> w) (p+q)"
+lemma ext_per_sum: assumes "period w p" and "period w q" and  "p \<le> \<^bold>|w\<^bold>|" 
+  shows "period ((take p w) \<cdot> w) (p+q)"
 proof-
   have nemp: "take p w \<cdot> take q w \<noteq> \<epsilon>"
-    using \<open>periodN w p\<close> by auto
+    using \<open>period w p\<close> by auto
   have "take (p + q) (take p w \<cdot> w) = take p (take p w \<cdot> w) \<cdot> take q (drop p (take p w \<cdot> w))"
     using take_add by blast
   also have "... = take p w \<cdot> take q w"
     by (simp add: \<open>p \<le> \<^bold>|w\<^bold>|\<close>)
   ultimately have sum: "take (p + q) (take p w \<cdot> w) = take p w \<cdot> take q w"
-    by simp
+    by presburger
   show ?thesis
     using assms(1) assms(2) nemp
-    unfolding periodN_def period_root_def sum rassoc same_prefix_prefix
+    unfolding period_def period_root_def sum rassoc same_prefix_prefix
     using pref_prolong  by blast
 qed
 
-abbreviation "fw_p_per p q \<equiv> butlast ([0..<(gcd p q)]\<^sup>@(p div (gcd p q)))"
-abbreviation "fw_base p q \<equiv> fw_p_per p q \<cdot> [gcd p q]\<cdot> fw_p_per p q"
+definition "fw_p_per p q \<equiv> butlast ([0..<(gcd p q)]\<^sup>@(p div (gcd p q)))"
+definition "fw_base p q \<equiv> fw_p_per p q \<cdot> [gcd p q]\<cdot> fw_p_per p q"
 
 fun FW_word :: "nat \<Rightarrow> nat \<Rightarrow> nat list" where
-  FW_word_def: "FW_word p q =
-\<comment>\<open>symmetry\<close>           (if q < p then  FW_word q p else
-\<comment>\<open>artificial value\<close>   if p = 0 \<or> p = q then \<epsilon> else
+  FW_word_def: "FW_word p q =  
+\<comment>\<open>symmetry\<close>           (if q < p then  FW_word q p else 
+\<comment>\<open>artificial value\<close>   if p = 0 then \<epsilon> else 
+\<comment>\<open>artificial value\<close>   if p = q then \<epsilon> else
 \<comment>\<open>base case\<close>          if gcd p q = q - p then fw_base p q
-\<comment>\<open>step\<close>               else (take p (FW_word p (q-p))) \<cdot> FW_word p (q-p)    )"
+\<comment>\<open>step\<close>               else (take p (FW_word p (q-p))) \<cdot> FW_word p (q-p))"
 
 lemma FW_sym: "FW_word p q = FW_word q p"
   by (cases rule: linorder_cases[of p q], simp+)
 
 theorem fw_word': "\<not> p dvd q \<Longrightarrow> \<not> q dvd p \<Longrightarrow>
- \<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1 \<and> periodN (FW_word p q) p \<and> periodN (FW_word p q) q \<and> \<not> periodN (FW_word p q) (gcd p q)"
+ \<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1 \<and> period (FW_word p q) p \<and> period (FW_word p q) q \<and> \<not> period (FW_word p q) (gcd p q)"
 proof (induction "p + p + q" arbitrary: p q rule: less_induct)
   case less
   have "p \<noteq> 0"
-    using  \<open>\<not> q dvd p\<close> dvd_0_right[of q] by meson
+    using  \<open>\<not> q dvd p\<close> dvd_0_right[of q] by meson 
   have "p \<noteq> q"
     using \<open>\<not> p dvd q\<close> by auto
-  then consider "q < p" | "p < q"
+  then consider "q < p" | "p < q" 
     by linarith
-  then show ?case
+  then show ?case 
   proof (cases)
     assume "q < p"
     have less: "q + q + p < p + p + q"
       by (simp add: \<open>q < p\<close>)
     thus ?case
-      using "less.hyps"[OF _ \<open>\<not> q dvd p\<close> \<open>\<not> p dvd q\<close>]
-      unfolding FW_sym[of p q] gcd.commute[of p q] add.commute[of p q] by blast
+      using "less.hyps"[OF _ \<open>\<not> q dvd p\<close> \<open>\<not> p dvd q\<close>] 
+      unfolding FW_sym[of p q] gcd.commute[of p q] add.commute[of p q] by blast             
   next
     let ?d = "gcd p q"
     let ?dw = "[0..<(gcd p q)]"
     let ?pd = "p div (gcd p q)"
-    assume "p < q"
+    assume "p < q" 
     thus ?thesis
     proof (cases "?d = q - p")
       assume "?d = q - p" hence "p + ?d = q" using \<open>p < q\<close> by auto
-      have fw: "FW_word p q = fw_base p q"
-        using FW_word_def \<open>p \<noteq> 0\<close> \<open>gcd p q = q - p\<close> \<open>p < q\<close> by auto
+      hence "p \<noteq> q" and "\<not> q < p" using \<open>p \<noteq> 0\<close> \<open>p < q\<close> by fastforce+ 
+      hence fw: "FW_word p q = fw_base p q"
+        unfolding FW_word_def[of p q] using \<open>p \<noteq> 0\<close>  \<open>gcd p q = q - p\<close> by presburger  
 
       have ppref: "\<^bold>|butlast (?dw\<^sup>@?pd)\<cdot>[?d]\<^bold>| = p"
-        using length_append \<open>p \<noteq> 0\<close> pow_len[of "?dw" "?pd"]
+        using  \<open>p \<noteq> 0\<close> pow_len[of "?dw" "?pd"] unfolding lenmorph sing_len 
         by auto
-      note ppref' = this[unfolded length_append]
+      note ppref' = this[unfolded lenmorph]
       have qpref: "\<^bold>|butlast (?dw\<^sup>@?pd)\<cdot>[?d]\<cdot>?dw\<^bold>| = q"
-        unfolding lassoc length_append ppref' using  \<open>p + gcd p q = q\<close> by simp
+        unfolding lassoc lenmorph ppref' using  \<open>p + gcd p q = q\<close> by simp   
       have "butlast (?dw\<^sup>@?pd)\<cdot>[?d] \<le>p FW_word p q"
-        unfolding fw by force
+        unfolding fw fw_base_def fw_p_per_def by force
       from pref_take[OF this]
       have takep: "take p (FW_word p q) = butlast (?dw\<^sup>@?pd)\<cdot>[?d]"
         unfolding ppref.
 
       have "?dw \<noteq> \<epsilon>" and "\<^bold>|?dw\<^bold>| = ?d"
         using \<open>p \<noteq> 0\<close> by auto
       have "?pd \<noteq> 0"
-        by (simp add: \<open>p \<noteq> 0\<close> dvd_div_eq_0_iff)
+        by (simp add: \<open>p \<noteq> 0\<close> dvd_div_eq_0_iff) 
       from not0_implies_Suc[OF this]
       obtain e where "?pd = Suc e"  by blast
       have "gcd p q \<noteq> p"
-        using \<open>\<not> p dvd q\<close> gcd_dvd2[of p q] by force
+        using \<open>\<not> p dvd q\<close> gcd_dvd2[of p q] by force     
       hence "Suc e \<noteq> 1"
         using dvd_mult_div_cancel[OF gcd_dvd1[of p q], unfolded \<open>?pd = Suc e\<close>] by force
       hence "e \<noteq> 0" by simp
 
       have "[0..<gcd p q] \<^sup>@ e \<noteq> \<epsilon>"
         using \<open>[0..<gcd p q] \<noteq> \<epsilon>\<close> \<open>e \<noteq> 0\<close> nonzero_pow_emp by blast
       hence but_dec: "butlast (?dw\<^sup>@?pd) = ?dw \<cdot> butlast (?dw\<^sup>@e)"
-        unfolding \<open>?pd = Suc e\<close> pow_Suc_list butlast_append  if_not_P[OF \<open>[0..<gcd p q] \<^sup>@ e \<noteq> \<epsilon>\<close>] by blast
-      have but_dec_b: "butlast (?dw\<^sup>@?pd) = ?dw\<^sup>@e \<cdot> butlast ?dw"
-        unfolding \<open>?pd = Suc e\<close> pow_Suc2_list butlast_append if_not_P[OF \<open>?dw \<noteq> \<epsilon>\<close>] by blast
+        unfolding \<open>?pd = Suc e\<close> pow_Suc butlast_append  if_not_P[OF \<open>[0..<gcd p q] \<^sup>@ e \<noteq> \<epsilon>\<close>] by blast
+      have but_dec_b: "butlast (?dw\<^sup>@?pd) = ?dw\<^sup>@e \<cdot> butlast ?dw" 
+        unfolding \<open>?pd = Suc e\<close> pow_Suc2 butlast_append if_not_P[OF \<open>?dw \<noteq> \<epsilon>\<close>] by blast
       have "butlast (?dw\<^sup>@?pd)\<cdot>[?d]\<cdot>?dw \<le>p FW_word p q"
-        using fw but_dec by auto
+        unfolding fw but_dec lassoc fw_base_def fw_p_per_def by blast
       note takeq = pref_take[OF this, unfolded qpref]
 
       have "\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1"
       proof-
+        have "p + q - (q - p) = p + p"
+          using \<open>p + gcd p q = q\<close> by auto
         have "\<^bold>|?dw\<^bold>| = ?d"
           by auto
         have "gcd p q dvd p"
           by auto
         hence "\<^bold>|?dw\<^sup>@?pd\<^bold>| = p"
           using pow_len[of "?dw" "?pd"]
           by auto
         hence "\<^bold>|butlast (?dw\<^sup>@?pd)\<^bold>| = p - 1"
           by simp
         hence "\<^bold>|FW_word p q\<^bold>| = (p - 1) + 1 +  (p - 1)"
-          using fw unfolding length_append
-          by auto
+          unfolding fw lenmorph sing_len fw_base_def fw_p_per_def by presburger 
         thus "\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1"
-          unfolding \<open>gcd p q = q - p\<close> using \<open>p + gcd p q = q\<close> \<open>p \<noteq> 0\<close> add.assoc by auto
-      qed
+          unfolding \<open>gcd p q = q - p\<close> \<open>p + q - (q - p) = p + p\<close>  using \<open>p \<noteq> 0\<close> by fastforce
+      qed    
 
-      have "periodN (FW_word p q) p"
+      have "period (FW_word p q) p"
       proof-
         have "take p (FW_word p q) \<noteq> \<epsilon>"
           using \<open>p \<noteq> 0\<close>  unfolding length_0_conv[symmetric] ppref[folded takep].
-        thus "periodN (FW_word p q) p"
-          unfolding periodN_def period_root_def  takep unfolding fw lassoc by auto
+        moreover have "fw_base p q \<le>p fw_p_per p q \<cdot> [gcd p q] \<cdot> fw_base p q"
+          unfolding rassoc pref_cancel_conv fw_base_def fw_p_per_def by simp 
+        ultimately show "period (FW_word p q) p"
+          unfolding period_def period_root_def takep unfolding fw rassoc fw_base_def fw_p_per_def by fast
       qed
 
-      have "periodN (FW_word p q) q"
-        unfolding periodN_def period_root_def
+      have "period (FW_word p q) q"
+        unfolding period_def period_root_def 
       proof
         show "take q (FW_word p q) \<noteq> \<epsilon>"
           unfolding length_0_conv[symmetric] qpref[folded takeq] using \<open>p \<noteq> 0\<close> \<open>p < q\<close> by linarith
       next
         show "FW_word p q \<le>p take q (FW_word p q) \<cdot> FW_word p q"
           unfolding takeq
-          unfolding fw rassoc pref_cancel_conv but_dec but_dec_b \<open>?pd = Suc e\<close> pow_Suc2_list butlast_append pow_Suc_list if_not_P[OF \<open>?dw \<noteq> \<epsilon>\<close>]
+          unfolding fw fw_base_def fw_p_per_def rassoc pref_cancel_conv but_dec but_dec_b \<open>?pd = Suc e\<close> pow_Suc2 butlast_append pow_Suc if_not_P[OF \<open>?dw \<noteq> \<epsilon>\<close>]
           unfolding lassoc power_commutes[symmetric] unfolding rassoc pref_cancel_conv
-          using pref_ext[OF prefixeq_butlast, of "?dw"] by blast
+          using pref_ext[OF prefixeq_butlast, of "?dw"]
+          by blast 
       qed
 
-      have "\<not> periodN (FW_word p q) ?d"
+      have "\<not> period (FW_word p q) ?d"
       proof-
         have last_a: "last (take p (FW_word p q)) = ?d"
           unfolding takep nth_append_length[of "butlast (?dw \<^sup>@ ?pd)" "?d" \<epsilon>]
             last_snoc by blast
         have "?dw \<le>p FW_word p q"
-          using fw but_dec  by simp
+          unfolding fw but_dec rassoc fw_base_def fw_p_per_def by blast
         from pref_take[OF this, unfolded \<open>\<^bold>|?dw\<^bold>| = ?d\<close>]
         have takegcd:  "take (gcd p q) (FW_word p q) = [0..<gcd p q]".
         have fw_dec_b: "FW_word p q = [0..<gcd p q]\<^sup>@e \<cdot> butlast ([0..<gcd p q]) \<cdot> [?d] \<cdot> (butlast ([0..<gcd p q]\<^sup>@(p div gcd p q)))"
-          using fw but_dec_b  by simp
-        hence gcdepref:  "[0..<gcd p q]\<^sup>@ Suc e \<le>p take (gcd p q) (FW_word p q) \<cdot> FW_word p q"
-          using takegcd  by simp
+          unfolding fw but_dec_b rassoc fw_base_def fw_p_per_def ..
+        have gcdepref:  "[0..<gcd p q]\<^sup>@ Suc e \<le>p take (gcd p q) (FW_word p q) \<cdot> FW_word p q"
+          unfolding takegcd pow_Suc pref_cancel_conv unfolding fw_dec_b by blast
         have "\<^bold>|[0..<gcd p q]\<^sup>@ Suc e\<^bold>| = p"
-          unfolding pow_len \<open>\<^bold>|?dw\<^bold>| = ?d\<close> \<open>?pd = Suc e\<close>[symmetric] using
+          unfolding pow_len \<open>\<^bold>|?dw\<^bold>| = ?d\<close> \<open>?pd = Suc e\<close>[symmetric] using  
             dvd_div_mult_self[OF gcd_dvd1].
-        from pref_take[OF gcdepref, unfolded this]
+        from pref_take[OF gcdepref, unfolded this] 
         have takegcdp:  "take p (take (gcd p q) (FW_word p q) \<cdot> (FW_word p q)) = [0..<gcd p q]\<^sup>@e \<cdot> [0..<gcd p q]"
-          unfolding pow_Suc2_list.
+          unfolding pow_Suc2.  
         have "0 < gcd p q" by (simp add: \<open>p \<noteq> 0\<close>)
         from last_upt[OF this]
         have last_b: "last (take p (take (gcd p q) (FW_word p q) \<cdot> (FW_word p q))) = gcd p q - 1"
           unfolding takegcdp  last_appendR[of "[0..<gcd p q]" "[0..<gcd p q]\<^sup>@e", OF \<open>[0..<gcd p q] \<noteq> \<epsilon>\<close>].
         have "p \<le> \<^bold>|FW_word p q\<^bold>|"
-          using \<open>\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1\<close> \<open>gcd p q = q - p\<close> \<open>p < q\<close> by linarith
+          unfolding \<open>\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1\<close> \<open>gcd p q = q - p\<close> using  \<open>p < q\<close> by auto 
         have "gcd p q \<noteq> gcd p q - 1"
           using \<open>gcd p q = q - p\<close> \<open>p < q\<close> by linarith
         hence "take p (FW_word p q) \<noteq> take p (take (gcd p q) (FW_word p q) \<cdot> (FW_word p q))"
           unfolding last_b[symmetric] unfolding last_a[symmetric] using arg_cong[of _ _ last] by blast
-        hence "\<not> FW_word p q \<le>p take (gcd p q) (FW_word p q) \<cdot> FW_word p q "
+        hence "\<not> FW_word p q \<le>p take (gcd p q) (FW_word p q) \<cdot> FW_word p q " 
           using pref_share_take[OF _ \<open>p \<le> \<^bold>|FW_word p q\<^bold>|\<close>, of "take (gcd p q) (FW_word p q) \<cdot> FW_word p q"] by blast
-        thus "\<not> periodN (FW_word p q) (gcd p q)"
-          unfolding periodN_def period_root_def by blast
-      qed
+        thus "\<not> period (FW_word p q) (gcd p q)" 
+          unfolding period_def period_root_def by blast
+      qed          
 
       show ?thesis
-        using \<open>periodN (FW_word p q) p\<close> \<open>periodN (FW_word p q) q\<close>
-          \<open>\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1\<close> \<open>\<not> periodN (FW_word p q) (gcd p q)\<close> by blast
+        using \<open>period (FW_word p q) p\<close> \<open>period (FW_word p q) q\<close>
+          \<open>\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1\<close> \<open>\<not> period (FW_word p q) (gcd p q)\<close> by blast
     next
-      let ?d' = "gcd p (q-p)"
+      let ?d' = "gcd p (q-p)" 
       assume "gcd p q \<noteq> q - p"
-      hence fw: "FW_word p q = (take p (FW_word p (q-p))) \<cdot> FW_word p (q-p)"
+      hence fw: "FW_word p q = (take p (FW_word p (q-p))) \<cdot> FW_word p (q-p)" 
         using FW_word_def \<open>p \<noteq> 0\<close> \<open>p \<noteq> q\<close> \<open>p < q\<close> by (meson less_Suc_eq not_less_eq)
 
       have divhyp1: "\<not> p dvd q - p"
         using \<open>\<not> p dvd q\<close> \<open>p < q\<close> dvd_minus_self by auto
 
       have divhyp2: "\<not> q - p dvd p"
       proof (rule notI)
         assume "q - p dvd p"
         have "q = p + (q - p)"
           by (simp add: \<open>p < q\<close> less_or_eq_imp_le)
-        from gcd_add2[of p "q - p", folded  this, unfolded gcd_nat.absorb2[of "q - p" p, OF \<open>q - p dvd p\<close>]]
+        from gcd_add2[of p "q - p", folded  this, unfolded gcd_nat.absorb2[of "q - p" p, OF \<open>q - p dvd p\<close>]] 
         show "False"
           using \<open>gcd p q \<noteq> q - p\<close> by blast
       qed
 
       have lenhyp: "p + p + (q - p) < p + p + q"
-        using \<open>p < q\<close> \<open>p \<noteq> 0\<close> by linarith
+        using \<open>p < q\<close> \<open>p \<noteq> 0\<close> by linarith 
 
-\<comment> \<open>induction assumption\<close>
-      have "\<^bold>|FW_word p (q - p)\<^bold>| = p + (q - p) - ?d' - 1" and "periodN (FW_word p (q-p)) p" and "periodN (FW_word p (q-p)) (q-p)" and
-        "\<not> periodN (FW_word p (q-p)) (gcd p (q-p))"
+\<comment> \<open>induction assumption\<close>      
+      have "\<^bold>|FW_word p (q - p)\<^bold>| = p + (q - p) - ?d' - 1" and "period (FW_word p (q-p)) p" and "period (FW_word p (q-p)) (q-p)" and
+        "\<not> period (FW_word p (q-p)) (gcd p (q-p))" 
         using "less.hyps"[OF _ divhyp1 divhyp2] lenhyp
-        by blast+
+        by blast+ 
 
 \<comment> \<open>auxiliary facts\<close>
       have "p + (q - p) = q"
          using divhyp1 dvd_minus_self by auto
       have "?d = ?d'"
         using  gcd_add2[of p "q-p", unfolded le_add_diff_inverse[OF less_imp_le[OF \<open>p < q\<close>]]].
       have "?d \<noteq> q"
         using  \<open>\<not> q dvd p\<close>  gcd_dvd2[of q p, unfolded gcd.commute[of q]] by force
       from this[unfolded nat_neq_iff]
       have "?d < q"
         using  gr_implies_not0 \<open>p < q\<close> nat_dvd_not_less by blast
       hence "1 \<le> q - ?d"
         by linarith
       have "?d' < q - p"
-        using  gcd_le2_nat[OF per_positive[OF \<open>periodN (FW_word p (q - p)) (q - p)\<close>], of p]  divhyp2[unfolded  gcd_nat.absorb_iff2] nat_less_le by blast
+        using  gcd_le2_nat[OF per_positive[OF \<open>period (FW_word p (q - p)) (q - p)\<close>], of p]  divhyp2[unfolded  gcd_nat.absorb_iff2] nat_less_le by blast
       hence "p \<le> \<^bold>|(FW_word p (q - p))\<^bold>|"
         unfolding  \<open>\<^bold>|FW_word p (q - p)\<^bold>| = p + (q - p) - ?d' - 1\<close>  diff_diff_left discrete by linarith
-      have "FW_word p (q - p) \<noteq> \<epsilon>"
-        unfolding length_0_conv[symmetric] using  \<open>p \<le> \<^bold>|FW_word p (q - p)\<^bold>|\<close> \<open>p \<noteq> 0\<close>[folded le_zero_eq]
+      have "FW_word p (q - p) \<noteq> \<epsilon>" 
+        unfolding length_0_conv[symmetric] using  \<open>p \<le> \<^bold>|FW_word p (q - p)\<^bold>|\<close> \<open>p \<noteq> 0\<close>[folded le_zero_eq] 
         by linarith
 
 \<comment> \<open>claim 1\<close>
-      have "\<^bold>|FW_word p q\<^bold>| = p + q - ?d - 1"
+      have "\<^bold>|FW_word p q\<^bold>| = p + q - ?d - 1" 
       proof-
+        have "p + (q - p) = q" using less_imp_le[OF \<open>p < q\<close>] by fastforce
         have "\<^bold>|FW_word p q\<^bold>| = \<^bold>|take p (FW_word p (q - p))\<^bold>| + \<^bold>|FW_word p (q - p)\<^bold>|"
-          using fw length_append[of "take p (FW_word p (q - p))" "FW_word p (q - p)"]
+          using fw lenmorph[of "take p (FW_word p (q - p))" "FW_word p (q - p)"]
           by presburger
         also have "... = p + (p + (q - p) - ?d' - 1)"
-          unfolding \<open>\<^bold>|FW_word p (q - p)\<^bold>| = p + (q - p) - ?d' - 1\<close>
+          unfolding \<open>\<^bold>|FW_word p (q - p)\<^bold>| = p + (q - p) - ?d' - 1\<close> 
             take_len[OF \<open>p \<le> \<^bold>|FW_word p (q - p)\<^bold>|\<close>] by blast
         also have "... = p + (q - ?d  - 1)"
-          unfolding \<open>?d = ?d'\<close> using  \<open>p < q\<close> by auto
+          unfolding \<open>?d = ?d'\<close> \<open>p + (q - p) = q\<close>..
         also have "... = p + (q - ?d) - 1"
           using Nat.add_diff_assoc[OF \<open>1 \<le> q - ?d\<close>].
         also have "... = p + q - ?d - 1"
           by (simp add: \<open>?d < q\<close> less_or_eq_imp_le)
-        finally show "\<^bold>|FW_word p q\<^bold>| = p + q - ?d - 1"
+        finally show "\<^bold>|FW_word p q\<^bold>| = p + q - ?d - 1" 
           by presburger
       qed
 
 \<comment> \<open>claim 2\<close>
-      have "periodN (FW_word p q) p"
-        using fw  ext_per_left[OF \<open>periodN (FW_word p (q-p)) p\<close> \<open>p \<le> \<^bold>|FW_word p (q - p)\<^bold>|\<close>]
+      have "period (FW_word p q) p"
+        using fw  ext_per_left[OF \<open>period (FW_word p (q-p)) p\<close> \<open>p \<le> \<^bold>|FW_word p (q - p)\<^bold>|\<close>]
         by presburger
 
 \<comment> \<open>claim 3\<close>
-      have "periodN (FW_word p q) q"
-        using ext_per_sum[OF \<open>periodN (FW_word p (q - p)) p\<close> \<open>periodN (FW_word p (q - p)) (q - p)\<close> \<open>p \<le> \<^bold>|FW_word p (q - p)\<^bold>|\<close>, folded fw, unfolded \<open>p + (q-p) = q\<close>].
+      have "period (FW_word p q) q"
+        using ext_per_sum[OF \<open>period (FW_word p (q - p)) p\<close> \<open>period (FW_word p (q - p)) (q - p)\<close> \<open>p \<le> \<^bold>|FW_word p (q - p)\<^bold>|\<close>, folded fw, unfolded \<open>p + (q-p) = q\<close>].
 
 \<comment> \<open>claim 4\<close>
-      have "\<not> periodN (FW_word p q) ?d"
-        using \<open>\<not> periodN (FW_word p (q -p)) (gcd p (q-p))\<close>
-        unfolding \<open>?d = ?d'\<close>[symmetric]
-        using periodN_fac[of "take p (FW_word p (q - p))" "FW_word p (q - p)" \<epsilon> "?d", unfolded append_Nil2,
+      have "\<not> period (FW_word p q) ?d"                   
+        using \<open>\<not> period (FW_word p (q -p)) (gcd p (q-p))\<close> 
+        unfolding \<open>?d = ?d'\<close>[symmetric]  
+        using period_fac[of "take p (FW_word p (q - p))" "FW_word p (q - p)" \<epsilon> "?d", unfolded append_Nil2, 
                           OF _ \<open>FW_word p (q - p) \<noteq> \<epsilon>\<close>, folded fw] by blast
       thus ?thesis
-        using \<open>periodN (FW_word p q) p\<close> \<open>periodN (FW_word p q) q\<close> \<open>\<^bold>|FW_word p q\<^bold>| = p + q - ?d - 1\<close> by blast
+        using \<open>period (FW_word p q) p\<close> \<open>period (FW_word p q) q\<close> \<open>\<^bold>|FW_word p q\<^bold>| = p + q - ?d - 1\<close> by blast 
     qed
   qed
 qed
 
 theorem fw_word: assumes "\<not> p dvd q" "\<not> q dvd p"
-  shows "\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1" and "periodN (FW_word p q) p" and  "periodN (FW_word p q) q" and "\<not> periodN (FW_word p q) (gcd p q)"
+  shows "\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1" and "period (FW_word p q) p" and  "period (FW_word p q) q" and "\<not> period (FW_word p q) (gcd p q)"
   using fw_word'[OF assms] by blast+
 
 text\<open>Calculation examples\<close>
 
-value "FW_word 3 7"
-value "FW_word 5 7"
-value "FW_word 5 13"
-value "FW_word 4 6"
-value "FW_word 12 18"
+(* value "FW_word 3 7" *)
+(* value "FW_word 5 7" *)
+(* value "FW_word 5 13" *)
+(* value "FW_word 4 6" *)
+(* value "FW_word 12 18" *)
 
 section "Other variants of the periodicity lemma"
 
 text \<open>Periodicity lemma is one of the most frequent tools in Combinatorics on words.
    Here are some useful variants.\<close>
 
-lemma fac_two_conjug_prim_root:
+lemma fac_two_conjug_primroot:
   assumes facs: "u \<le>f r\<^sup>@k" "u \<le>f s\<^sup>@l" and nemps: "r \<noteq> \<epsilon>" "s \<noteq> \<epsilon>" and len: "\<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| - gcd (\<^bold>|r\<^bold>|) (\<^bold>|s\<^bold>|) \<le> \<^bold>|u\<^bold>|"
   shows "\<rho> r \<sim> \<rho> s"
 proof -
   obtain r' s' where prefr': "u \<le>p r'\<^sup>@k" and prefs': "u \<le>p s'\<^sup>@l"
                and   conjugs: "r \<sim> r'" "s \<sim> s'"
     using facs by (elim fac_pow_pref_conjug)
   have rootr': "u \<le>p r' \<cdot> u" and roots': "u \<le>p s' \<cdot> u"
-    using pref_prod_root[OF prefr'] pref_prod_root[OF prefs'].
+    using pref_prod_root[OF prefr'] pref_prod_root[OF prefs']. 
   have nemps': "r' \<noteq> \<epsilon>" "s'\<noteq> \<epsilon>" using nemps conjugs conjug_nemp_iff by blast+
   have "\<^bold>|r'\<^bold>| + \<^bold>|s'\<^bold>| - gcd (\<^bold>|r'\<^bold>|) (\<^bold>|s'\<^bold>|) \<le> \<^bold>|u\<^bold>|" using len
     unfolding conjug_len[OF \<open>r \<sim> r'\<close>] conjug_len[OF \<open>s \<sim> s'\<close>].
   from per_lemma_comm[OF roots' rootr' this]  have "r' \<cdot> s' = s' \<cdot> r'".
-  then have "\<rho> r' = \<rho> s'" using comm_primroots[OF nemps'] by force
-  also have "\<rho> s \<sim> \<rho> s'" using conjug_prim_root[OF \<open>s \<sim> s'\<close> \<open>s \<noteq> \<epsilon>\<close>].
-  also have [symmetric]: "\<rho> r \<sim> \<rho> r'" using conjug_prim_root[OF \<open>r \<sim> r'\<close> \<open>r \<noteq> \<epsilon>\<close>].
+  then have "\<rho> r' = \<rho> s'" using comm_primroots[OF nemps'] by force 
+  also have "\<rho> s \<sim> \<rho> s'" using conjug_primroot[OF \<open>s \<sim> s'\<close>].
+  also have [symmetric]: "\<rho> r \<sim> \<rho> r'" using conjug_primroot[OF \<open>r \<sim> r'\<close>].
   finally show "\<rho> r \<sim> \<rho> s"..
 qed
 
-lemma fac_two_conjug_prim_root':
+lemma fac_two_conjug_primroot':
   assumes facs: "u \<le>f r\<^sup>@k" "u \<le>f s\<^sup>@l" and "u \<noteq> \<epsilon>" and len: "\<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| - gcd (\<^bold>|r\<^bold>|) (\<^bold>|s\<^bold>|) \<le> \<^bold>|u\<^bold>|"
   shows "\<rho> r \<sim> \<rho> s"
 proof -
   have nemps: "r \<noteq> \<epsilon>" "s \<noteq> \<epsilon>" using facs \<open>u \<noteq> \<epsilon>\<close> by auto
-  show "conjugate (\<rho> r) (\<rho> s)" using fac_two_conjug_prim_root[OF facs nemps len].
+  show "conjugate (\<rho> r) (\<rho> s)" using fac_two_conjug_primroot[OF facs nemps len].
 qed
 
 lemma fac_two_nconj_prim_pow:
   assumes prims: "primitive r" "primitive s" and "\<not> r \<sim> s"
       and facs: "u \<le>f r\<^sup>@k" "u \<le>f s\<^sup>@l"
   shows "\<^bold>|u\<^bold>| < \<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| - gcd (\<^bold>|r\<^bold>|) (\<^bold>|s\<^bold>|)"
-  using \<open>\<not> r \<sim> s\<close> fac_two_conjug_prim_root[OF facs prim_nemp prim_nemp leI, OF prims]
+  using \<open>\<not> r \<sim> s\<close> fac_two_conjug_primroot[OF facs prim_nemp prim_nemp leI, OF prims]
   unfolding prim_self_root[OF \<open>primitive r\<close>] prim_self_root[OF \<open>primitive s\<close>]
   by (rule contrapos_np)
 
+lemma per_lemma_pref_suf: assumes "w \<le>p p \<cdot> w" and "w \<le>s w \<cdot> q" and "p \<noteq> \<epsilon>" and "q \<noteq> \<epsilon>" and
+  fw: "\<^bold>|p\<^bold>| + \<^bold>|q\<^bold>| - (gcd \<^bold>|p\<^bold>| \<^bold>|q\<^bold>|) \<le> \<^bold>|w\<^bold>|"
+obtains r s k l m where "p = (r \<cdot> s)\<^sup>@k" and "q = (s \<cdot> r)\<^sup>@l" and "w = (r \<cdot> s)\<^sup>@m \<cdot> r" and "primitive (r\<cdot>s)"
+proof-
+  obtain kp where "w \<le>f p\<^sup>@kp"
+    using per_root_fac[OF \<open>w \<le>p p \<cdot> w\<close> \<open>p \<noteq> \<epsilon>\<close>].
+  obtain kq where "w \<le>f q\<^sup>@kq"
+    using per_root_fac[reversed, OF \<open>w \<le>s w \<cdot> q\<close>] using \<open>q \<noteq> \<epsilon>\<close> by blast
+  from fac_two_conjug_primroot[OF \<open>w \<le>f p\<^sup>@kp\<close> \<open>w \<le>f q\<^sup>@kq\<close> \<open>p \<noteq> \<epsilon>\<close> \<open>q \<noteq> \<epsilon>\<close> fw]
+  have "\<rho> p \<sim> \<rho> q".
+  have "\<^bold>|p\<^bold>| \<le> \<^bold>|w\<^bold>|"
+    using per_lemma_len_le[OF fw] \<open>q \<noteq> \<epsilon>\<close> by simp
+  hence "\<^bold>|\<rho> p\<^bold>| \<le> \<^bold>|w\<^bold>|" and "\<^bold>|\<rho> q\<^bold>| \<le> \<^bold>|w\<^bold>|"
+    using  conjug_len[OF \<open>\<rho> p \<sim> \<rho> q\<close>] dual_order.trans primroot_len_le[OF \<open>p \<noteq> \<epsilon>\<close>] by metis+  
+  hence "\<rho> q \<le>s w"
+    using \<open>w \<le>s w \<cdot> q\<close>  primroot_suf[OF \<open>q \<noteq> \<epsilon>\<close>] suffix_appendI suffix_length_suffix by metis
+  have "w \<le>p \<rho> p \<cdot> w"
+    using per_root_primroot[OF \<open>w \<le>p p \<cdot> w\<close> \<open>p \<noteq> \<epsilon>\<close>].
+  obtain r s k where "\<rho> p = r \<cdot> s" and  "w = (r \<cdot> s)\<^sup>@k \<cdot> r"
+    using  per_root_eq[OF \<open>w \<le>p \<rho> p \<cdot> w\<close> primroot_nemp[OF \<open>p \<noteq> \<epsilon>\<close>]].
+  have "\<^bold>|\<rho> q\<^bold>| = \<^bold>|s \<cdot> r\<^bold>|"
+    using  lenarg[OF \<open>\<rho> p = r \<cdot> s\<close>] conjug_len[OF \<open>\<rho> p \<sim> \<rho> q\<close>] unfolding lenmorph by linarith
+  hence "\<rho> q = s \<cdot> r"
+  proof (cases "k = 0")
+    assume "k = 0"
+    hence "w = r" 
+      using \<open>w = (r \<cdot> s)\<^sup>@k \<cdot> r\<close> pow_zero by force
+    hence "s = \<epsilon>"
+      using \<open>\<^bold>|\<rho> p\<^bold>| \<le> \<^bold>|w\<^bold>|\<close> \<open>\<rho> p = r \<cdot> s\<close> by auto
+    have "\<rho> q = r"
+      using conjug_sym[OF \<open>\<rho> p \<sim> \<rho> q\<close>] suf_same_len[OF \<open>\<rho> q \<le>s w\<close> conjug_len]
+      unfolding \<open>s = \<epsilon>\<close> clean_emp \<open>w = r\<close> \<open>\<rho> p = r \<cdot> s\<close> by blast
+   thus "\<rho> q = s \<cdot> r"
+      using \<open>s = \<epsilon>\<close> by simp
+  next
+    assume "k \<noteq> 0"
+    hence "w = (r \<cdot> (s \<cdot> r)\<^sup>@(k-1)) \<cdot> s \<cdot> r" 
+      unfolding \<open>w = (r \<cdot> s)\<^sup>@k \<cdot> r\<close> by comparison  
+    from suf_prod_eq[OF \<open>\<rho> q \<le>s w\<close>[unfolded this] \<open>\<^bold>|\<rho> q\<^bold>| = \<^bold>|s \<cdot> r\<^bold>|\<close>]   
+    show "\<rho> q = s \<cdot> r".
+  qed
+  from that[OF _ _ \<open>w = (r \<cdot> s)\<^sup>@k \<cdot> r\<close>] \<open>\<rho> q = s \<cdot> r\<close> \<open>q \<noteq> \<epsilon>\<close> \<open>\<rho> p = r \<cdot> s\<close> \<open>p \<noteq> \<epsilon>\<close>    
+  show thesis
+    using primroot_expE primroot_prim by metis
+qed
+
 end
diff --git a/thys/Combinatorics_Words/ROOT b/thys/Combinatorics_Words/ROOT
--- a/thys/Combinatorics_Words/ROOT
+++ b/thys/Combinatorics_Words/ROOT
@@ -1,16 +1,20 @@
 chapter AFP
 
-session Combinatorics_Words (AFP)  = "HOL-Library" +
-  options [timeout = 600,document_variants = "document=-unimportant:manual=/proof,/ML,+unimportant"]
+session Combinatorics_Words (AFP)  = "HOL-Eisbach" +
+  options [timeout = 600]
   theories
     Arithmetical_Hints
+    Border_Array
     Reverse_Symmetry
-    CoWBasic   
+    CoWBasic
     Submonoids
+    Morphisms
     Periodicity_Lemma
-    Lyndon_Schutzenberger    
+    Equations_Basic
+    Binary_Code_Morphisms
+    Lyndon_Schutzenberger
   theories [document = false]
     CoWAll
   document_files
     root.tex
     root.bib
diff --git a/thys/Combinatorics_Words/Reverse_Symmetry.thy b/thys/Combinatorics_Words/Reverse_Symmetry.thy
--- a/thys/Combinatorics_Words/Reverse_Symmetry.thy
+++ b/thys/Combinatorics_Words/Reverse_Symmetry.thy
@@ -1,424 +1,713 @@
 (*  Title:      CoW/Reverse_Symmetry.thy
     Author:     Martin Raška, Charles University
+
+Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/
 *)
 
 theory Reverse_Symmetry
   imports Main
 begin
 
 chapter "Reverse symmetry"
 
 text \<open>This theory deals with a mechanism which produces new facts on lists from already known facts
 by the reverse symmetry of lists, induced by the mapping @{term rev}.
 It constructs the rule attribute ``reversed'' which produces the symmetrical fact using so-called
 reversal rules, which are rewriting rules that may be applied to obtain the symmetrical fact.
 An example of such a reversal rule is the already existing @{thm rev_append[symmetric, no_vars]}.
 Some additional reversal rules are given in this theory.
 
 The symmetrical fact 'A[reversed]' is constructed from the fact 'A' in the following manner:
   1. each schematic variable @{term "xs::'a list"} of type @{typ "'a list"}
 is instantiated by @{term "rev xs"};
   2. constant Nil is substituted by @{term "rev Nil"};
   3. each quantification of @{typ "'a list"} type variable @{term "\<And>(xs::'a list). P xs"}
 is substituted by (logically equivalent) quantification @{term "\<And>xs. P (rev xs)"},
 similarly for $\forall$, $\exists$ and $\exists!$ quantifiers; each bounded quantification of @{typ "'a list"} type
 variable @{term "\<forall>(xs::'a list) \<in> A. P xs"} is substituted by (logically equivalent)
 quantification @{term "\<forall>xs\<in>rev ` A. P (rev xs)"}, similarly for bounded $\exists$ quantifier;
   4. simultaneous rewrites according to a the current list of reversal rules are performed;
   5. final correctional rewrites related to reversion of @{const "Cons"} are performed.
 
 List of reversal rules is maintained by declaration attribute ``reversal\_rule'' with standard
 ``add'' and ``del'' options. 
 
 See examples at the end of the file.
 \<close>
 
 
 section \<open>Quantifications and maps\<close>
 
 lemma all_surj_conv: assumes "surj f" shows "(\<And>x. PROP P (f x)) \<equiv> (\<And>y. PROP P y)"
 proof
   fix y assume "\<And>x. PROP P (f x)"
   then have "PROP P (f (inv f y))".
   then show "PROP P y" unfolding surj_f_inv_f[OF assms].
 qed
 
 lemma All_surj_conv: assumes "surj f" shows "(\<forall>x. P (f x)) \<longleftrightarrow> (\<forall>y. P y)"
 proof (intro iffI allI)
   fix y assume "\<forall>x. P (f x)"
   then have "P (f (inv f y))"..
   then show "P y" unfolding surj_f_inv_f[OF assms].
 qed simp
 
 lemma Ex_surj_conv: assumes "surj f" shows "(\<exists>x. P (f x)) \<longleftrightarrow> (\<exists>y. P y)"
 proof
   assume "\<exists>x. P (f x)"
   then obtain x where "P (f x)"..
   then show "\<exists>x. P x"..
 next 
   assume "\<exists>y. P y"
   then obtain y where "P y"..
   then have "P (f (inv f y))" unfolding surj_f_inv_f[OF assms].
   then show "\<exists>x. P (f x)"..
 qed
 
 lemma Ex1_bij_conv: assumes "bij f" shows "(\<exists>!x. P (f x)) \<longleftrightarrow> (\<exists>!y. P y)"
 proof
   have imp: "\<exists>!y. Q y" if bij: "bij g" and ex1: "\<exists>!x. Q (g x)" for g Q
   proof -
     from ex1E[OF ex1, rule_format]
     obtain x where ex: "Q (g x)" and uniq: "\<And>x'. Q (g x') \<Longrightarrow> x' = x" by blast
     {
       fix y assume "Q y"
       then have "Q (g (inv g y))" unfolding surj_f_inv_f[OF bij_is_surj[OF bij]].
       from uniq[OF this] have "x = inv g y"..
       then have "y = g x" unfolding bij_inv_eq_iff[OF bij]..
     }
     with ex show "\<exists>!y. Q y"..
   qed
   show "\<exists>!x. P (f x) \<Longrightarrow> \<exists>!y. P y" using imp[OF assms].
   assume "\<exists>!y. P y"
   then have "\<exists>!y. P (f (inv f y))" unfolding surj_f_inv_f[OF bij_is_surj[OF assms]].
   from imp[OF bij_imp_bij_inv[OF assms] this]
   show "\<exists>!x. P (f x)".
 qed
 
 lemma Ball_inj_conv: assumes "inj f" shows "(\<forall>y\<in>f ` A. P (inv f y)) \<longleftrightarrow> (\<forall>x\<in>A. P x)"
   using ball_simps(9)[of f A "\<lambda>y. P (inv f y)"] unfolding inv_f_f[OF assms].
 
 lemma Bex_inj_conv: assumes "inj f" shows "(\<exists>y\<in>f ` A. P (inv f y)) \<longleftrightarrow> (\<exists>x\<in>A. P x)"
   using bex_simps(7)[of f A "\<lambda>y. P (inv f y)"] unfolding inv_f_f[OF assms].
 
 subsection \<open>Quantifications and reverse\<close>
 
-lemma rev_involution: "rev \<circ> rev = id"
+lemma rev_involution': "rev \<circ> rev = id"
   by auto
 
-lemma rev_bij: "bij rev" 
-  using o_bij[OF rev_involution rev_involution].
-
 lemma rev_inv: "inv rev = rev"
-  using inv_unique_comp[OF rev_involution rev_involution].
-
-lemmas all_rev_conv = all_surj_conv[OF bij_is_surj[OF rev_bij]]
-   and All_rev_conv = All_surj_conv[OF bij_is_surj[OF rev_bij]]
-   and Ex_rev_conv = Ex_surj_conv[OF bij_is_surj[OF rev_bij]]
-   and Ex1_rev_conv = Ex1_bij_conv[OF rev_bij]
-   and Ball_rev_conv = Ball_inj_conv[OF bij_is_inj[OF rev_bij], unfolded rev_inv]
-   and Bex_rev_conv = Bex_inj_conv[OF bij_is_inj[OF rev_bij], unfolded rev_inv]
+  using inv_unique_comp[OF rev_involution' rev_involution'].
 
 section \<open>Attributes\<close>
 
 context
 begin
 
-subsection \<open>Definitons of reverse wrapers\<close>
-
-private definition rev_Nil_wrap :: "'a list"
-  where "rev_Nil_wrap = rev Nil" 
-
-private definition all_rev_wrap :: "('a list \<Rightarrow> prop) \<Rightarrow> prop"
-  where "all_rev_wrap P \<equiv> (\<And>x. PROP P (rev x))"
-
-private definition All_rev_wrap :: "('a list \<Rightarrow> bool) \<Rightarrow> bool"
-  where "All_rev_wrap P = (\<forall>x. P (rev x))"
-
-private definition Ex_rev_wrap :: "('a list \<Rightarrow> bool) \<Rightarrow> bool"
-  where "Ex_rev_wrap P = (\<exists>x. P (rev x))"
-
-private definition Ex1_rev_wrap :: "('a list \<Rightarrow> bool) \<Rightarrow> bool"
-  where "Ex1_rev_wrap P = (\<exists>!x. P (rev x))"
-
-private definition Ball_rev_wrap :: "'a list set \<Rightarrow> ('a list \<Rightarrow> bool) \<Rightarrow> bool"
-  where "Ball_rev_wrap A P = (\<forall>x \<in> rev ` A. P (rev x))"
-
-private definition Bex_rev_wrap :: "'a list set \<Rightarrow> ('a list \<Rightarrow> bool) \<Rightarrow> bool"
-  where "Bex_rev_wrap A P = (\<exists>x \<in> rev ` A. P (rev x))"
-
-subsection \<open>Initial reversal rules\<close>
-
-private lemma rev_Nil: "rev Nil = Nil"
-  by simp
-
-private lemmas init_rev_wrap =
-  eq_reflection[OF trans[OF rev_Nil[symmetric] rev_Nil_wrap_def[symmetric]]]
-  transitive[OF all_rev_conv[symmetric] all_rev_wrap_def[symmetric], of P P for P]
-  eq_reflection[OF trans[OF All_rev_conv[symmetric] All_rev_wrap_def[symmetric], of P P for P]]
-  eq_reflection[OF trans[OF Ex_rev_conv[symmetric] Ex_rev_wrap_def[symmetric], of P P for P]] (* Ex_rev_wrapI *)
-  eq_reflection[OF trans[OF Ex1_rev_conv[symmetric] Ex1_rev_wrap_def[symmetric], of P P for P]]
-  eq_reflection[OF trans[OF Ball_rev_conv[symmetric] Ball_rev_wrap_def[symmetric], of P P for P]]
-  eq_reflection[OF trans[OF Bex_rev_conv[symmetric] Bex_rev_wrap_def[symmetric], of P P for P]]
-
-private lemma all_rev_unwrap: "all_rev_wrap (\<lambda>x. PROP P x) \<equiv> (\<And>x. PROP P (rev x))"
-  using all_rev_wrap_def.
-
-private lemma All_rev_unwrap: "All_rev_wrap (\<lambda>x. P x) = (\<forall>x. P (rev x))"
-  using All_rev_wrap_def.
-
-private lemma Ex_rev_unwrap: "Ex_rev_wrap (\<lambda>x. P x) = (\<exists>x. P (rev x))"
-  using Ex_rev_wrap_def.
-
-private lemma Ex1_rev_unwrap: "Ex1_rev_wrap (\<lambda>x. P x) = (\<exists>!x. P (rev x))"
-  using Ex1_rev_wrap_def.
-
-private lemma Ball_rev_unwrap: "Ball_rev_wrap A (\<lambda>x. P x) = (\<forall>x \<in> rev ` A. P (rev x))"
-  using Ball_rev_wrap_def.
-
-private lemma Bex_rev_unwrap: "Bex_rev_wrap A (\<lambda>x. P x) = (\<exists>x \<in> rev ` A. P (rev x))"
-  using Bex_rev_wrap_def.
-
-private lemmas init_rev_unwrap =
-  eq_reflection[OF rev_Nil_wrap_def]
-  all_rev_unwrap
-  eq_reflection[OF All_rev_unwrap]
-  eq_reflection[OF Ex_rev_unwrap]
-  eq_reflection[OF Ex1_rev_unwrap]
-  eq_reflection[OF Ball_rev_unwrap]
-  eq_reflection[OF Bex_rev_unwrap]
-
 subsection \<open>Cons reversion\<close>
 
 definition snocs :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list"
   where "snocs xs ys  = xs @ ys"
 
-lemma Cons_rev: "a # rev u = rev (snocs u [a])"
-  unfolding snocs_def by simp
+subsection \<open>Final corrections\<close>
 
 lemma snocs_snocs: "snocs (snocs xs (y # ys)) zs = snocs xs (y # snocs ys zs)"
   unfolding snocs_def by simp
 
-subsection \<open>Final corrections\<close>
-
 lemma snocs_Nil: "snocs [] xs = xs"
   unfolding snocs_def by simp
 
 lemma snocs_is_append: "snocs xs ys = xs @ ys"
   unfolding snocs_def..
 
 private lemmas final_correct1 =
+  snocs_snocs
+
+private lemmas final_correct2 =
   snocs_Nil
 
-private lemmas final_correct2 =
+private lemmas final_correct3 =
   snocs_is_append
 
 subsection \<open>Declaration attribute \<open>reversal_rule\<close>\<close>
 
 ML \<open>
 structure Reversal_Rules = 
   Named_Thms(
     val name = @{binding "reversal_rule"}
     val description = "Rules performing reverse-symmetry transformation on theorems on lists"
   )
 \<close>
 
 attribute_setup reversal_rule = 
   \<open>Attrib.add_del
     (Thm.declaration_attribute Reversal_Rules.add_thm)
     (Thm.declaration_attribute Reversal_Rules.del_thm)\<close>
   "maintaining a list of reversal rules"
 
-subsection \<open>Rule attribute \<open>reversed\<close>\<close>
+subsection \<open>Tracing attribute\<close>
 
 ML \<open>
-val eq_refl = @{thm eq_reflection}
+  val reversed_trace = Config.declare_bool ("reversed_trace", \<^here>) (K false);
+  val enable_tracing = Config.put_generic reversed_trace true
+  val tracing_attr = Thm.declaration_attribute (K enable_tracing)
+  val tracing_parser : attribute context_parser = Scan.lift (Scan.succeed tracing_attr)
+\<close>
 
-fun pure_eq_of th =
-  case Thm.prop_of th of
-    Const (\<^const_name>\<open>Pure.eq\<close>, _) $ _ $ _
-      => SOME (th)
-  | Const (\<^const_name>\<open>Trueprop\<close>, _) $ (Const (\<^const_name>\<open>HOL.eq\<close>, _) $ _ $ _ )
-      => SOME (th RS eq_refl)
-  | _ => NONE
+attribute_setup reversed_trace = tracing_parser "reversed trace configuration"
 
-val init_rev_wrap = @{thms init_rev_wrap}
-val init_unwrap = @{thms init_rev_unwrap}
-val final_correct1 = map_filter pure_eq_of @{thms final_correct1}
-val final_correct2 = map_filter pure_eq_of @{thms final_correct2}
+subsection \<open>Rule attribute \<open>reversed\<close>\<close>
 
-fun reverse ths context th =
+private lemma rev_Nil: "rev [] \<equiv> []"
+  by simp
+
+private lemma map_Nil: "map f [] \<equiv> []"
+  by simp
+
+private lemma image_empty: "f ` Set.empty \<equiv> Set.empty"
+  by simp
+
+definition COMP :: "('b \<Rightarrow> prop) \<Rightarrow> ('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> prop" (infixl "oo" 55)
+  where "F oo g \<equiv> (\<lambda>x. F (g x))"
+
+lemma COMP_assoc: "F oo (f o g) \<equiv> (F oo f) oo g"
+  unfolding COMP_def o_def.
+
+private lemma image_comp_image: "(`) f \<circ> (`) g \<equiv> (`) (f \<circ> g)"
+  unfolding comp_def image_comp.
+
+private lemma rev_involution: "rev \<circ> rev \<equiv> id"
+  unfolding comp_def rev_rev_ident id_def.
+
+private lemma map_involution: assumes "f \<circ> f \<equiv> id" shows "(map f) \<circ> (map f) \<equiv> id"
+  unfolding map_comp_map \<open>f \<circ> f \<equiv> id\<close> List.map.id.
+
+private lemma image_involution: assumes "f \<circ> f \<equiv> id" shows "(image f) \<circ> (image f) \<equiv> id"
+  unfolding image_comp_image \<open>f \<circ> f \<equiv> id\<close> image_id.
+
+private lemma rev_map_comm: "rev \<circ> map f \<equiv> map f \<circ> rev"
+  unfolding comp_def rev_map.
+
+private lemma involut_comm_comp: assumes "f o f \<equiv> id" and "g o g \<equiv> id" and "f o g \<equiv> g o f"
+  shows "(f \<circ> g) \<circ> (f \<circ> g) \<equiv> id"
+  by (simp add: comp_assoc comp_assoc[symmetric] assms)
+
+private lemma rev_map_involution: assumes "g o g \<equiv> id"
+  shows "(rev \<circ> map g) \<circ> (rev \<circ> map g) \<equiv> id"
+  using involut_comm_comp[OF rev_involution map_involution[OF \<open>g o g \<equiv> id\<close>] rev_map_comm].
+
+private lemma prop_abs_subst: assumes "f o f \<equiv> id" shows "(\<lambda>x. F (f x)) oo f \<equiv> (\<lambda>x. F x)"
+  unfolding COMP_def o_apply[symmetric] unfolding \<open>f o f \<equiv> id\<close> id_def.
+
+private lemma prop_abs_subst_comm: assumes "f o f \<equiv> id" and "g o g \<equiv> id" and "f o g \<equiv> g o f"
+  shows "(\<lambda>x. F (f (g x))) oo (f o g) \<equiv> (\<lambda>x. F x)"
+  unfolding \<open>f o g \<equiv> g o f\<close> unfolding COMP_assoc
+  unfolding prop_abs_subst[OF \<open>g o g \<equiv> id\<close>, of "\<lambda>x. F (f x)"] prop_abs_subst[OF \<open>f o f \<equiv> id\<close>].
+
+private lemma prop_abs_subst_rev_map: assumes "g o g \<equiv> id"
+  shows "(\<lambda>x. F (rev (map g x))) oo (rev o map g) \<equiv> (\<lambda>x. F x)"
+  using prop_abs_subst_comm[OF rev_involution map_involution[OF \<open>g o g \<equiv> id\<close>] rev_map_comm].
+
+private lemma obj_abs_subst: assumes "f o f \<equiv> id" shows "(\<lambda>x. F (f x)) o f \<equiv> (\<lambda>x. F x)"
+  unfolding comp_def unfolding o_apply[of f, symmetric] \<open>f o f \<equiv> id\<close> id_def.
+
+private lemma obj_abs_subst_comm: assumes "f o f \<equiv> id" and "g o g \<equiv> id" and "f o g \<equiv> g o f"
+  shows "(\<lambda>x. F (f (g x))) o (f o g) \<equiv> (\<lambda>x. F x)"
+  unfolding \<open>f o g \<equiv> g o f\<close> unfolding comp_assoc[symmetric]
+  unfolding obj_abs_subst[OF \<open>g o g \<equiv> id\<close>, of "\<lambda>x. F (f x)"] obj_abs_subst[OF \<open>f o f \<equiv> id\<close>].
+
+private lemma obj_abs_subst_rev_map: assumes "g o g \<equiv> id"
+  shows "(\<lambda>x. F (rev (map g x))) o (rev o map g) \<equiv> (\<lambda>x. F x)"
+  using obj_abs_subst_comm[OF rev_involution map_involution[OF \<open>g o g \<equiv> id\<close>] rev_map_comm].
+
+ML \<open>
+
+local
+  fun comp_const T = Const(\<^const_name>\<open>comp\<close>, (T --> T) --> (T --> T) --> T --> T)
+  fun rev_const T = Const(\<^const_name>\<open>rev\<close>, T --> T)
+  fun map_const S T = Const(\<^const_name>\<open>map\<close>, (S --> S) --> T --> T)
+  fun image_const S T = Const(\<^const_name>\<open>image\<close>, (S --> S) --> T --> T)
+
+  val rev_Nil_thm = @{thm rev_Nil}
+  val map_Nil_thm = @{thm map_Nil}
+  val image_empty_thm = @{thm image_empty}
+  val rev_involut_thm = @{thm rev_involution}
+  val map_involut_thm = @{thm map_involution}
+  val image_involut_thm = @{thm image_involution}
+  val rev_map_comm_thm = @{thm rev_map_comm}
+  val involut_comm_comp_thm = @{thm involut_comm_comp}
+  fun abs_subst_thm T =
+    if T = propT then @{thm prop_abs_subst} else @{thm obj_abs_subst}
+  fun abs_subst_rev_map_thm T =
+    if T = propT then @{thm prop_abs_subst_rev_map} else @{thm obj_abs_subst_rev_map}
+
+  fun comp T f gs = fold (fn f => fn g =>
+        (comp_const T $ f $ g)) gs f
+  fun app ctxt gs ct = fold_rev (fn g => fn ct' =>
+        Thm.apply (Thm.cterm_of ctxt g) ct') gs ct
+in
+
+  fun subst ctxt T ct =
+    let
+      fun tr (T as Type(\<^type_name>\<open>list\<close>, [S])) = [rev_const T] @ (
+          case tr S of
+            [] => []
+          | (g :: gs') => [map_const S T $ comp S g gs'])
+        | tr (T as Type(\<^type_name>\<open>set\<close>, [S])) = (
+          case tr S of
+            [] => []
+          | (g :: gs') => [image_const S T $ comp S g gs'])
+        | tr _ = []
+    in app ctxt (tr T) ct end
+
+  fun abs_cv T U ct =
+    let
+      fun tr_eq (T as Type(\<^type_name>\<open>list\<close>, [S])) =
+            rev_involut_thm :: (
+            case tr_eq S of
+              [] => []
+            | [f_eq] => [f_eq RS map_involut_thm]
+            | [f_eq, g_eq] =>
+                [([f_eq, g_eq, rev_map_comm_thm] MRS involut_comm_comp_thm) RS map_involut_thm])
+        | tr_eq (T as Type(\<^type_name>\<open>set\<close>, [S])) = (
+            case tr_eq S of
+              [] => []
+            | [f_eq] => [f_eq RS image_involut_thm]
+            | [f_eq, g_eq] =>
+                [([f_eq, g_eq, rev_map_comm_thm] MRS involut_comm_comp_thm) RS image_involut_thm])
+        | tr_eq _ = []
+    in case tr_eq T of
+      [] => Thm.reflexive ct
+    | [f_inv] =>
+        [Thm.reflexive ct, Thm.symmetric (f_inv RS abs_subst_thm U)] MRS transitive_thm
+    | [f_inv, g_inv] =>
+        [Thm.reflexive ct, Thm.symmetric (g_inv RS abs_subst_rev_map_thm U)] MRS transitive_thm
+    end;
+
+  fun Nil_cv ctxt T ct =
+    ((Conv.try_conv o Conv.arg_conv o Conv.rewr_conv) map_Nil_thm
+    then_conv (Conv.try_conv o Conv.rewr_conv) rev_Nil_thm) (subst ctxt T ct)
+      |> Thm.symmetric
+  
+  fun empty_cv ctxt T ct =
+    (Conv.try_conv o Conv.rewr_conv) image_empty_thm (subst ctxt T ct)
+      |> Thm.symmetric
+
+end
+
+fun initiate_cv ctxt ct =
+  case Thm.term_of ct of
+    _ $ _ => Conv.comb_conv (initiate_cv ctxt) ct
+  | Abs(_, T, b) => (Conv.abs_conv (initiate_cv o snd) ctxt then_conv abs_cv T (fastype_of b)) ct
+  | Const(\<^const_name>\<open>Nil\<close>, T) => Nil_cv ctxt T ct
+  | Const(\<^const_name>\<open>bot\<close>, T as Type(\<^type_name>\<open>set\<close>, _)) => empty_cv ctxt T ct
+  | _ => Thm.reflexive ct
+\<close>
+
+ML \<open>
+
+fun trace_rule_prems_proof ctxt rule goals rule_prems rule' =
+  if not (Config.get ctxt reversed_trace) then () else
+    let
+      val ctxt_prems = Raw_Simplifier.prems_of ctxt
+      val np = Thm.nprems_of rule
+      val np' = Thm.nprems_of rule'
+      val pretty_term = Syntax.pretty_term ctxt
+      val pretty_thm = pretty_term o Thm.prop_of
+      val success = rule_prems |> List.all is_some
+      val sendback = Active.make_markup Markup.sendbackN
+        {implicit = false, properties = [Markup.padding_command]}
+      val _ = [
+        [ 
+          "Trying to use conditional reverse rule:" |> Pretty.para,
+          rule |> pretty_thm
+        ] |> Pretty.fbreaks |> Pretty.block,
+        [(if null ctxt_prems 
+          then "No context premises."
+          else "Context premises:"
+         ) |> Pretty.para
+        ] @ (
+          ctxt_prems |> map (Pretty.item o single o pretty_thm)
+        ) |> Pretty.fbreaks |> Pretty.block,
+        ( if success then [
+          "Successfully derived unconditional reverse rule:" |> Pretty.para,
+          rule' |> pretty_thm
+        ] else [
+          "Unable to prove " ^ string_of_int np ^ " out of " ^ string_of_int np' ^ " rule premises:\n"
+            |> Pretty.para
+        ] @ (
+          (goals ~~ rule_prems) |> map_filter (
+            fn (goal, NONE) => SOME ([
+                "lemma" |> Pretty.str, Pretty.brk 1,
+                goal |> pretty_term |> Pretty.quote, Pretty.fbrk,
+                "sorry" |> Pretty.str
+              ] |> curry Pretty.blk 0 |> Pretty.mark sendback |> single |> Pretty.item)
+            | _ => NONE
+          )
+        )) |> Pretty.fbreaks |> Pretty.block
+      ] |> Pretty.chunks |> Pretty.string_of |> tracing
+    in () end
+
+fun full_resolve ctxt prem i =
+  let
+    val tac = resolve_tac ctxt [prem] THEN_ALL_NEW blast_tac ctxt
+  in rule_by_tactic ctxt (tac i) end
+
+fun prover method ss ctxt rule =
+  let
+    val ctxt_prems = Raw_Simplifier.prems_of ctxt
+    val rule_prems' = Logic.strip_imp_prems (Thm.prop_of rule)
+    val goals = rule_prems' |> map (fn prem =>
+      Logic.list_implies (map Thm.prop_of ctxt_prems, prem));
+    val ctxt' = ctxt |> put_simpset ss
+    fun prove t = SOME (Goal.prove ctxt' [] [] t
+      (fn {context = goal_ctxt, prems} => NO_CONTEXT_TACTIC goal_ctxt (method goal_ctxt prems)))
+      handle ERROR _ =>  NONE
+    val ths = goals |> map prove
+    val gen_ctxt_prems = map (Variable.gen_all ctxt) ctxt_prems
+    fun full_resolve1 prem = full_resolve ctxt prem 1
+    val rule_prems = ths |> (map o Option.map) (fold full_resolve1 gen_ctxt_prems)
+    val rule' = (fold o curry) (
+      fn (SOME th, rule') => rule' |> full_resolve1 th
+      | (NONE, rule') => Drule.rotate_prems 1 rule'
+      ) rule_prems rule
+    val nprems = Thm.nprems_of rule'
+    val _ = trace_rule_prems_proof ctxt rule goals rule_prems rule'
+  in if nprems = 0 then SOME rule' else NONE end
+
+fun rewrite _ _ [] = Thm.reflexive
+  | rewrite method ctxt thms =
+      let
+        val p = prover method (simpset_of ctxt)
+        val ctxt' = Raw_Simplifier.init_simpset thms ctxt
+      in
+        Raw_Simplifier.rewrite_cterm (true, true, true) p ctxt'
+      end
+
+fun rewrite_rule method ctxt = Conv.fconv_rule o rewrite method ctxt;
+
+fun meta_reversal_rules ctxt extra =
+  map (Local_Defs.meta_rewrite_rule ctxt) (extra @ Reversal_Rules.get ctxt)
+
+fun reverse method extra_rules context th =
   let
     val ctxt = Context.proof_of context
-    val rules = map_filter pure_eq_of (ths @ Reversal_Rules.get ctxt)
-    val vars = Term.add_vars (Thm.full_prop_of th) []
-    fun add_inst_vars [] inst_vars = inst_vars
-      | add_inst_vars ( ((v, i), T) :: vars ) inst_vars =
-          case T of
-            Type(\<^type_name>\<open>list\<close>, _) =>
-              add_inst_vars vars (
-                (
-                  ((v, i), T),
-                  Thm.cterm_of ctxt 
-                    ( Const(\<^const_name>\<open>rev\<close>, Type(\<^type_name>\<open>fun\<close>, [T, T])) $ Var((v, i), T) )
-                ) :: inst_vars
-              )
-          | _ => add_inst_vars vars inst_vars
+    val final_correct1 = map (Local_Defs.meta_rewrite_rule ctxt) @{thms final_correct1}
+    val final_correct2 = map (Local_Defs.meta_rewrite_rule ctxt) @{thms final_correct2}
+    val final_correct3 = map (Local_Defs.meta_rewrite_rule ctxt) @{thms final_correct3}
+    val rules = meta_reversal_rules ctxt extra_rules
+    val cvars = Thm.add_vars th Vars.empty
+    val cvars' = Vars.map ((subst ctxt o snd)) cvars
+    val th_subst = Thm.instantiate (TVars.empty, cvars') th
+    val ((_, [th_import]), ctxt') = Variable.import true [th_subst] ctxt
+    val th_init = th_import |> Conv.fconv_rule (initiate_cv ctxt')
+    val th_rev = th_init |> rewrite_rule method ctxt' rules
+    val th_corr = th_rev
+          |> Raw_Simplifier.rewrite_rule ctxt' final_correct1
+          |> Raw_Simplifier.rewrite_rule ctxt' final_correct2
+          |> Raw_Simplifier.rewrite_rule ctxt' final_correct3
+    val th_export = th_corr |> singleton (Variable.export ctxt' ctxt)
   in
-    th
-    |> Drule.instantiate_normalize
-       (TVars.empty, Vars.make (add_inst_vars vars []))
-    |> Simplifier.rewrite_rule ctxt init_rev_wrap
-    |> Simplifier.rewrite_rule ctxt init_unwrap
-    |> Simplifier.rewrite_rule ctxt rules
-    |> Simplifier.rewrite_rule ctxt final_correct1
-    |> Simplifier.rewrite_rule ctxt final_correct2
+    Drule.zero_var_indexes th_export
   end
 
-val reversed = Scan.optional (Scan.lift (Args.add -- Args.colon) |-- Attrib.thms) []
-  >> (fn ths => Thm.rule_attribute [] (reverse ths))
+val default_method = SIMPLE_METHOD o CHANGED_PROP o auto_tac
+
+val solve_arg = Args.$$$ "solve"
+
+val extra_rules_parser = Scan.optional (Scan.lift (Args.add -- Args.colon) |-- Attrib.thms) []
+
+val solve_parser = Scan.lift (Scan.optional
+    (solve_arg -- Args.colon |-- Method.parse >> (fst #> Method.evaluate)) default_method
+  )
+
+val reversed = extra_rules_parser -- solve_parser
+  >> (fn (ths, method) => Thm.rule_attribute [] (reverse method ths))
 \<close>
 
 attribute_setup reversed =
   \<open>reversed\<close>
   "Transforms the theorem on lists to reverse-symmetric version"
 
 end
 
 section \<open>Declaration of basic reversal rules\<close>
 
-lemma hd_last_Nil: "hd [] = last []"
-  unfolding hd_def last_def by simp 
-
-lemma last_rev_hd: "last(rev xs) = hd xs"
-  by (induct xs, simp add: hd_last_Nil, simp)
+subsection \<open>Pure\<close>
 
-lemma hd_rev_last: "hd(rev xs) = last xs"
-  by (induct xs, simp add: hd_last_Nil, simp)
+  \<comment> \<open>\<^const>\<open>Pure.all\<close>\<close>
+lemma all_surj_conv' [reversal_rule]: assumes "surj f" shows "Pure.all (P oo f) \<equiv> Pure.all P"
+  unfolding COMP_def using all_surj_conv[OF assms].
 
-lemma tl_rev: "tl (rev xs) = rev (butlast xs)"
-  unfolding rev_swap[symmetric] butlast_rev[of "rev xs", symmetric] rev_rev_ident..
+subsection \<open>\<^theory>\<open>HOL.HOL\<close>\<close>
 
-lemma if_rev: "(if P then rev u else rev v) = rev (if P then u else v)"
+  \<comment> \<open>\<^const>\<open>HOL.eq\<close>\<close>
+lemmas [reversal_rule] = rev_is_rev_conv inj_eq
+
+  \<comment> \<open>\<^const>\<open>All\<close>\<close>
+lemma All_surj_conv' [reversal_rule]: assumes "surj f" shows "All (P o f) = All P"
+  unfolding comp_def using All_surj_conv[OF assms].
+
+  \<comment> \<open>\<^const>\<open>Ex\<close>\<close>
+lemma Ex_surj_conv' [reversal_rule]: assumes "surj f" shows "Ex (P o f) \<longleftrightarrow> Ex P"
+  unfolding comp_def using Ex_surj_conv[OF assms].
+
+  \<comment> \<open>\<^const>\<open>Ex1\<close>\<close>
+lemma Ex1_bij_conv' [reversal_rule]: assumes "bij f" shows "Ex1 (P o f) \<longleftrightarrow> Ex1 P"
+  unfolding comp_def using Ex1_bij_conv[OF assms].
+
+  \<comment> \<open>\<^const>\<open>If\<close>\<close>
+lemma if_image [reversal_rule]: "(if P then f u else f v) = f (if P then u else v)"
   by simp
 
-lemma rev_in_conv: "rev u \<in> A \<longleftrightarrow> u \<in> rev ` A"
-  using image_iff by fastforce
+subsection \<open>\<^theory>\<open>HOL.Set\<close>\<close>
 
-lemma in_lists_rev: "u \<in> lists A \<Longrightarrow> rev u \<in> lists A"
-  by auto
+  \<comment> \<open>\<^const>\<open>Collect\<close>\<close>
+lemma collect_image: "Collect (P \<circ> f) = f -` (Collect P)"
+  by fastforce
 
-lemma rev_in_lists: "rev u \<in> lists A \<Longrightarrow> u \<in> lists A"
+lemma collect_image' [reversal_rule]: assumes "f \<circ> f = id" shows "Collect (P \<circ> f) = f ` (Collect P)"
+  unfolding collect_image
+  unfolding bij_vimage_eq_inv_image[OF o_bij[OF assms assms]]
+  unfolding inv_unique_comp[OF assms assms]..
+
+  \<comment> \<open>\<^const>\<open>Ball\<close>\<close>
+lemma Ball_image [reversal_rule]: assumes "(g \<circ> f) ` A = A" shows "Ball (f ` A) (P \<circ> g) = Ball A P"
+  unfolding Ball_image_comp[symmetric] image_comp \<open>(g \<circ> f) ` A = A\<close>..
+
+  \<comment> \<open>\<^const>\<open>Bex\<close>\<close>
+lemma Bex_image_comp: "Bex (f ` A) g = Bex A (g \<circ> f)"
+  by simp
+
+lemma Bex_image [reversal_rule]: assumes "(g \<circ> f) ` A = A" shows "Bex (f ` A) (P \<circ> g) = Bex A P"
+  unfolding Bex_image_comp[symmetric] image_comp \<open>(g \<circ> f) ` A = A\<close>..
+                      
+  \<comment> \<open>\<^const>\<open>insert\<close>\<close>
+lemma insert_image [reversal_rule]: "insert (f x) (f ` X) = f ` (insert x X)"
+  by blast
+
+  \<comment> \<open>\<^const>\<open>List.member\<close>\<close>
+lemmas [reversal_rule] = inj_image_mem_iff
+
+subsection \<open>\<^theory>\<open>HOL.List\<close>\<close>
+
+  \<comment> \<open>\<^const>\<open>set\<close>\<close>
+lemmas [reversal_rule] = set_rev set_map
+
+  \<comment> \<open>\<^const>\<open>Cons\<close>\<close>
+lemma Cons_rev: "a # rev u = rev (snocs u [a])"
+  unfolding snocs_def by simp
+
+lemma Cons_map: "(f x) # (map f xs) = map f (x # xs)"
+  using list.simps(9)[symmetric].
+
+lemmas [reversal_rule] = Cons_rev Cons_map
+
+  \<comment> \<open>\<^const>\<open>hd\<close>\<close>
+lemmas [reversal_rule] = hd_rev hd_map
+
+  \<comment> \<open>\<^const>\<open>tl\<close>\<close>
+lemma tl_rev: "tl (rev xs) = rev (butlast xs)"
+  using butlast_rev[of "rev xs", symmetric] unfolding rev_swap rev_rev_ident.
+
+lemmas [reversal_rule] = tl_rev map_tl[symmetric]
+
+  \<comment> \<open>\<^const>\<open>last\<close>\<close>
+lemmas [reversal_rule] = last_rev last_map
+
+  \<comment> \<open>\<^const>\<open>butlast\<close>\<close>
+lemmas [reversal_rule] = butlast_rev map_butlast[symmetric]
+
+  \<comment> \<open>\<^const>\<open>List.coset\<close>\<close>
+lemma coset_rev: "List.coset (rev xs) = List.coset xs"
+  by simp
+
+lemma coset_map: assumes "bij f" shows "List.coset (map f xs) =  f ` List.coset xs"
+  using bij_image_Compl_eq[OF \<open>bij f\<close>, symmetric] unfolding coset_def set_map.
+
+lemmas [reversal_rule] = coset_rev coset_map
+
+  \<comment> \<open>\<^const>\<open>append\<close>\<close>
+lemmas [reversal_rule] = rev_append[symmetric] map_append[symmetric]
+
+  \<comment> \<open>\<^const>\<open>concat\<close>\<close>
+lemma concat_rev_map_rev: "concat (rev (map rev xs)) = rev (concat xs)"
+  using rev_concat[symmetric] unfolding rev_map.
+
+lemma concat_rev_map_rev': "concat (rev (map (rev \<circ> f) xs)) = rev (concat (map f xs))"
+  unfolding map_comp_map[symmetric] o_apply using concat_rev_map_rev.
+
+lemmas [reversal_rule] = concat_rev_map_rev concat_rev_map_rev'
+
+  \<comment> \<open>\<^const>\<open>drop\<close>\<close>
+lemmas [reversal_rule] = drop_rev drop_map
+  
+  \<comment> \<open>\<^const>\<open>take\<close>\<close>
+lemmas [reversal_rule] = take_rev take_map
+
+  \<comment> \<open>\<^const>\<open>nth\<close>\<close>
+lemmas [reversal_rule] = rev_nth nth_map
+
+  \<comment> \<open>\<^const>\<open>List.insert\<close>\<close>
+lemma list_insert_map [reversal_rule]:
+  assumes "inj f" shows "List.insert (f  x) (map f xs) = map f (List.insert x xs)"
+  unfolding List.insert_def set_map inj_image_mem_iff[OF \<open>inj f\<close>] Cons_map if_image..
+
+  \<comment> \<open>\<^const>\<open>List.union\<close>\<close>
+lemma list_union_map [reversal_rule]:
+  assumes "inj f" shows "List.union (map f xs) (map f ys) = map f (List.union xs ys)"
+proof (induction xs arbitrary: ys)
+  case (Cons a xs)
+  show ?case using Cons.IH unfolding List.union_def Cons_map[symmetric] fold.simps(2) o_apply
+    unfolding list_insert_map[OF \<open>inj f\<close>].
+qed (simp add: List.union_def)
+
+  \<comment> \<open>\<^const>\<open>length\<close>\<close>
+lemmas [reversal_rule] = length_rev length_map
+ 
+  \<comment> \<open>\<^const>\<open>rotate\<close>\<close>
+lemmas [reversal_rule] = rotate_rev rotate_map
+
+  \<comment> \<open>\<^const>\<open>lists\<close>\<close>
+lemma rev_in_lists: "rev u \<in> lists A \<longleftrightarrow> u \<in> lists A"
   by auto
 
-lemma rev_lists_conv: "rev ` lists A = lists A"
-proof (intro equalityI subsetI)
-  fix x
-  show "x \<in> rev ` lists A \<Longrightarrow> x \<in> lists A"
-    unfolding rev_in_conv[symmetric] using rev_in_lists.
-  show "x \<in> lists A \<Longrightarrow> x \<in> rev ` lists A"
-    unfolding rev_in_conv[symmetric] using in_lists_rev.
-qed
-
-lemma coset_rev: "List.coset (rev xs) = List.coset xs"
- by simp
+lemma map_in_lists: "inj f \<Longrightarrow> map f u \<in> lists (f ` A) \<longleftrightarrow> u \<in> lists A"
+  by (simp add: lists_image inj_image_mem_iff inj_mapI)
 
-lemmas [reversal_rule] =
-  Cons_rev
-  snocs_snocs
-  rev_append[symmetric]
-  last_rev_hd hd_rev_last
-  tl_rev butlast_rev
-  rev_is_rev_conv
-  length_rev
-  take_rev
-  drop_rev
-  rotate_rev
-  if_rev
-  rev_in_conv
-  rev_lists_conv
-  set_rev
-  coset_rev
+lemmas [reversal_rule] = rev_in_lists map_in_lists
+
+subsection \<open>Reverse Symmetry\<close>
+
+  \<comment> \<open>\<^const>\<open>snocs\<close>\<close>
+lemma snocs_map [reversal_rule]: "snocs (map f u) [f a] = map f (snocs u [a])"
+  unfolding snocs_def by simp
+
+section \<open>\<close>
+
+lemma bij_rev: "bij rev"
+  using o_bij[OF rev_involution' rev_involution'].
+
+lemma bij_map: "bij f \<Longrightarrow> bij (map f)"
+  using bij_betw_def inj_mapI lists_UNIV lists_image by metis
+
+lemma surj_map: "surj f \<Longrightarrow> surj (map f)"
+  using lists_UNIV lists_image by metis
+
+lemma bij_image: "bij f \<Longrightarrow> bij (image f)"
+  using bij_betw_Pow by force
+
+lemma inj_image: "inj f \<Longrightarrow> inj (image f)"
+  by (simp add: inj_on_image)
+
+lemma surj_image: "surj f \<Longrightarrow> surj (image f)"
+  using Pow_UNIV image_Pow_surj by metis
+
+lemmas [simp] =
+  bij_rev
+  bij_is_inj
+  bij_is_surj
+  bij_comp
+  inj_compose
+  comp_surj
+  bij_map
+  inj_mapI
+  surj_map
+  bij_image
+  inj_image
+  surj_image
 
 section \<open>Examples\<close>
 
 context
 begin
 
 subsection \<open>Cons and append\<close>
 
 private lemma example_Cons_append:
   assumes "xs = [a, b]" and "ys = [b, a, b]"
   shows "xs @ xs @ xs = a # b # a # ys"
 using assms by simp
 
 thm
   example_Cons_append
   example_Cons_append[reversed]
   example_Cons_append[reversed, reversed]
 
 thm
   not_Cons_self
   not_Cons_self[reversed]
 
 thm
   neq_Nil_conv
   neq_Nil_conv[reversed]
 
 subsection \<open>Induction rules\<close>
 
 thm
   list_nonempty_induct
   list_nonempty_induct[reversed] (* needs work *)
   list_nonempty_induct[reversed, where P="\<lambda>x. P (rev x)" for P, unfolded rev_rev_ident] 
 
 thm
   list_induct2
   list_induct2[reversed] (* needs work *)
   list_induct2[reversed, where P="\<lambda>x y. P (rev x) (rev y)" for P, unfolded rev_rev_ident]
 
 subsection \<open>hd, tl, last, butlast\<close>
 
 thm
   hd_append
   hd_append[reversed]
   last_append
 
 thm
   length_tl
   length_tl[reversed]
   length_butlast
 
 thm
   hd_Cons_tl
   hd_Cons_tl[reversed]
   append_butlast_last_id
   append_butlast_last_id[reversed]
 
 subsection \<open>set\<close>
 
 thm
   hd_in_set
   hd_in_set[reversed]
   last_in_set
 
 thm
   set_ConsD
   set_ConsD[reversed]
 
 thm
   split_list_first
   split_list_first[reversed]
 
 thm
   split_list_first_prop
   split_list_first_prop[reversed]
   split_list_first_prop[reversed, unfolded append_assoc append_Cons append_Nil]
   split_list_last_prop
 
 thm
   split_list_first_propE
   split_list_first_propE[reversed]
   split_list_first_propE[reversed, unfolded append_assoc append_Cons append_Nil]
   split_list_last_propE
 
 subsection \<open>rotate\<close>
 
-private lemma rotate1_hd_tl': "xs \<noteq> [] \<Longrightarrow> rotate 1 xs = tl xs @ [hd xs]"
+private lemma rotate1_hd_tl: "xs \<noteq> [] \<Longrightarrow> rotate 1 xs = tl xs @ [hd xs]"
   by (cases xs) simp_all
 
 thm
-  rotate1_hd_tl'
-  rotate1_hd_tl'[reversed]
+  rotate1_hd_tl
+  rotate1_hd_tl[reversed]
 
 end
 
 end
\ No newline at end of file
diff --git a/thys/Combinatorics_Words/Submonoids.thy b/thys/Combinatorics_Words/Submonoids.thy
--- a/thys/Combinatorics_Words/Submonoids.thy
+++ b/thys/Combinatorics_Words/Submonoids.thy
@@ -1,1058 +1,2503 @@
 (*  Title:      CoW/Submonoids.thy
     Author:     Štěpán Holub, Charles University
     Author:     Štěpán Starosta, CTU in Prague
+
+Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/
 *)
 
 theory Submonoids
   imports CoWBasic
 begin
 
 chapter \<open>Submonoids of a free monoid\<close>
 
 text\<open>This chapter deals with properties of submonoids of a free monoid, that is, with monoids of words.
 See more in Chapter 1 of @{cite Lo83}.
 \<close>
 
 section \<open>Hull\<close>
 
 text\<open>First, we define the hull of a set of words, that is, the monoid generated by them.\<close>
 
 inductive_set hull :: "'a list set \<Rightarrow> 'a list set" ("\<langle>_\<rangle>")
   for G where
-   emp_in:  "\<epsilon> \<in> \<langle>G\<rangle>" |
+   emp_in[simp]:  "\<epsilon> \<in> \<langle>G\<rangle>" |
    prod_cl:  "w1 \<in> G \<Longrightarrow> w2 \<in> \<langle>G\<rangle> \<Longrightarrow> w1 \<cdot> w2 \<in> \<langle>G\<rangle>"
 
 lemmas [intro] = hull.intros
 
-lemma hull_closed: "w1 \<in> \<langle>G\<rangle> \<Longrightarrow> w2 \<in> \<langle>G\<rangle> \<Longrightarrow> w1 \<cdot> w2 \<in> \<langle>G\<rangle>"
-  by (rule hull.induct[of w1 G "\<lambda> x. (x\<cdot>w2)\<in>\<langle>G\<rangle>"]) auto+
+lemma hull_closed[intro]: "w1 \<in> \<langle>G\<rangle> \<Longrightarrow> w2 \<in> \<langle>G\<rangle> \<Longrightarrow> w1 \<cdot> w2 \<in> \<langle>G\<rangle>"
+  by (rule hull.induct[of w1 G "\<lambda> x. (x\<cdot>w2)\<in>\<langle>G\<rangle>"]) auto+ 
 
 lemma gen_in [intro]: "w \<in> G \<Longrightarrow> w \<in> \<langle>G\<rangle>"
-  using hull.prod_cl by fastforce
+  using hull.prod_cl by fastforce 
 
-lemma hull_induct: assumes "x \<in> \<langle>G\<rangle>" "P \<epsilon>" "\<And>w. w \<in> G \<Longrightarrow> P w"
+lemma hull_induct: assumes "x \<in> \<langle>G\<rangle>" "P \<epsilon>" "\<And>w. w \<in> G \<Longrightarrow> P w" 
 "\<And>w1 w2. w1 \<in> \<langle>G\<rangle> \<Longrightarrow> P w1 \<Longrightarrow> w2 \<in> \<langle>G\<rangle> \<Longrightarrow> P w2 \<Longrightarrow> P (w1 \<cdot> w2)" shows  "P x"
-  using hull.induct[of _ _ P, OF \<open>x \<in> \<langle>G\<rangle>\<close>  \<open>P \<epsilon>\<close>]
+  using hull.induct[of _ _ P, OF \<open>x \<in> \<langle>G\<rangle>\<close>  \<open>P \<epsilon>\<close>]  
         assms by (simp add: gen_in)
+  
+lemma genset_sub[simp]: "G \<subseteq> \<langle>G\<rangle>"
+   using gen_in ..
 
-lemma genset_sub: "G \<subseteq> \<langle>G\<rangle>"
-   using gen_in ..
+lemma genset_sub_lists: "ws \<in> lists G \<Longrightarrow> ws \<in> lists \<langle>G\<rangle>"
+  using sub_lists_mono[OF genset_sub].
 
 lemma in_lists_conv_set_subset: "set ws \<subseteq> G \<longleftrightarrow> ws \<in> lists G"
   by blast
 
 lemma concat_in_hull [intro]:
   assumes "set ws \<subseteq> G"
   shows   "concat ws \<in> \<langle>G\<rangle>"
   using assms by (induction ws) auto
 
 lemma concat_in_hull' [intro]:
   assumes "ws \<in> lists G"
   shows   "concat ws \<in> \<langle>G\<rangle>"
   using assms by (induction ws) auto
 
-lemma hull_concat_lists0: "w \<in> \<langle>G\<rangle> \<Longrightarrow> (\<exists> ws \<in> lists G. concat ws = w)"
+lemma hull_concat_lists0: "w \<in> \<langle>G\<rangle> \<Longrightarrow> (\<exists> ws \<in> lists G. concat ws = w)" 
 proof(rule hull.induct[of _ G], simp)
   show "\<exists>ws\<in>lists G. concat ws = \<epsilon>"
     using concat.simps(1) lists.Nil[of G] exI[of "\<lambda> x. concat x = \<epsilon>", OF concat.simps(1)] by blast
   show " \<And>w1 w2. w1 \<in> G \<Longrightarrow> w2 \<in> \<langle>G\<rangle> \<Longrightarrow> \<exists>ws\<in>lists G. concat ws = w2 \<Longrightarrow> \<exists>ws\<in>lists G. concat ws = w1 \<cdot> w2"
-    by (metis Cons_in_lists_iff concat.simps(2))
+    using Cons_in_lists_iff concat.simps(2) by metis 
 qed
 
+lemma hull_concat_listsE: assumes "w \<in> \<langle>G\<rangle>" 
+  obtains ws where "ws \<in> lists G" and "concat ws = w"
+  using assms hull_concat_lists0 by auto 
+
 lemma hull_concat_lists: "\<langle>G\<rangle> = concat ` lists G"
-   unfolding image_iff  using hull_concat_lists0 by blast
+   using hull_concat_lists0 by blast
 
 lemma concat_tl: "x # xs \<in> lists G \<Longrightarrow> concat xs \<in> \<langle>G\<rangle>"
   by (simp add: hull_concat_lists)
 
 lemma nemp_concat_hull: assumes "us \<noteq> \<epsilon>" and "us \<in> lists G\<^sub>+"
   shows "concat us \<in> \<langle>G\<rangle>" and "concat us \<noteq> \<epsilon>"
   using assms by fastforce+
 
-
-lemma hull_mon: "A \<subseteq> B \<Longrightarrow> \<langle>A\<rangle> \<subseteq> \<langle>B\<rangle>"
-proof
+lemma hull_mono: "A \<subseteq> B \<Longrightarrow> \<langle>A\<rangle> \<subseteq> \<langle>B\<rangle>" 
+proof 
   fix x assume "A \<subseteq> B" "x \<in> \<langle>A\<rangle>"
-  thus "x \<in> \<langle>B\<rangle>"
+  thus "x \<in> \<langle>B\<rangle>" 
     unfolding image_def hull_concat_lists using sub_lists_mono[OF \<open>A \<subseteq> B\<close>]
     by blast
 qed
 
 lemma emp_gen_set: "\<langle>{}\<rangle> = {\<epsilon>}"
-  unfolding hull_concat_lists by auto
+  unfolding hull_concat_lists by auto 
 
 lemma hull_drop_one: "\<langle>G\<rangle> = \<langle>G\<^sub>+\<rangle>"
 proof (intro equalityI subsetI)
-  fix x assume "x \<in> \<langle>G\<rangle>" thus "x \<in> \<langle>G\<^sub>+\<rangle>"
+  fix x assume "x \<in> \<langle>G\<rangle>" thus "x \<in> \<langle>G\<^sub>+\<rangle>" 
     unfolding  hull_concat_lists using del_emp_concat lists_drop_emp' by blast
 next
   fix x assume "x \<in> \<langle>G\<^sub>+\<rangle>" thus "x \<in> \<langle>G\<rangle>"
     unfolding  hull_concat_lists image_iff by auto
-qed
+qed 
 
-lemma sing_gen_power: "u \<in> \<langle>{x}\<rangle> \<Longrightarrow> \<exists>k. u = x\<^sup>@k"
-  unfolding hull_concat_lists  using one_generated_list_power by auto
+lemma sing_gen_power: "u \<in> \<langle>{x}\<rangle> \<Longrightarrow> \<exists>k. u = x\<^sup>@k" 
+  unfolding hull_concat_lists  using one_generated_list_power by auto 
 
 lemma sing_gen: "w \<in> \<langle>{z}\<rangle> \<Longrightarrow> w \<in> z*"
   using rootI sing_gen_power by blast
 
+lemma sing_genE:
+  assumes "u \<in> \<langle>{x}\<rangle>"
+  obtains k where "x\<^sup>@k = u"
+using assms using sing_gen_power by blast
+
 lemma lists_gen_to_hull: "us \<in> lists G\<^sub>+ \<Longrightarrow> us \<in> lists \<langle>G\<rangle>\<^sub>+"
   using lists_mono genset_sub by force
 
-lemma rev_hull0: "x \<in> rev ` \<langle>G\<rangle> \<Longrightarrow> x \<in> \<langle>rev ` G\<rangle>"
+lemma rev_hull0: "x \<in> rev ` \<langle>G\<rangle> \<Longrightarrow> x \<in> \<langle>rev ` G\<rangle>" 
 proof-
   assume "x \<in> rev ` \<langle>G\<rangle>"
   then obtain xs where "x = rev (concat xs)" and "xs \<in> lists G"
     unfolding hull_concat_lists by auto
   thus "x \<in> \<langle>rev ` G\<rangle>" unfolding image_iff hull_concat_lists using rev_concat[of xs]
-    by fastforce
+    by fastforce  
 qed
 
 lemma rev_hull1: "x \<in>  \<langle>rev ` G\<rangle> \<Longrightarrow> x \<in> rev ` \<langle>G\<rangle>"
 proof-
   assume "x \<in>  \<langle>rev ` G\<rangle>"
   then obtain xs where "x = concat xs" and "xs \<in> lists (rev ` G)"
     unfolding hull_concat_lists by blast
   hence "rev x \<in> \<langle>G\<rangle>"
     unfolding hull_concat_lists using rev_concat by fastforce
   thus "x \<in> rev ` \<langle>G\<rangle>"
-    by (simp add: rev_in_conv)
+    by (simp add: rev_image_eqI)
 qed
 
 lemma rev_hull: "rev`\<langle>G\<rangle> = \<langle>rev`G\<rangle>"
   by (simp add: rev_hull0 rev_hull1 set_eq_subset subsetI)
 
-lemma power_in: "x \<in> \<langle>G\<rangle>  \<Longrightarrow> x\<^sup>@k \<in> \<langle>G\<rangle>"
-  by (induction k, auto, simp add: hull_closed)
+lemma power_in[intro]: "x \<in> \<langle>G\<rangle> \<Longrightarrow> x\<^sup>@k \<in> \<langle>G\<rangle>"
+  by (induction k, auto)
 
 lemma hull_closed_lists:  "us \<in> lists \<langle>G\<rangle> \<Longrightarrow> concat us \<in> \<langle>G\<rangle>"
-proof (induct us, auto)
-  show  "\<And>a us. concat us \<in> \<langle>G\<rangle> \<Longrightarrow> a \<in> \<langle>G\<rangle> \<Longrightarrow> \<forall>x\<in>set us. x \<in> \<langle>G\<rangle> \<Longrightarrow> a \<cdot> concat us \<in> \<langle>G\<rangle> "
-    by (simp add: hull_closed)
-qed
+  by (induct us, auto)
+
+lemma hull_I [intro]:
+  "\<epsilon> \<in> H \<Longrightarrow> (\<And> x y. x \<in> H \<Longrightarrow> y \<in> H \<Longrightarrow> x \<cdot> y \<in> H) \<Longrightarrow> \<langle>H\<rangle> = H"  
+  by (standard, use hull.induct[of _ H "\<lambda> x. x \<in> H"] in blast) (simp only: genset_sub)
 
 lemma self_gen: "\<langle>\<langle>G\<rangle>\<rangle> = \<langle>G\<rangle>"
   using image_subsetI[of "lists \<langle>G\<rangle>" concat "\<langle>G\<rangle>", unfolded hull_concat_lists[of "\<langle>G\<rangle>", symmetric],
-        THEN subset_antisym[OF _ genset_sub[of "\<langle>G\<rangle>"]]] hull_closed_lists[of _ G] by blast
+        THEN subset_antisym[OF _ genset_sub[of "\<langle>G\<rangle>"]]] hull_closed_lists[of _ G] by blast 
+
+lemma hull_mono'[intro]: "A \<subseteq> \<langle>B\<rangle> \<Longrightarrow> \<langle>A\<rangle> \<subseteq> \<langle>B\<rangle>" 
+  using hull_mono self_gen by blast
+
+lemma hull_conjug [elim]: "w \<in> \<langle>{r\<cdot>s,s\<cdot>r}\<rangle> \<Longrightarrow> w \<in> \<langle>{r,s}\<rangle>"
+  using hull_mono[of "{r\<cdot>s,s\<cdot>r}" "\<langle>{r,s}\<rangle>", unfolded self_gen] by blast
 
 text\<open>Intersection of hulls is a hull.\<close>
 
 lemma hulls_inter: "\<langle>\<Inter> {\<langle>G\<rangle> | G. G \<in> S}\<rangle> = \<Inter> {\<langle>G\<rangle> | G. G \<in> S}"
 proof
   {fix G assume "G \<in> S"
-    hence "\<langle>\<Inter> {\<langle>G\<rangle> |G. G \<in> S}\<rangle> \<subseteq> \<langle>G\<rangle>"
-      using Inter_lower[of "\<langle>G\<rangle>" "{\<langle>G\<rangle> |G. G \<in> S}"] mem_Collect_eq[of "\<langle>G\<rangle>" "\<lambda> A. \<exists> G. G \<in> S \<and> A = \<langle>G\<rangle>"]
-        hull_mon[of "\<Inter> {\<langle>G\<rangle> |G. G \<in> S}" "\<langle>G\<rangle>"] unfolding self_gen by auto}
-  thus "\<langle>\<Inter> {\<langle>G\<rangle> |G. G \<in> S}\<rangle> \<subseteq> \<Inter> {\<langle>G\<rangle> |G. G \<in> S}"  by blast
-next
+    hence "\<langle>\<Inter> {\<langle>G\<rangle> |G. G \<in> S}\<rangle> \<subseteq> \<langle>G\<rangle>" 
+      using Inter_lower[of "\<langle>G\<rangle>" "{\<langle>G\<rangle> |G. G \<in> S}"] mem_Collect_eq[of "\<langle>G\<rangle>" "\<lambda> A. \<exists> G. G \<in> S \<and> A = \<langle>G\<rangle>"] 
+        hull_mono[of "\<Inter> {\<langle>G\<rangle> |G. G \<in> S}" "\<langle>G\<rangle>"] unfolding self_gen by auto}
+  thus "\<langle>\<Inter> {\<langle>G\<rangle> |G. G \<in> S}\<rangle> \<subseteq> \<Inter> {\<langle>G\<rangle> |G. G \<in> S}"  by blast 
+next  
   show "\<Inter> {\<langle>G\<rangle> |G. G \<in> S} \<subseteq> \<langle>\<Inter> {\<langle>G\<rangle> |G. G \<in> S}\<rangle>"
-    by (simp add: genset_sub)
+    by simp
 qed
 
+lemma hull_keeps_root: "\<forall> u \<in> A. u \<in> r* \<Longrightarrow>  w \<in> \<langle>A\<rangle> \<Longrightarrow> w \<in> r*"
+  by (rule hull.induct[of _ _ "\<lambda> x. x \<in> r*"], auto)
+
+lemma bin_hull_keeps_root [intro]: "u \<in> r* \<Longrightarrow> v \<in> r* \<Longrightarrow> w \<in> \<langle>{u,v}\<rangle> \<Longrightarrow> w \<in> r*" 
+  by (rule hull.induct[of _ _ "\<lambda> x. x \<in> r*"], auto)
+
+lemma bin_comm_hull_comm: "x \<cdot> y = y \<cdot> x \<Longrightarrow> u \<in> \<langle>{x,y}\<rangle> \<Longrightarrow> v \<in> \<langle>{x,y}\<rangle> \<Longrightarrow>  u \<cdot> v = v \<cdot> u"
+  unfolding comm_root using bin_hull_keeps_root by blast 
+
+lemma[reversal_rule]: "rev ` \<langle>{rev u, rev v}\<rangle> = \<langle>{u,v}\<rangle>"
+  by (simp add: rev_hull) 
+
+lemma[reversal_rule]: "rev w \<in>  \<langle>rev ` G\<rangle> \<equiv> w \<in> \<langle>G\<rangle>"
+  unfolding rev_in_conv rev_hull rev_rev_image_eq.
+
 
 section "Factorization into generators"
 
-text\<open>We define a decomposition (or a factorization) of a into elements of a given generating set. Such a decomposition is well defined only
+text\<open>We define a decomposition (or a factorization) of a into elements of a given generating set. Such a decomposition is well defined only 
 if the decomposed word is an element of the hull. Even int that case, however, the decomposition need not be unique.\<close>
 
-fun decompose :: "'a list set  \<Rightarrow> 'a list \<Rightarrow> 'a list list" ("Dec _ _" [51,51] 64) where
+definition decompose :: "'a list set  \<Rightarrow> 'a list \<Rightarrow> 'a list list" ("Dec _ _" [55,55] 56) where
   "decompose G u = (SOME us. us \<in> lists G\<^sub>+ \<and> concat us = u)"
 
-lemma dec_ex:  assumes "u \<in> \<langle>G\<rangle>" shows "\<exists> us. (us \<in> lists G\<^sub>+ \<and> concat us = u)"
-  using assms unfolding image_def  hull_concat_lists[of G] mem_Collect_eq
-  using del_emp_concat lists_drop_emp' by metis
+lemma dec_ex:  assumes "u \<in> \<langle>G\<rangle>" shows "\<exists> us. (us \<in> lists G\<^sub>+ \<and> concat us = u)" 
+  using assms unfolding image_def  hull_concat_lists[of G] mem_Collect_eq 
+  using del_emp_concat lists_drop_emp' by metis 
 
 lemma decI': "u \<in> \<langle>G\<rangle> \<Longrightarrow> (Dec G u) \<in> lists G\<^sub>+"
-  unfolding decompose.simps using someI_ex[OF dec_ex] by blast
+  unfolding decompose_def using someI_ex[OF dec_ex] by blast
 
-lemma decI: "u \<in> \<langle>G\<rangle> \<Longrightarrow> concat (Dec G u) = u"
-  unfolding decompose.simps using someI_ex[OF dec_ex] by blast
+lemma concat_dec[simp, intro] : "u \<in> \<langle>G\<rangle> \<Longrightarrow> concat (Dec G u) = u"
+  unfolding decompose_def using someI_ex[OF dec_ex] by blast
 
-lemma dec_emp: "Dec G \<epsilon> = \<epsilon>"
+lemma dec_emp [simp]: "Dec G \<epsilon> = \<epsilon>"                             
 proof-
   have ex:  "\<epsilon> \<in> lists G\<^sub>+ \<and> concat \<epsilon> = \<epsilon>"
     by simp
   have all: "(us \<in> lists G\<^sub>+ \<and> concat us = \<epsilon>) \<Longrightarrow> us = \<epsilon>" for us
     using emp_concat_emp by auto
-  show  ?thesis
-    unfolding decompose.simps
+  show  ?thesis 
+    unfolding decompose_def
     using all[OF someI[of "\<lambda> x. x \<in> lists G\<^sub>+ \<and> concat x = \<epsilon>", OF ex]].
 qed
 
 lemma dec_nemp: "u \<in> \<langle>G\<rangle>\<^sub>+ \<Longrightarrow>  Dec G u \<noteq> \<epsilon>"
-  using decI[of u G] by force
+  using concat_dec[of u G] by force  
 
-lemma dec_nemp': "u \<noteq> \<epsilon> \<Longrightarrow> u \<in> \<langle>G\<rangle> \<Longrightarrow> Dec G u \<noteq> \<epsilon>"
+lemma dec_nemp'[simp, intro]: "u \<noteq> \<epsilon> \<Longrightarrow> u \<in> \<langle>G\<rangle> \<Longrightarrow> Dec G u \<noteq> \<epsilon>"
   using dec_nemp by blast
 
-lemma dec_dom': "u \<in> \<langle>G\<rangle> \<Longrightarrow> Dec G u \<in> lists G"
-  using decI' by auto
+lemma dec_eq_emp_iff [simp]: assumes "u \<in> \<langle>G\<rangle>" shows "Dec G u = \<epsilon> \<longleftrightarrow> u = \<epsilon>"
+  using dec_nemp'[OF _ \<open>u \<in> \<langle>G\<rangle>\<close>] by auto
 
-lemma dec_hd: assumes "u \<noteq> \<epsilon>" "u \<in> \<langle>G\<rangle>" shows "hd (Dec G u) \<in> G"
-  using dec_nemp'[OF assms] dec_dom'[OF \<open>u \<in> \<langle>G\<rangle>\<close>] lists_hd[of "Dec G u" G] by blast
+lemma dec_in_lists[simp]: "u \<in> \<langle>G\<rangle> \<Longrightarrow> Dec G u \<in> lists G"
+  using decI' by auto 
+
+lemma set_dec_sub: "x \<in> \<langle>G\<rangle> \<Longrightarrow> set (Dec G x) \<subseteq> G"
+  using dec_in_lists by blast
+
+lemma dec_hd: "u \<noteq> \<epsilon> \<Longrightarrow> u \<in> \<langle>G\<rangle> \<Longrightarrow> hd (Dec G u) \<in> G"
+  by simp  
 
 lemma non_gen_dec: "u \<in> \<langle>G\<rangle> \<Longrightarrow> u \<notin> G \<Longrightarrow> Dec G u  \<noteq> [u]"
   using decI'  Cons_in_lists_iff by fastforce
 
 subsection \<open>Refinement into a specific decomposition\<close>
 
 text\<open>We extend the decomposition to lists of words. This can be seen as a refinement of a previous decomposition of some word.\<close>
 
-fun refine :: "'a list set \<Rightarrow> 'a list list \<Rightarrow> 'a list list" ("Ref _ _" [51,51] 65) where
+definition refine :: "'a list set \<Rightarrow> 'a list list \<Rightarrow> 'a list list" ("Ref _ _" [51,51] 65) where
   "refine G us = concat(map (decompose G) us)"
 
 lemma ref_morph: "us \<in> lists \<langle>G\<rangle> \<Longrightarrow> vs \<in> lists \<langle>G\<rangle> \<Longrightarrow> refine G (us \<cdot> vs) = refine G us \<cdot> refine G vs"
-  using refine.simps by simp
+  unfolding refine_def by simp
+
+lemma ref_conjug:
+  "u \<sim> v \<Longrightarrow> (Ref G u) \<sim> Ref G v"
+  unfolding refine_def by (intro conjug_concat_conjug map_conjug)
 
 lemma ref_morph_plus: "us \<in> lists \<langle>G\<rangle>\<^sub>+ \<Longrightarrow> vs \<in> lists \<langle>G\<rangle>\<^sub>+ \<Longrightarrow> refine G (us \<cdot> vs) = refine G us \<cdot> refine G vs"
-  using refine.simps by simp
+  unfolding refine_def by simp     
+
+lemma ref_pref_mono: "ws \<in> lists \<langle>G\<rangle> \<Longrightarrow> us \<le>p ws \<Longrightarrow> Ref G us \<le>p Ref G ws"
+  unfolding prefix_def using ref_morph append_in_lists_dest' append_in_lists_dest by metis
+
+lemma ref_suf_mono: "ws \<in> lists \<langle>G\<rangle> \<Longrightarrow> us \<le>s ws \<Longrightarrow> (Ref G us) \<le>s Ref G ws"
+  unfolding suffix_def using ref_morph append_in_lists_dest' append_in_lists_dest by metis
+
+lemma ref_fac_mono: "ws \<in> lists \<langle>G\<rangle> \<Longrightarrow> us \<le>f ws \<Longrightarrow> (Ref G us) \<le>f Ref G ws"
+  unfolding sublist_altdef' using ref_pref_mono ref_suf_mono  suf_in_lists by metis
 
 lemma ref_pop_hd: "us \<noteq> \<epsilon> \<Longrightarrow> us \<in> lists \<langle>G\<rangle> \<Longrightarrow> refine G us = decompose G (hd us) \<cdot> refine G (tl us)"
-  unfolding  refine.simps  using list.simps(9)[of "decompose G" "hd us" "tl us"] by simp
+  unfolding  refine_def  using list.simps(9)[of "decompose G" "hd us" "tl us"] by simp  
 
 lemma ref_in: "us \<in> lists \<langle>G\<rangle> \<Longrightarrow> (Ref G us) \<in> lists G\<^sub>+"
- proof (induction us, simp)
+ proof (induction us, simp add: refine_def)
    case (Cons a us)
    then show ?case
-      using Cons.IH Cons.prems decI' by auto
-qed
+      using Cons.IH Cons.prems decI' by (auto simp add: refine_def)
+qed 
 
-lemma ref: "us \<in> lists \<langle>G\<rangle> \<Longrightarrow> concat (Ref G us) = concat us"
-proof (induction us, simp)
+lemma ref_in'[intro]: "us \<in> lists \<langle>G\<rangle> \<Longrightarrow> (Ref G us) \<in> lists G"
+  using ref_in by fast
+
+lemma concat_ref: "us \<in> lists \<langle>G\<rangle> \<Longrightarrow> concat (Ref G us) = concat us"
+proof (induction us, simp add: refine_def)
   case (Cons a us)
   then show ?case
-      using Cons.IH Cons.prems decI by auto
+      using Cons.IH Cons.prems concat_dec refine_def by (auto simp add: refine_def)
   qed
 
-lemma ref_gen: "us \<in> lists B \<Longrightarrow> B \<subseteq> \<langle>G\<rangle> \<Longrightarrow> Ref G us \<in> \<langle>decompose G ` B\<rangle>"
-  by (induct us, auto)
+lemma ref_gen: "us \<in> lists B \<Longrightarrow> B \<subseteq> \<langle>G\<rangle> \<Longrightarrow> Ref G us \<in> \<langle>decompose G ` B\<rangle>" 
+  by (induct us, auto simp add: refine_def)
+
+lemma ref_set: "ws \<in> lists \<langle>G\<rangle> \<Longrightarrow> set (Ref G ws) = \<Union> (set`(decompose G)`set ws)"
+  by (simp add: refine_def)
 
 lemma emp_ref: assumes "us \<in> lists \<langle>G\<rangle>\<^sub>+" and  "Ref G us = \<epsilon>" shows "us = \<epsilon>"
   using emp_concat_emp[OF \<open>us \<in> lists \<langle>G\<rangle>\<^sub>+\<close>]
-     ref[OF lists_drop_emp[OF assms(1)], unfolded \<open>Ref G us = \<epsilon>\<close> concat.simps(1),symmetric] by blast
+    concat_ref [OF lists_drop_emp[OF assms(1)], unfolded \<open>Ref G us = \<epsilon>\<close> concat.simps(1),symmetric] by blast 
 
-lemma sing_ref_sing:
-  assumes "us \<in> lists \<langle>G\<rangle>\<^sub>+" and "refine G us = [b]"
+lemma sing_ref_sing: 
+  assumes "us \<in> lists \<langle>G\<rangle>\<^sub>+" and "refine G us = [b]" 
   shows "us = [b]"
 proof-
   have "us \<noteq> \<epsilon>"
-    using \<open>refine G us = [b]\<close> by auto
+    using \<open>refine G us = [b]\<close> by (auto simp add: refine_def)
   have "tl us \<in> lists \<langle>G\<rangle>\<^sub>+" and "hd us \<in> \<langle>G\<rangle>\<^sub>+"
     using list.collapse[OF \<open>us \<noteq> \<epsilon>\<close>]  \<open>us \<in> lists \<langle>G\<rangle>\<^sub>+\<close> Cons_in_lists_iff[of "hd us" "tl us" "\<langle>G\<rangle>\<^sub>+"]
     by auto
-  have "Dec G (hd us) \<noteq> \<epsilon>"
+  have "Dec G (hd us) \<noteq> \<epsilon>" 
     using dec_nemp[OF \<open>hd us \<in> \<langle>G\<rangle>\<^sub>+\<close>].
   have "us \<in> lists \<langle>G\<rangle>"
     using \<open>us \<in> lists \<langle>G\<rangle>\<^sub>+\<close> lists_drop_emp by auto
   have "concat us = b"
-    using \<open>us \<in> lists \<langle>G\<rangle>\<close> assms(2) ref by force
+    using \<open>us \<in> lists \<langle>G\<rangle>\<close> assms(2) concat_ref by force       
   have "refine G (tl us) = \<epsilon>"
-    using ref_pop_hd[OF \<open>us \<noteq> \<epsilon>\<close> \<open>us \<in> lists \<langle>G\<rangle>\<close>]  unfolding  \<open>refine G us = [b]\<close>
+    using ref_pop_hd[OF \<open>us \<noteq> \<epsilon>\<close> \<open>us \<in> lists \<langle>G\<rangle>\<close>]  unfolding  \<open>refine G us = [b]\<close> 
     using \<open>Dec G (hd us) \<noteq> \<epsilon>\<close> Cons_eq_append_conv[of b \<epsilon> "(Dec G (hd us))" "(Ref G (tl us))"]
       Cons_eq_append_conv[of b \<epsilon> "(Dec G (hd us))" "(Ref G (tl us))"]  append_is_Nil_conv[of _ "(Ref G (tl us))"]
     by blast
   from  emp_ref[OF \<open>tl us \<in> lists \<langle>G\<rangle>\<^sub>+\<close> this, symmetric]
   have "\<epsilon> = tl us".
   from this[unfolded Nil_tl]
   show ?thesis
-    using \<open>us \<noteq> \<epsilon>\<close> \<open>concat us = b\<close> by auto
+    using \<open>us \<noteq> \<epsilon>\<close> \<open>concat us = b\<close> by auto  
 qed
 
-lemma ref_ex: assumes "Q \<subseteq> \<langle>G\<rangle>" and "us \<in> lists Q"
+lemma ref_ex: assumes "Q \<subseteq> \<langle>G\<rangle>" and "us \<in> lists Q" 
   shows "Ref G us \<in> lists G\<^sub>+" and "concat (Ref G us) = concat us"
-  using  ref_in[OF sub_lists_mono[OF assms]] ref[OF sub_lists_mono[OF assms]].
+  using ref_in[OF sub_lists_mono[OF assms]] concat_ref[OF sub_lists_mono[OF assms]].
 
 section "Basis"
 
 text\<open>An important property of monoids of words is that they have a unique minimal generating set. Which is the set consisting of indecomposable elements.\<close>
 
 text\<open>The simple element is defined as a word which has only trivial decomposition into generators: a singleton.\<close>
 
-function simple_element :: "'a list \<Rightarrow> 'a list set  \<Rightarrow> bool" (" _ \<in>B _ " [51,51] 50) where
+definition simple_element :: "'a list \<Rightarrow> 'a list set  \<Rightarrow> bool" (" _ \<in>B _ " [51,51] 50) where
   "simple_element b G = (b \<in> G \<and> (\<forall> us. us \<in> lists G\<^sub>+ \<and> concat us = b \<longrightarrow> \<^bold>|us\<^bold>| = 1))"
-  using prod.exhaust by auto
-termination
-  using "termination" by blast
 
 lemma simp_el_el: "b \<in>B G \<Longrightarrow> b \<in> G"
-    unfolding simple_element.simps by blast
+    unfolding simple_element_def by blast
 
 lemma simp_elD: "b \<in>B G \<Longrightarrow> us \<in> lists G\<^sub>+ \<Longrightarrow> concat us = b \<Longrightarrow> \<^bold>|us\<^bold>| = 1"
-    unfolding simple_element.simps by blast
+    unfolding simple_element_def by blast
 
 lemma simp_el_sing: assumes "b \<in>B G" "us \<in> lists G\<^sub>+" "concat us = b" shows "us = [b]"
-  using simp_elD[OF assms] \<open>concat us = b\<close> concat_len_one sing_word by fastforce
+  using simp_elD[OF assms] \<open>concat us = b\<close> concat_len_one sing_word by fastforce  
 
 lemma nonsimp: "us \<in> lists G\<^sub>+ \<Longrightarrow> concat us \<in>B G \<Longrightarrow>  us = [concat us]"
-  using simp_el_sing[of "concat us" G us]   unfolding simple_element.simps
+  using simp_el_sing[of "concat us" G us]   unfolding simple_element_def 
   by blast
 
-lemma emp_nonsimp: "\<not> \<epsilon> \<in>B G"
-  unfolding simple_element.simps using list.size(3) concat.simps(1) lists.Nil[of "G\<^sub>+"]
+lemma emp_nonsimp: "\<not> \<epsilon> \<in>B G" 
+  unfolding simple_element_def using list.size(3) concat.simps(1) lists.Nil[of "G\<^sub>+"]
   by fastforce
 
 lemma basis_no_fact: assumes "u \<in> \<langle>G\<rangle>" and "v \<in> \<langle>G\<rangle>" and "u \<cdot> v \<in>B G" shows "u = \<epsilon> \<or> v = \<epsilon>"
 proof-
   have eq1: "concat ((Dec G u) \<cdot> (Dec G v)) = u \<cdot> v"
-    using concat_morph[of "Dec G u" "Dec G v",symmetric]
-    unfolding decI[OF \<open>u \<in> \<langle>G\<rangle>\<close>] decI[OF \<open>v \<in> \<langle>G\<rangle>\<close>].
+    using concat_morph[of "Dec G u" "Dec G v"] 
+    unfolding concat_dec[OF \<open>u \<in> \<langle>G\<rangle>\<close>] concat_dec[OF \<open>v \<in> \<langle>G\<rangle>\<close>].
   have eq2: "(Dec G u) \<cdot> (Dec G v) = [u \<cdot> v]"
-    using  \<open>u \<cdot> v \<in>B G\<close> nonsimp[of "(Dec G u) \<cdot> (Dec G v)"]
+    using  \<open>u \<cdot> v \<in>B G\<close> nonsimp[of "(Dec G u) \<cdot> (Dec G v)"] 
     unfolding eq1 append_in_lists_conv[of "(Dec G u)" "(Dec G v)" "G\<^sub>+"]
     using decI'[OF \<open>u \<in> \<langle>G\<rangle>\<close>] decI'[OF \<open>v \<in> \<langle>G\<rangle>\<close>]
-    by (meson append_in_lists_conv)
+    by (meson append_in_lists_conv) 
   have "Dec G u = \<epsilon> \<or> Dec G v = \<epsilon>"
-    using butlast_append[of "Dec G u" "Dec G v"]  unfolding eq2 butlast.simps(2)[of "u\<cdot>v" \<epsilon>]
-    using   Nil_is_append_conv[of "Dec G u" "butlast (Dec G v)"] by auto
+    using butlast_append[of "Dec G u" "Dec G v"]  unfolding eq2 butlast.simps(2)[of "u\<cdot>v" \<epsilon>] 
+    using   Nil_is_append_conv[of "Dec G u" "butlast (Dec G v)"] by auto 
   thus ?thesis
-    using decI[OF \<open>u \<in> \<langle>G\<rangle>\<close>] decI[OF \<open>v \<in> \<langle>G\<rangle>\<close>]
+    using concat_dec[OF \<open>u \<in> \<langle>G\<rangle>\<close>] concat_dec[OF \<open>v \<in> \<langle>G\<rangle>\<close>]
       concat.simps(1)
-    by auto
+    by auto 
 qed
 
 lemma simp_elI:
   assumes "b \<in> G" and "b \<noteq> \<epsilon>"  and all: "\<forall> u v. u \<noteq> \<epsilon> \<and> u \<in> \<langle>G\<rangle> \<and> v \<noteq> \<epsilon> \<and> v \<in> \<langle>G\<rangle> \<longrightarrow> u \<cdot> v \<noteq> b"
   shows "b \<in>B G"
-  unfolding simple_element.simps
+  unfolding simple_element_def
 proof(simp add: \<open>b \<in> G\<close>, standard, standard, elim conjE)
   fix us assume "us \<in> lists G\<^sub>+" "concat us = b"
   hence "us \<noteq> \<epsilon>" using \<open>b \<noteq> \<epsilon>\<close> concat.simps(1) by blast
   hence "hd us \<in> \<langle>G\<rangle>" and "hd us \<noteq> \<epsilon>"
-    using \<open>us \<in> lists G\<^sub>+\<close> lists_hd  gen_in by auto
+    using \<open>us \<in> lists G\<^sub>+\<close> lists_hd_in_set  gen_in by auto 
   have "tl us = \<epsilon>"
   proof(rule ccontr)
     assume "tl us \<noteq> \<epsilon>"
-    from nemp_concat_hull[of "tl us", OF this tl_lists[OF \<open>us \<in> lists G\<^sub>+\<close>]]
+    from nemp_concat_hull[of "tl us", OF this tl_in_lists[OF \<open>us \<in> lists G\<^sub>+\<close>]]
     show False
-      using all \<open>hd us \<noteq> \<epsilon>\<close> \<open>hd us \<in> \<langle>G\<rangle>\<close>  concat.simps(2)[of "hd us" "tl us", symmetric]
+      using all \<open>hd us \<noteq> \<epsilon>\<close> \<open>hd us \<in> \<langle>G\<rangle>\<close>  concat.simps(2)[of "hd us" "tl us", symmetric] 
       unfolding list.collapse[OF \<open>us \<noteq> \<epsilon>\<close>] \<open>concat us = b\<close>
       by blast
   qed
   hence "\<^bold>|us\<^bold>| = 1"
     using \<open>concat us = b\<close> assms(2) long_list_tl nonsing_concat_len by blast
    thus "\<^bold>|us\<^bold>| = Suc 0"
      by (simp add: \<open>b \<in> G\<close>)
 qed
 
-lemma simp_el_indecomp:
-  assumes "b \<in>B G"
+lemma simp_el_indecomp: 
+  assumes "b \<in>B G" 
   shows "b \<in> G" and  "b \<noteq> \<epsilon>" and "\<forall> u v. u \<noteq> \<epsilon> \<and> u \<in> \<langle>G\<rangle> \<and> v \<noteq> \<epsilon> \<and> v \<in> \<langle>G\<rangle> \<longrightarrow> u \<cdot> v \<noteq> b"
-  using assms basis_no_fact emp_nonsimp simple_element.simps by blast+
+  using assms basis_no_fact emp_nonsimp simple_element_def by blast+
 
 text\<open>We are ready to define the \emph{basis} as the set of all simple elements.\<close>
 
-fun basis :: "'a list set  \<Rightarrow> 'a list set" ("\<BB> _" [51] ) where
-  basisdef:  "basis G = {x. x \<in>B G}"
+definition basis :: "'a list set  \<Rightarrow> 'a list set" ("\<BB> _" [51] ) where
+    "basis G = {x. x \<in>B G}"
 
-lemma basisI: "x \<in>B G \<Longrightarrow> x \<in> \<BB> G"
-  by simp
+lemma basis_inI: "x \<in>B G \<Longrightarrow> x \<in> \<BB> G"
+  unfolding basis_def by simp
 
 lemma basisD: "x \<in> \<BB> G \<Longrightarrow> x \<in>B G"
-  by simp
+   unfolding basis_def by simp
 
 lemma emp_not_basis: "x \<in> \<BB> G \<Longrightarrow> x \<noteq> \<epsilon>"
-  using basisD emp_nonsimp by blast
+  using basisD emp_nonsimp by blast 
 
 lemma basis_sub: "\<BB> G \<subseteq> G"
-  using  basisdef by simp
+  unfolding  basis_def simple_element_def by simp   
 
 lemma basis_drop_emp: "(\<BB> G)\<^sub>+ = \<BB> G"
   using emp_not_basis by blast
 
-lemma simp_el_hull':  assumes "b \<in>B \<langle>G\<rangle>"  shows "b \<in>B G"
+lemma simp_el_hull':  assumes "b \<in>B \<langle>G\<rangle>"  shows "b \<in>B G" 
 proof-
   have all: "\<forall>us. us \<in> lists G\<^sub>+ \<and> concat us = b \<longrightarrow> \<^bold>|us\<^bold>| = 1"
-    using assms lists_gen_to_hull unfolding simple_element.simps by metis
+    using assms lists_gen_to_hull unfolding simple_element_def by metis
   have "b \<in> \<langle>G\<rangle>"
-    using assms simp_elD by auto
+    using assms simp_elD unfolding simple_element_def by blast
   obtain bs where "bs \<in> lists G\<^sub>+" and "concat bs = b"
     using  dec_ex[OF \<open>b \<in> \<langle>G\<rangle>\<close>] by blast
   have "b \<in> G"
-    using lists_drop_emp[OF \<open>bs \<in> lists G\<^sub>+\<close>]
-          lists_gen_to_hull[OF \<open>bs \<in> lists G\<^sub>+\<close>, THEN nonsimp[of bs "\<langle>G\<rangle>"],
+    using lists_drop_emp[OF \<open>bs \<in> lists G\<^sub>+\<close>] 
+          lists_gen_to_hull[OF \<open>bs \<in> lists G\<^sub>+\<close>, THEN nonsimp[of bs "\<langle>G\<rangle>"], 
           unfolded \<open>concat bs = b\<close>, OF \<open>b \<in>B \<langle>G\<rangle>\<close>] by simp
   thus "b \<in>B G"
-    by (simp add: all)
+    by (simp add: all simple_element_def)
 qed
 
 lemma simp_el_hull:  assumes "b \<in>B G" shows "b \<in>B \<langle>G\<rangle>"
-  using simp_elI[of b "\<langle>G\<rangle>"] unfolding self_gen
+  using simp_elI[of b "\<langle>G\<rangle>"] unfolding self_gen 
   using assms gen_in simp_el_indecomp[OF \<open>b \<in>B G\<close>] by auto
 
 lemma concat_tl_basis: "x # xs \<in> lists \<BB> G \<Longrightarrow> concat xs \<in> \<langle>G\<rangle>"
-  unfolding hull_concat_lists by auto
+  unfolding hull_concat_lists basis_def simple_element_def by auto
 
-text\<open>The basis generates the hull\<close>
+text\<open>The basis generates the hull\<close> 
 
 lemma set_concat_len: assumes "us \<in> lists G\<^sub>+" "1 < \<^bold>|us\<^bold>|" "u \<in> set us" shows "\<^bold>|u\<^bold>| < \<^bold>|concat us\<^bold>|"
 proof-
   obtain x y where "us = x \<cdot> [u] \<cdot> y" and "x \<cdot> y \<noteq> \<epsilon>"
-    using split_list_long[OF \<open>1 < \<^bold>|us\<^bold>|\<close> \<open>u \<in> set us\<close>].
+    using split_list_long[OF \<open>1 < \<^bold>|us\<^bold>|\<close> \<open>u \<in> set us\<close>]. 
   hence "x \<cdot> y \<in> lists G\<^sub>+"
-    using \<open>us \<in> lists G\<^sub>+\<close> by auto
-  hence "\<^bold>|concat (x \<cdot> y)\<^bold>| \<noteq> 0"
-    using \<open>x \<cdot> y \<noteq> \<epsilon>\<close> in_lists_conv_set  by force
+    using \<open>us \<in> lists G\<^sub>+\<close> by auto 
+  hence "\<^bold>|concat (x \<cdot> y)\<^bold>| \<noteq> 0" 
+    using \<open>x \<cdot> y \<noteq> \<epsilon>\<close> in_lists_conv_set  by force 
   hence "\<^bold>|concat us\<^bold>| = \<^bold>|u\<^bold>| + \<^bold>|concat x\<^bold>| + \<^bold>|concat y\<^bold>|"
-    using length_append \<open>us = x \<cdot> [u] \<cdot> y\<close> by simp
+    using lenmorph \<open>us = x \<cdot> [u] \<cdot> y\<close> by simp
   thus ?thesis
     using \<open>\<^bold>|concat (x \<cdot> y)\<^bold>| \<noteq> 0\<close> by auto
-qed
+qed    
 
 lemma non_simp_dec: assumes "w \<notin> \<BB> G" "w \<noteq> \<epsilon>" "w \<in> G"
   obtains us where "us \<in> lists G\<^sub>+" "1 < \<^bold>|us\<^bold>|" "concat us = w"
-  using \<open>w \<noteq> \<epsilon>\<close> \<open>w \<in> G\<close> \<open>w \<notin> \<BB> G\<close> nonsing_concat_len  basisI[of w G, unfolded simple_element.simps]
+  using \<open>w \<noteq> \<epsilon>\<close> \<open>w \<in> G\<close> \<open>w \<notin> \<BB> G\<close> nonsing_concat_len  basis_inI[of w G, unfolded simple_element_def] 
   by blast
 
-lemma basis_gen: "w \<in> G \<longrightarrow> w \<in> \<langle>\<BB> G\<rangle>"
+lemma basis_gen: "w \<in> G \<Longrightarrow>  w \<in> \<langle>\<BB> G\<rangle>"
 proof (induct "length w" arbitrary: w rule: less_induct)
   case less
-  {assume "w \<notin> \<BB> G" "w \<noteq> \<epsilon>" "w \<in> G"
+  show ?case
+  proof (cases "w \<in> \<BB> G \<or> w = \<epsilon>", blast)
+    assume "\<not> (w \<in> \<BB> G \<or> w = \<epsilon>)"
+    with \<open>w \<in> G\<close> 
     obtain us where "us \<in> lists G\<^sub>+" "1 < \<^bold>|us\<^bold>|" "concat us = w"
-      using non_simp_dec[OF \<open>w \<notin> \<BB> G\<close> \<open>w \<noteq> \<epsilon>\<close> \<open>w \<in> G\<close>] by blast
+      using non_simp_dec by blast 
     have "u \<in> set us \<Longrightarrow> u \<in> \<langle>\<BB> G\<rangle>" for u
-      using  lists_drop_emp[OF \<open>us \<in> lists G\<^sub>+\<close>]
-       set_concat_len[OF \<open>us \<in> lists G\<^sub>+\<close> \<open>1 < \<^bold>|us\<^bold>|\<close>, THEN less[unfolded \<open>concat us = w\<close>[symmetric], of u]]
-       unfolding in_lists_conv_set[of us G] by blast
-     from subsetI[of "set us", OF this]
-     have ?case
-      using  concat_in_hull[of us "\<langle>\<BB> G\<rangle>", unfolded self_gen \<open>concat us = w\<close>] by blast
-    }
-  thus ?case
-    by auto
+      using  lists_drop_emp[OF \<open>us \<in> lists G\<^sub>+\<close>] less(1)[OF set_concat_len[OF \<open>us \<in> lists G\<^sub>+\<close> \<open>1 < \<^bold>|us\<^bold>|\<close>, unfolded \<open>concat us = w\<close>], of u]
+      by blast
+    thus "w \<in> \<langle>\<BB> G\<rangle> "
+      unfolding \<open>concat us = w\<close>[symmetric]
+      using hull_closed_lists[OF in_listsI] by blast  
+  qed
 qed
 
+lemmas basis_concat_listsE = hull_concat_listsE[OF basis_gen]
+
 theorem basis_gen_hull: "\<langle>\<BB> G\<rangle> = \<langle>G\<rangle>"
 proof
   show "\<langle>\<BB> G\<rangle> \<subseteq> \<langle>G\<rangle>"
-    unfolding hull_concat_lists by auto
-  show  "\<langle>G\<rangle> \<subseteq> \<langle>\<BB> G\<rangle>"
-  proof
+    unfolding hull_concat_lists basis_def simple_element_def by auto
+  show  "\<langle>G\<rangle> \<subseteq> \<langle>\<BB> G\<rangle>" 
+  proof 
     fix x  show  "x \<in> \<langle>G\<rangle> \<Longrightarrow> x \<in> \<langle>\<BB> G\<rangle>"
     proof (induct rule: hull.induct)
       show "\<And>w1 w2. w1 \<in> G \<Longrightarrow> w2 \<in> \<langle>\<BB> G\<rangle> \<Longrightarrow> w1 \<cdot> w2 \<in> \<langle>\<BB> G\<rangle>"
-        using hull_closed[of _ "\<BB> G"] basis_gen[of _ G]  by blast
+        using hull_closed[of _ "\<BB> G"] basis_gen[of _ G]  by blast 
     qed auto
   qed
 qed
 
 lemma basis_gen_hull': "\<langle>\<BB> \<langle>G\<rangle>\<rangle> = \<langle>G\<rangle>"
   using basis_gen_hull self_gen by blast
 
-theorem basis_of_hull: "\<BB> G = \<BB> \<langle>G\<rangle>"
+theorem basis_of_hull: "\<BB> \<langle>G\<rangle> = \<BB> G"
 proof
   show "\<BB> G  \<subseteq>  \<BB> \<langle>G\<rangle>"
-    using basisD basisI simp_el_hull by blast
+    using basisD basis_inI simp_el_hull by blast
   show "\<BB> \<langle>G\<rangle>  \<subseteq>  \<BB> G"
-    using basisD basisI simp_el_hull' by blast
+    using basisD basis_inI simp_el_hull' by blast
 qed
 
+lemma basis_hull_sub: "\<BB> \<langle>G\<rangle> \<subseteq> G"
+  using basis_of_hull basis_sub by fast
+
 text\<open>The basis is the smallest generating set.\<close>
-theorem "\<langle>S\<rangle> = \<langle>G\<rangle> \<Longrightarrow> \<BB> G \<subseteq> S"
-  by (metis basis_of_hull basis_sub)
+theorem basis_sub_gen:  "\<langle>S\<rangle> = \<langle>G\<rangle> \<Longrightarrow> \<BB> G \<subseteq> S"
+  using basis_of_hull basis_sub by metis 
+
+lemma basis_min_gen: "S \<subseteq> \<BB> G \<Longrightarrow> \<langle>S\<rangle> = G \<Longrightarrow> S = \<BB> G"
+  using basis_of_hull basis_sub by blast
+
+lemma basisI: "(\<And> B. \<langle>B\<rangle> = \<langle>C\<rangle> \<Longrightarrow> C \<subseteq> B) \<Longrightarrow> \<BB> \<langle>C\<rangle> = C"
+  using basis_gen_hull basis_min_gen basis_of_hull by metis  
+
+thm basis_inI
 
 text\<open>An arbitrary set between basis and the hull is generating...\<close>
 lemma gen_sets: assumes "\<BB> G \<subseteq> S" and "S \<subseteq> \<langle>G\<rangle>" shows "\<langle>S\<rangle> = \<langle>G\<rangle>"
   using  image_mono[OF lists_mono[of S "\<langle>G\<rangle>"], of concat, OF \<open>S \<subseteq> \<langle>G\<rangle>\<close>] image_mono[OF lists_mono[of "\<BB> G" S], of concat, OF \<open>\<BB> G \<subseteq> S\<close>]
-  unfolding sym[OF hull_concat_lists]  basis_gen_hull
-  using  subset_antisym[of "\<langle>S\<rangle>" "\<langle>G\<rangle>"] self_gen by auto
+  unfolding sym[OF hull_concat_lists]  basis_gen_hull     
+  using  subset_antisym[of "\<langle>S\<rangle>" "\<langle>G\<rangle>"] self_gen by auto  
 
 text\<open>... and has the same basis\<close>
 lemma basis_sets: "\<BB> G \<subseteq> S \<Longrightarrow> S \<subseteq> \<langle>G\<rangle> \<Longrightarrow> \<BB> G = \<BB> S"
   by (metis basis_of_hull  gen_sets)
 
 text\<open>Any nonempty composed element has a decomposition into basis elements with many useful properties\<close>
 
 lemma non_simp_fac: assumes "w \<noteq> \<epsilon>" and "w \<in> \<langle>G\<rangle>" and "w \<notin> \<BB> G"
-  obtains us where "1 < \<^bold>|us\<^bold>|" and "us \<noteq> \<epsilon>" and  "us \<in> lists \<BB> G" and
-    "hd us \<noteq> \<epsilon>" and "hd us \<in> \<langle>G\<rangle>" and
-    "concat(tl us) \<noteq> \<epsilon>" and "concat(tl us) \<in> \<langle>G\<rangle>" and
+  obtains us where "1 < \<^bold>|us\<^bold>|" and "us \<noteq> \<epsilon>" and  "us \<in> lists \<BB> G" and 
+    "hd us \<noteq> \<epsilon>" and "hd us \<in> \<langle>G\<rangle>" and 
+    "concat(tl us) \<noteq> \<epsilon>" and "concat(tl us) \<in> \<langle>G\<rangle>" and 
     "w = hd us \<cdot> concat(tl us)"
 proof-
   obtain us where "us \<in> lists \<BB> G" and "concat us = w"
-    using \<open>w \<in> \<langle>G\<rangle>\<close> dec_dom'[of w "\<BB> G"] decI[of w "\<BB> G"]
+    using \<open>w \<in> \<langle>G\<rangle>\<close> dec_in_lists[of w "\<BB> G"] concat_dec[of w "\<BB> G"]
     unfolding basis_gen_hull
     by blast
   hence "us \<noteq> \<epsilon>"
     using  \<open>w \<noteq> \<epsilon>\<close> concat.simps(1)
     by blast
-  from lists_hd[OF this \<open>us \<in> lists \<BB> G\<close>, THEN emp_not_basis]
-    lists_hd[OF this \<open>us \<in> lists \<BB> G\<close>, THEN gen_in[of "hd us" "\<BB> G", unfolded basis_gen_hull]]
+  from lists_hd_in_set[OF this \<open>us \<in> lists \<BB> G\<close>, THEN emp_not_basis]
+    lists_hd_in_set[OF this \<open>us \<in> lists \<BB> G\<close>, THEN gen_in[of "hd us" "\<BB> G", unfolded basis_gen_hull]]
   have "hd us \<noteq> \<epsilon>" and "hd us \<in> \<langle>G\<rangle>".
   have  "1 < \<^bold>|us\<^bold>|"
-    using \<open>w \<notin> \<BB> G\<close> lists_hd[OF \<open>us \<noteq> \<epsilon>\<close> \<open>us \<in> lists \<BB> G\<close>] \<open>w \<noteq> \<epsilon>\<close> \<open>w \<in> \<langle>G\<rangle>\<close>
+    using \<open>w \<notin> \<BB> G\<close> lists_hd_in_set[OF \<open>us \<noteq> \<epsilon>\<close> \<open>us \<in> lists \<BB> G\<close>] \<open>w \<noteq> \<epsilon>\<close> \<open>w \<in> \<langle>G\<rangle>\<close> 
       concat_len_one[of us, unfolded \<open>concat us = w\<close>]  nonsing_concat_len[of us, unfolded \<open>concat us = w\<close>] by blast
-  from nemp_concat_hull[OF long_list_tl[OF this], of "\<BB> G", unfolded basis_drop_emp basis_gen_hull, OF tl_lists[OF \<open>us \<in> lists \<BB> G\<close>]]
+  from nemp_concat_hull[OF long_list_tl[OF this], of "\<BB> G", unfolded basis_drop_emp basis_gen_hull, OF tl_in_lists[OF \<open>us \<in> lists \<BB> G\<close>]]
   have "concat (tl us) \<in> \<langle>G\<rangle>" and "concat(tl us) \<noteq> \<epsilon>".
   have "w = hd us \<cdot> concat(tl us)"
     using \<open>us \<noteq> \<epsilon>\<close> \<open>us \<in> lists \<BB> G\<close> \<open>concat us = w\<close> concat.simps(2)[of "hd us" "tl us"] list.collapse[of us]
     by argo
-  from that[OF \<open>1 < \<^bold>|us\<^bold>|\<close> \<open>us \<noteq> \<epsilon>\<close> \<open>us \<in> lists \<BB> G\<close> \<open>hd us \<noteq> \<epsilon>\<close> \<open>hd us \<in> \<langle>G\<rangle>\<close> \<open>concat (tl us) \<noteq> \<epsilon>\<close> \<open>concat (tl us) \<in> \<langle>G\<rangle>\<close> this]
+  from that[OF \<open>1 < \<^bold>|us\<^bold>|\<close> \<open>us \<noteq> \<epsilon>\<close> \<open>us \<in> lists \<BB> G\<close> \<open>hd us \<noteq> \<epsilon>\<close> \<open>hd us \<in> \<langle>G\<rangle>\<close> \<open>concat (tl us) \<noteq> \<epsilon>\<close> \<open>concat (tl us) \<in> \<langle>G\<rangle>\<close> this] 
   show thesis.
 qed
 
-lemma basis_dec: "p \<in> \<langle>G\<rangle> \<Longrightarrow> s \<in> \<langle>G\<rangle> \<Longrightarrow> p \<cdot> s \<in> \<BB> G \<Longrightarrow> p = \<epsilon> \<or> s = \<epsilon>"
-  using basis_no_fact[of p G s] by simp
+lemma basis_dec: "p \<in> \<langle>G\<rangle> \<Longrightarrow> s \<in> \<langle>G\<rangle> \<Longrightarrow> p \<cdot> s \<in> \<BB> G \<Longrightarrow> p = \<epsilon> \<or> s = \<epsilon>" 
+  using basis_no_fact[of p G s] unfolding basis_def by simp 
 
 lemma non_simp_fac': "w \<notin> \<BB> G \<Longrightarrow> w \<noteq> \<epsilon> \<Longrightarrow> w \<in> \<langle>G\<rangle> \<Longrightarrow> \<exists>us. us \<in> lists G\<^sub>+ \<and> w = concat us \<and> \<^bold>|us\<^bold>| \<noteq> 1"
-  by (metis basisI concat_len_one decI' dec_dom' decI dec_nemp lists_hd nemp_elem_setI simple_element.elims(3))
+  by (metis basis_inI concat_len_one decI' dec_in_lists concat_dec dec_nemp lists_hd_in_set nemp_elem_setI simple_element_def)
 
 lemma emp_gen_iff: "G\<^sub>+ = {} \<longleftrightarrow> \<langle>G\<rangle> = {\<epsilon>}"
 proof
   assume "G\<^sub>+ = {}" show "\<langle>G\<rangle> = {\<epsilon>}"
     using  hull_drop_one[of G, unfolded \<open>G\<^sub>+ = {}\<close> emp_gen_set].
 next
   assume "\<langle>G\<rangle> = {\<epsilon>}" thus"G\<^sub>+ = {}" by blast
 qed
 
 lemma emp_basis_iff:  "\<BB> G = {} \<longleftrightarrow> G\<^sub>+ = {}"
-  using emp_gen_iff[of "\<BB> G", unfolded basis_gen_hull basis_drop_emp, folded emp_gen_iff].
+  using emp_gen_iff[of "\<BB> G", unfolded basis_gen_hull basis_drop_emp, folded emp_gen_iff].  
 
 section "Code"
 
-text\<open>A basis freely generating its hull is called a \emph{code}. By definition,
+locale nemp_words = 
+  fixes G
+  assumes emp_not_in: "\<epsilon> \<notin> G"
+
+begin
+lemma drop_empD: "G\<^sub>+ = G" 
+  using emp_not_in by simp
+
+lemmas emp_concat_emp' = emp_concat_emp[of _ G, unfolded drop_empD]
+
+lemma concat_take_mono: assumes "ws \<in> lists G" and "concat (take i ws) \<le>p concat (take j ws)" 
+  shows "take i ws \<le>p take j ws"
+proof (rule disjE[OF ruler[OF take_is_prefix[of i ws] take_is_prefix[of j ws]]], simp)
+  assume "take j ws \<le>p take i ws"
+  from prefixE[OF this]
+  obtain us where "take i ws = take j ws \<cdot> us".
+  hence "us \<in> lists G" using \<open>ws \<in> lists G\<close>
+    using append_in_lists_conv take_in_lists by metis
+  have "concat (take j ws) = concat (take i ws)"
+    using pref_concat_pref[OF \<open>take j ws \<le>p take i ws\<close>] assms(2) by simp
+  from arg_cong[OF \<open>take i ws = take j ws \<cdot> us\<close>, of concat, unfolded concat_morph, unfolded this]
+  have "us = \<epsilon>"
+    using \<open>us \<in> lists G\<close> emp_concat_emp' by blast
+  thus  "take i ws \<le>p take j ws"   
+    using \<open>take i ws = take j ws \<cdot> us\<close> by force
+qed
+
+lemma in_gen_nemp: "x \<in> G \<Longrightarrow> x \<noteq> \<epsilon>" 
+  using emp_not_in by blast
+
+lemma code_concat_eq_emp_iff [simp]: "us \<in> lists G \<Longrightarrow> concat us = \<epsilon> \<longleftrightarrow> us = \<epsilon>"
+  unfolding in_lists_conv_set concat_eq_Nil_conv
+  by (simp add: in_gen_nemp)
+
+lemma root_dec_inj_on: "inj_on (\<lambda> x. [\<rho> x]\<^sup>@(e\<^sub>\<rho> x)) G"
+  unfolding inj_on_def using in_gen_nemp[THEN primroot_exp_eq] 
+  unfolding concat_sing_pow[of "\<rho> _", symmetric] by metis
+
+
+lemma concat_root_dec_eq_concat: 
+  assumes "ws \<in> lists G" 
+  shows "concat (concat (map (\<lambda> x. [\<rho> x]\<^sup>@(e\<^sub>\<rho> x)) ws)) = concat ws"
+  (is "concat(concat (map ?R ws)) = concat ws")
+  using assms
+  by (induction ws, simp_all add: primroot_exp_eq in_gen_nemp)
+
+end
+
+text\<open>A basis freely generating its hull is called a \emph{code}. By definition, 
 this means that generated elements have unique factorizations into the elements of the code.\<close>
 
 locale code =
   fixes \<C>
-  assumes \<C>_is_code: "xs \<in> lists \<C> \<Longrightarrow> ys \<in> lists \<C> \<Longrightarrow> concat xs = concat ys \<Longrightarrow> xs = ys"
+  assumes is_code: "xs \<in> lists \<C> \<Longrightarrow> ys \<in> lists \<C> \<Longrightarrow> concat xs = concat ys \<Longrightarrow> xs = ys"
 begin
 
-lemma emp_not_in_code: "\<epsilon> \<notin> \<C>"
+lemma code_not_comm: "x \<in> \<C> \<Longrightarrow> y \<in> \<C> \<Longrightarrow> x \<noteq> y \<Longrightarrow> x \<cdot> y \<noteq> y \<cdot> x"
+  using is_code[of "[x,y]" "[y,x]"]  by auto
+
+lemma emp_not_in_code: "\<epsilon> \<notin> \<C>" 
 proof
   assume "\<epsilon> \<in> \<C>"
   hence "[] \<in> lists \<C>" and "[\<epsilon>] \<in> lists \<C>" and "concat [] = concat [\<epsilon>]" and "[] \<noteq> [\<epsilon>]"
     by simp+
-  thus False
-    using \<C>_is_code by blast
+  thus False  
+    using is_code by blast
 qed
 
-lemma code_simple: "c \<in> \<C> \<Longrightarrow> c \<in>B \<C>"
-  unfolding   simple_element.simps
-proof
-  fix c assume "c \<in> \<C>"
+sublocale nemp_words \<C>
+  using emp_not_in_code by unfold_locales
+
+lemmas in_code_nemp = in_gen_nemp
+
+lemma code_simple: "c \<in> \<C> \<Longrightarrow> c \<in>B \<C>" 
+  unfolding   simple_element_def 
+proof 
+  fix c assume "c \<in> \<C>" 
   hence "[c] \<in> lists \<C>"
     by simp
   show "\<forall>us. us \<in> lists \<C>\<^sub>+ \<and> concat us = c \<longrightarrow> \<^bold>|us\<^bold>| = 1"
   proof
     fix us
     {assume "us \<in> lists \<C>\<^sub>+" "concat us = c"
       hence "us \<in> lists \<C>" by blast
-      hence  "us = [c]"
-        using \<open>concat us = c\<close> \<open>c \<in> \<C>\<close> \<C>_is_code[of "[c]", OF \<open>[c] \<in> lists \<C>\<close> \<open>us \<in> lists \<C>\<close>] emp_not_in_code by auto}
+      hence  "us = [c]" 
+        using \<open>concat us = c\<close> \<open>c \<in> \<C>\<close> is_code[of "[c]", OF \<open>[c] \<in> lists \<C>\<close> \<open>us \<in> lists \<C>\<close>] emp_not_in_code by auto}
     thus "us \<in> lists \<C>\<^sub>+ \<and> concat us = c \<longrightarrow> \<^bold>|us\<^bold>| = 1"
-      using sing_len[of c] by fastforce
+      using sing_len[of c] by fastforce 
   qed
 qed
 
 lemma code_is_basis: "\<BB> \<C> = \<C>"
-  using code_simple basisdef[of \<C>] basis_sub by blast
+  using code_simple basis_def[of \<C>] basis_sub by blast
 
-lemma code_unique_dec: "us \<in> lists \<C> \<Longrightarrow> Dec \<C> (concat us) = us"
-  using dec_dom'[of "concat us" \<C>, THEN \<C>_is_code, of us]
-    decI[of "concat us" \<C>] hull_concat_lists[of \<C>] image_eqI[of "concat us" concat us "lists \<C>"]
+lemma code_unique_dec': "us \<in> lists \<C> \<Longrightarrow> Dec \<C> (concat us) = us"
+  using dec_in_lists[of "concat us" \<C>, THEN is_code, of us] 
+    concat_dec[of "concat us" \<C>] hull_concat_lists[of \<C>] image_eqI[of "concat us" concat us "lists \<C>"]
   by argo
 
+lemma code_unique_dec [intro!]: "us \<in> lists \<C> \<Longrightarrow> concat us = u \<Longrightarrow>  Dec \<C> u = us"
+  using code_unique_dec' by blast
+
+lemma triv_refine[intro!] : "us \<in> lists \<C> \<Longrightarrow> concat us = u \<Longrightarrow>  Ref \<C> [u] = us"
+  using code_unique_dec' by (auto simp add: refine_def) 
+
 lemma code_unique_ref: "us \<in> lists \<langle>\<C>\<rangle> \<Longrightarrow> refine \<C> us = decompose \<C> (concat us)"
 proof-
   assume "us \<in> lists \<langle>\<C>\<rangle>"
   hence "concat (refine \<C> us) = concat us"
-    using ref by fastforce
+    using concat_ref  by fastforce
   hence eq: "concat (refine \<C> us) = concat (decompose \<C> (concat us))"
-    using  decI[OF hull_closed_lists[OF \<open>us \<in> lists \<langle>\<C>\<rangle>\<close>]] by auto
+    using  concat_dec[OF hull_closed_lists[OF \<open>us \<in> lists \<langle>\<C>\<rangle>\<close>]] by auto 
   have dec: "Dec \<C> (concat us) \<in> lists \<C>"
-    using \<open>us \<in> lists \<langle>\<C>\<rangle>\<close> dec_dom' hull_closed_lists by blast
-  have ref: "Ref \<C> us \<in> lists \<C>"
+    using \<open>us \<in> lists \<langle>\<C>\<rangle>\<close> dec_in_lists hull_closed_lists
+    by metis 
+  have "Ref \<C> us \<in> lists \<C>"
     using lists_drop_emp[OF ref_in[OF \<open>us \<in> lists \<langle>\<C>\<rangle>\<close>]].
-  show ?thesis
-    using \<C>_is_code[OF ref dec eq].
+  from  is_code[OF this dec eq]
+  show ?thesis.
 qed
 
-lemma code_dec_morph: assumes "x \<in> \<langle>\<C>\<rangle>" "y \<in> \<langle>\<C>\<rangle>"
+lemma refI [intro]: "us \<in> lists \<langle>\<C>\<rangle> \<Longrightarrow> vs \<in> lists \<C> \<Longrightarrow> concat vs = concat us \<Longrightarrow> Ref \<C> us = vs"
+  unfolding code_unique_ref code_unique_dec..
+
+lemma code_dec_morph: assumes "x \<in> \<langle>\<C>\<rangle>" "y \<in> \<langle>\<C>\<rangle>" 
   shows "(Dec \<C> x) \<cdot> (Dec \<C> y) = Dec \<C> (x\<cdot>y)"
 proof-
   have eq: "(Dec \<C> x) \<cdot> (Dec \<C> y) = Dec \<C> (concat ((Dec \<C> x) \<cdot> (Dec \<C> y)))"
-    using dec_dom'[OF \<open>x \<in> \<langle>\<C>\<rangle>\<close>] dec_dom'[OF \<open>y \<in> \<langle>\<C>\<rangle>\<close>]
+    using dec_in_lists[OF \<open>x \<in> \<langle>\<C>\<rangle>\<close>] dec_in_lists[OF \<open>y \<in> \<langle>\<C>\<rangle>\<close>]
       code.code_unique_dec[OF code_axioms, of "(Dec \<C> x) \<cdot> (Dec \<C> y)", unfolded append_in_lists_conv, symmetric]
-    by blast
+    by presburger     
   moreover have "concat ((Dec \<C> x) \<cdot> (Dec \<C> y)) = (x \<cdot> y)"
-    using concat_morph[of "Dec \<C> x" "Dec \<C> y", symmetric]
-    unfolding decI[OF \<open>x \<in> \<langle>\<C>\<rangle>\<close>] decI[OF \<open>y \<in> \<langle>\<C>\<rangle>\<close>].
+    using concat_morph[of "Dec \<C> x" "Dec \<C> y"]
+    unfolding concat_dec[OF \<open>x \<in> \<langle>\<C>\<rangle>\<close>] concat_dec[OF \<open>y \<in> \<langle>\<C>\<rangle>\<close>].
   ultimately show "(Dec \<C> x) \<cdot> (Dec \<C> y) = Dec \<C> (x\<cdot>y)"
     by argo
 qed
 
-lemma code_el_dec: "c \<in> \<C> \<Longrightarrow> decompose \<C> c = [c]"
-  using code_unique_dec[of "[c]"] by auto
+lemma dec_pow: "rs \<in> \<langle>\<C>\<rangle> \<Longrightarrow> Dec \<C> (rs\<^sup>@k) = (Dec \<C> rs)\<^sup>@k"
+proof(induction k arbitrary: rs, fastforce)
+  case (Suc k)
+  then show ?case
+    using code_dec_morph pow_Suc power_in by metis 
+qed
+    
+lemma code_el_dec: "c \<in> \<C> \<Longrightarrow> decompose \<C> c = [c]" 
+  by fastforce
 
 lemma code_ref_list: "us \<in> lists \<C> \<Longrightarrow> refine \<C> us = us"
 proof (induct us)
   case (Cons a us)
   then show ?case using code_el_dec
-    by simp
-qed simp
+    unfolding refine_def by simp
+qed (simp add: refine_def)
 
-lemma code_ref_gen: assumes "G \<subseteq> \<langle>\<C>\<rangle>" "u \<in> \<langle>G\<rangle>"
+lemma code_ref_gen: assumes "G \<subseteq> \<langle>\<C>\<rangle>" "u \<in> \<langle>G\<rangle>" 
   shows "Dec \<C> u \<in> \<langle>decompose \<C> ` G\<rangle>"
 proof-
   have "refine \<C> (Dec G u) = Dec \<C> u"
-    using  dec_dom'[OF \<open>u \<in> \<langle>G\<rangle>\<close>]  \<open>G \<subseteq> \<langle>\<C>\<rangle>\<close> code_unique_ref[of "Dec G u", unfolded decI[OF \<open>u \<in> \<langle>G\<rangle>\<close>]] by blast
-  from ref_gen[of "Dec G u" G, OF dec_dom'[OF \<open>u \<in> \<langle>G\<rangle>\<close>], of \<C>, unfolded this, OF \<open>G \<subseteq> \<langle>\<C>\<rangle>\<close>]
+    using  dec_in_lists[OF \<open>u \<in> \<langle>G\<rangle>\<close>]  \<open>G \<subseteq> \<langle>\<C>\<rangle>\<close> code_unique_ref[of "Dec G u", unfolded concat_dec[OF \<open>u \<in> \<langle>G\<rangle>\<close>]] by blast
+  from ref_gen[of "Dec G u" G, OF dec_in_lists[OF \<open>u \<in> \<langle>G\<rangle>\<close>], of \<C>, unfolded this, OF \<open>G \<subseteq> \<langle>\<C>\<rangle>\<close>]
   show ?thesis.
 qed
 
+lemma code_rev_code: "code (rev ` \<C>)"
+proof
+  fix xs ys assume "xs \<in> lists (rev ` \<C>)" "ys \<in> lists (rev ` \<C>)" "concat xs = concat ys"
+  hence "map rev (rev xs) \<in> lists \<C>" and "map rev (rev ys) \<in> lists \<C>"
+    using rev_in_lists[OF \<open>xs \<in> lists (rev ` \<C>)\<close>] rev_in_lists[OF \<open>ys \<in> lists (rev ` \<C>)\<close>] map_rev_lists_rev by blast+
+  moreover have "concat (map rev (rev xs)) = concat (map rev (rev ys))"
+    unfolding rev_concat[symmetric] using \<open>concat xs = concat ys\<close> by blast
+  ultimately have "map rev (rev xs) = map rev (rev ys)"
+    using is_code by blast
+  thus "xs = ys" by simp
+qed
+
+lemma dec_rev [simp]: 
+  "u \<in> \<langle>\<C>\<rangle> \<Longrightarrow> Dec rev ` \<C> (rev u) = rev (map rev (Dec \<C> u))" 
+  by (auto simp only: rev_map lists_image rev_in_lists rev_concat[symmetric] dec_in_lists
+      intro!: code_rev_code code.code_unique_dec imageI del: in_listsI) 
+
+
+lemma elem_comm_sing_set: assumes "ws \<in> lists \<C>" and "ws \<noteq> \<epsilon>" and "u \<in> \<C>" and "concat ws \<cdot> u = u \<cdot> concat ws" 
+  shows  "set ws = {u}" 
+  using assms
+proof (cases "ws = \<epsilon>", simp)
+  assume "ws \<noteq> \<epsilon>"
+  have "concat (ws \<cdot> [u]) = concat ([u] \<cdot> ws)"
+    using assms by simp
+  have "ws \<cdot> [u] = [u] \<cdot> ws" 
+    using  \<open>u \<in> \<C>\<close> \<open>ws \<in> lists \<C>\<close> is_code[OF _ _  \<open>concat (ws \<cdot> [u]) = concat ([u] \<cdot> ws)\<close>]
+    by simp
+  from this[unfolded comm]
+  obtain k where "ws = [u]\<^sup>@k" by force
+  from nemp_pow_SucE[OF \<open>ws \<noteq> \<epsilon>\<close> this, of \<open>set ws = {u}\<close>]
+  show "set ws = {u}"
+     using sing_pow_set_Suc by metis
+qed
+
+lemma  pure_code_pres_prim:  assumes pure: "\<forall>u \<in> \<langle>\<C>\<rangle>. \<rho> u \<in> \<langle>\<C>\<rangle>" and 
+  "w \<in> \<langle>\<C>\<rangle>" and "primitive (Dec \<C> w)"
+  shows "primitive w"
+proof-
+  obtain k where "(\<rho> w)\<^sup>@k = w"
+    using primroot_expE' by blast
+
+  have "\<rho> w \<in> \<langle>\<C>\<rangle>"
+    using assms(2) pure by auto
+
+  have "(Dec \<C> (\<rho> w))\<^sup>@k \<in> lists \<C>"
+    by (metis \<open>\<rho> w \<in> \<langle>\<C>\<rangle>\<close> concat_sing_pow dec_in_lists flatten_lists order_refl sing_pow_lists)
+
+  have "(Dec \<C> (\<rho> w))\<^sup>@k = Dec \<C> w"
+    using \<open>(Dec \<C> (\<rho> w)) \<^sup>@ k \<in> lists \<C>\<close>  code.code_unique_dec code_axioms concat_morph_power \<open>(\<rho> w) \<^sup>@ k = w\<close> concat_dec[OF \<open>\<rho> w \<in> \<langle>\<C>\<rangle>\<close>] by metis
+  hence "k = 1"
+    using \<open>primitive (Dec \<C> w)\<close> unfolding primitive_def by blast
+  thus "primitive w"
+    by (metis CoWBasic.power_one_right \<open>\<rho> w \<^sup>@ k = w\<close> assms(3) dec_emp prim_nemp primroot_prim)
+qed
+
+lemma inj_on_dec: "inj_on (decompose \<C>) \<langle>\<C>\<rangle>"
+  by (rule inj_onI) (use concat_dec in force)
+
 end \<comment> \<open>end context code\<close>
 
+lemma emp_is_code: "code {}"
+  using code.intro empty_iff insert_iff lists_empty by metis
+
+lemma code_induct_hd: assumes "\<epsilon> \<notin> C" and
+              "\<And> xs ys. xs \<in> lists C \<Longrightarrow> ys \<in> lists C \<Longrightarrow> concat xs = concat ys \<Longrightarrow> hd xs = hd ys"
+      shows "code C"
+proof
+  show "xs \<in> lists C \<Longrightarrow> ys \<in> lists C \<Longrightarrow> concat xs = concat ys \<Longrightarrow> xs = ys" for xs ys
+  proof (induct xs ys rule: list_induct2', simp, use \<open>\<epsilon> \<notin> C\<close> in force, use \<open>\<epsilon> \<notin> C\<close> in force)
+    case (4 x xs y ys)
+    from assms(2)[OF "4.prems"]
+    have "x = y" by force  
+    from "4.prems"[unfolded this]
+    have "xs \<in> lists C" and "ys \<in> lists C" and "concat xs = concat ys" 
+      by simp_all
+    from "4.hyps"[OF this] \<open>x = y\<close> 
+    show ?case
+      by simp
+  qed
+qed  
+
+lemma ref_set_primroot: assumes "ws \<in> lists G\<^sub>+" and "code (\<rho>`G)"
+  shows "set (Ref \<rho>`G ws) = \<rho>`(set ws)"
+proof-
+  have "G \<subseteq> \<langle>\<rho>`G\<rangle>"
+  proof
+    fix x
+    assume "x \<in> G"
+    show "x \<in> \<langle>\<rho> ` G\<rangle>"
+      by (metis \<open>x \<in> G\<close> genset_sub image_subset_iff power_in primroot_expE')
+  qed
+  hence "ws \<in> lists \<langle>\<rho>`G\<rangle>"
+    using assms by blast
+
+  have "set (decompose (\<rho>`G) a) = {\<rho> a}" if "a \<in> set ws" for a
+  proof-
+    have "\<rho> a \<in> \<rho>`G"
+      using \<open>a \<in> set ws\<close> \<open>ws \<in> lists G\<^sub>+\<close> by blast 
+    have "(Dec (\<rho>`G) a) \<in> [\<rho> a]*"
+      using code.code_unique_dec[OF \<open>code (\<rho> ` G)\<close> sing_pow_lists concat_sing_pow, OF \<open>\<rho> a \<in> \<rho> ` G\<close>]
+            primroot_expE' rootI by metis
+    from sing_pow_set'[OF this dec_nemp']
+    show "set (decompose (\<rho>`G) a) = {\<rho> a}"
+      using \<open>a \<in> set ws\<close> \<open>ws \<in> lists \<langle>\<rho> ` G\<rangle>\<close> \<open>ws \<in> lists G\<^sub>+\<close> by blast
+  qed
+
+  have "(set`(decompose (\<rho>`G))`set ws) = {{\<rho> a} |a. a \<in> set ws}" (is "?L = ?R")
+  proof
+    show "?L \<subseteq> ?R"
+      using \<open>\<And>a. a \<in> set ws \<Longrightarrow> set (Dec \<rho> ` G a) = {\<rho> a}\<close> by blast
+    show "?R \<subseteq> ?L"
+      using \<open>\<And>a. a \<in> set ws \<Longrightarrow> set (Dec \<rho> ` G a) = {\<rho> a}\<close> by blast
+  qed
+
+  show ?thesis
+    using ref_set[OF \<open>ws \<in> lists \<langle>\<rho>`G\<rangle>\<close>]
+      Setcompr_eq_image \<open>set ` decompose (\<rho> ` G) ` set ws = {{\<rho> a} |a. a \<in> set ws}\<close> by (auto simp add: refine_def)
+qed
+
+
+section \<open>Prefix code\<close>
+
+locale pref_code = 
+  fixes \<C>
+  assumes 
+    nemp: "u \<in> \<C> \<Longrightarrow> u \<noteq> \<epsilon>" and
+    pref_free: "u \<in> \<C> \<Longrightarrow> v \<in> \<C> \<Longrightarrow> u \<le>p v \<Longrightarrow> u = v"
+
+begin
+
+sublocale code
+proof 
+  fix xs ys
+  show "xs \<in> lists \<C> \<Longrightarrow> ys \<in> lists \<C> \<Longrightarrow> concat xs = concat ys \<Longrightarrow> xs = ys"
+  proof (induction xs ys rule: list_induct2')
+    case (4 x xs y ys)
+    hence "x \<in> \<C>" and "y \<in> \<C>" and "xs \<in> lists \<C>" and "ys \<in> lists \<C>"
+    by simp_all
+    have "x \<bowtie> y"    
+      using \<open>concat (x # xs) = concat (y # ys)\<close>
+      by (simp add: ruler_eq) 
+    hence "x = y"
+      using pref_free \<open>x \<in> \<C>\<close> \<open>y \<in> \<C>\<close> by auto
+    show ?case 
+      using "4.IH"[OF \<open>xs \<in> lists \<C>\<close> \<open>ys \<in> lists \<C>\<close>] \<open>concat (x # xs) = concat (y # ys)\<close>
+      unfolding \<open>x = y\<close> by force    
+  qed (simp_all add: nemp)
+qed
+
+lemmas is_code = is_code and
+       code = code_axioms
+
+lemma dec_pref_unique:
+  assumes "w \<in> \<langle>\<C>\<rangle>" and "p \<in> \<langle>\<C>\<rangle>" and  "p \<le>p w"
+  shows "Dec \<C> p \<le>p Dec \<C> w"
+  using assms
+proof (induction "Dec \<C> p" "Dec \<C> w" arbitrary: p w rule: list_induct2', simp)
+  case (2 x xs)
+  then show ?case
+    by (metis dec_nemp' prefix_Nil) 
+next
+  case (4 x xs y ys)
+  then show ?case     
+  proof-
+    have "x \<in> \<C>"  
+      using \<open>x # xs = Dec \<C> p\<close> \<open>p \<in> \<langle>\<C>\<rangle>\<close> Cons_in_lists_iff dec_in_lists by metis   
+    moreover have "y \<in> \<C>"
+      using \<open>y # ys = Dec \<C> w\<close> \<open>w \<in> \<langle>\<C>\<rangle>\<close> Cons_in_lists_iff dec_in_lists by metis
+    moreover have "x \<bowtie> y"    
+      using \<open>p \<le>p w\<close> concat_dec[OF \<open>p \<in> \<langle>\<C>\<rangle>\<close>, folded \<open>x # xs = Dec \<C> p\<close>] concat_dec[OF \<open>w \<in> \<langle>\<C>\<rangle>\<close>, folded \<open>y # ys = Dec \<C> w\<close>]
+        concat.simps(2) pref_compI1 pref_compI2 ruler_prefE by metis
+    ultimately have "x = y"
+      using pref_free by blast
+   have xs: "xs = Dec \<C> (concat xs)"
+        by (metis "4.hyps"(2) "4.prems"(2) Cons_in_lists_iff code_unique_dec' dec_in_lists)
+   have ys: "ys = Dec \<C> (concat ys)"
+        by (metis "4.hyps"(3) "4.prems"(1) Cons_in_lists_iff code_unique_dec' dec_in_lists)
+   have "Dec \<C> (concat xs) \<le>p Dec \<C> (concat ys)"
+    proof (rule "4.hyps"(1)[OF xs ys])     
+      show "concat ys \<in> \<langle>\<C>\<rangle>"
+        by (metis "4.hyps"(3) "4.prems"(1) concat_in_hull' dec_in_lists listsE)
+      show "concat xs \<in> \<langle>\<C>\<rangle>"
+        by (metis "4.hyps"(2) "4.prems"(2) concat_in_hull' dec_in_lists listsE)
+      note concat_dec[OF \<open>w \<in> \<langle>\<C>\<rangle>\<close>, folded \<open>y # ys = Dec \<C> w\<close>, unfolded hd_word[of y ys]]
+           concat_dec[OF \<open>p \<in> \<langle>\<C>\<rangle>\<close>, folded \<open>x # xs = Dec \<C> p\<close>, unfolded hd_word[of x xs], unfolded \<open>x = y\<close>]
+      show "concat xs \<le>p concat ys"
+       using \<open>p \<le>p w\<close>[folded \<open>concat ([y] \<cdot> ys) = w\<close> \<open>concat ([y] \<cdot> xs) = p\<close>, unfolded concat_morph pref_cancel_conv]. 
+    qed
+    from this xs ys
+    show "Dec \<C> p \<le>p Dec \<C> w"
+      unfolding \<open>x # xs = Dec \<C> p\<close>[symmetric] \<open>y # ys = Dec \<C> w\<close>[symmetric] \<open>x = y\<close> by force  
+  qed
+qed force
+
+end
+
+section \<open>Marked code\<close>
+
+locale marked_code = 
+  fixes \<C>
+  assumes
+     nemp: "u \<in> \<C> \<Longrightarrow> u \<noteq> \<epsilon>" and
+     marked: "u \<in> \<C> \<Longrightarrow> v \<in> \<C> \<Longrightarrow> hd u = hd v \<Longrightarrow> u = v"
+
+begin 
+
+sublocale pref_code
+proof (unfold_locales, simp add: nemp)
+  show "\<And>u v. u \<in> \<C> \<Longrightarrow> v \<in> \<C> \<Longrightarrow> u \<le>p v \<Longrightarrow> u = v"
+    by (simp add: marked nemp pref_hd_eq)
+qed
+
+lemma marked_concat_lcp: "us \<in> lists \<C> \<Longrightarrow> vs \<in> lists \<C> \<Longrightarrow> concat (us \<and>\<^sub>p vs) = (concat us) \<and>\<^sub>p (concat vs)"
+proof (induct us vs rule: list_induct2')
+  case (4 x xs y ys)
+  hence "x \<in> \<C>" and "y \<in> \<C>" and "xs \<in> lists \<C>" and "ys \<in> lists \<C>"
+    by simp_all
+  show ?case
+  proof (cases) 
+    assume "x = y" 
+    thus "concat (x # xs \<and>\<^sub>p y # ys) = concat (x # xs) \<and>\<^sub>p concat (y # ys)"
+      using "4.hyps"[OF \<open>xs \<in> lists \<C>\<close> \<open>ys \<in> lists \<C>\<close>] by (simp add: lcp_ext_left)   
+  next
+    assume "x \<noteq> y"
+    with marked[OF \<open>x \<in> \<C>\<close> \<open>y \<in> \<C>\<close>] have "hd x \<noteq> hd y" by blast
+    hence "concat (x # xs) \<and>\<^sub>p concat (y # ys) = \<epsilon>"
+      by (simp add: \<open>x \<in> \<C>\<close> \<open>y \<in> \<C>\<close> nemp lcp_distinct_hd) 
+    moreover have "concat (x # xs \<and>\<^sub>p y # ys) = \<epsilon>"
+      using \<open>x \<noteq> y\<close> by simp
+    ultimately show ?thesis by presburger
+  qed
+qed simp_all
+
+lemma hd_concat_hd: assumes "xs \<in> lists \<C>" and "ys \<in> lists \<C>" and "xs \<noteq> \<epsilon>" and "ys \<noteq> \<epsilon>" and 
+              "hd (concat xs) = hd (concat ys)"
+      shows "hd xs = hd ys"
+proof-
+  have "hd (hd xs) = hd (hd ys)"
+    using assms  hd_concat[OF \<open>xs \<noteq> \<epsilon>\<close> lists_hd_in_set[THEN nemp]] hd_concat[OF \<open>ys \<noteq> \<epsilon>\<close> lists_hd_in_set[THEN nemp]]
+    by presburger
+    
+  from marked[OF lists_hd_in_set lists_hd_in_set this] assms(1-4) 
+  show "hd xs = hd ys" 
+    by simp
+qed
+
+end
+
+subsection "Sings code"
+
+locale sings_code =
+  fixes \<C>
+  assumes
+    card_set: "c \<in> \<C> \<Longrightarrow> card (set c) = 1" and
+    set_neq: "c \<in> \<C> \<Longrightarrow> d \<in> \<C> \<Longrightarrow> c \<noteq> d \<Longrightarrow> set c \<noteq> set d"
+begin
+
+lemma nemp: assumes "u \<in> \<C> " shows "u \<noteq> \<epsilon>"
+  using card_set[OF \<open>u \<in> \<C>\<close>] by (intro notI) simp
+
+lemma set_is_sing_hd: assumes "u \<in> \<C>" shows "set u = {hd u}"
+  using hd_in_set[OF nemp[OF \<open>u \<in> \<C>\<close>]] card_set[OF \<open>u \<in> \<C>\<close>]
+  by (elim card_1_singletonE) simp
+
+sublocale marked_code
+proof
+  show "\<And>u. u \<in> \<C> \<Longrightarrow> u \<noteq> \<epsilon>"
+    using card_set by fastforce 
+  show "\<And>u v. u \<in> \<C> \<Longrightarrow> v \<in> \<C> \<Longrightarrow> hd u = hd v \<Longrightarrow> u = v"
+    using set_is_sing_hd set_neq by auto
+qed
+
+lemma sing_pow:
+  assumes "u \<in> \<C>"
+  shows "[hd u]\<^sup>@\<^bold>|u\<^bold>| = u"
+  using unique_letter_word[of u "hd u", symmetric] unfolding set_is_sing_hd[OF \<open>u \<in> \<C>\<close>] by blast
+
+lemma palindrome: assumes "u \<in> \<C>" shows "rev u = u"
+  using sing_pow_palindrom[OF sing_pow[OF \<open>u \<in> \<C>\<close>, symmetric]].
+
+lemma rev_in_conv [reversal_rule]: "rev u \<in> \<C> \<longleftrightarrow> u \<in> \<C>"
+  using palindrome by fastforce
+
+lemma map_rev_in_lists_conv [reversal_rule]: "map rev us \<in> lists \<C> \<longleftrightarrow> us \<in> lists \<C>"
+  using palindrome by fastforce
+
+thm marked
+lemmas marked_last = marked[reversed]
+
+lemma common_letter_imp_same:
+  assumes "u \<in> \<C>" "v \<in> \<C>"
+      and "i < \<^bold>|u\<^bold>|" "j < \<^bold>|v\<^bold>|"
+  shows "u ! i = v ! j \<Longrightarrow> u = v"
+  using nth_mem[OF \<open>i < \<^bold>|u\<^bold>|\<close>] nth_mem[OF \<open>j < \<^bold>|v\<^bold>|\<close>]
+  unfolding set_is_sing_hd[OF \<open>u \<in> \<C>\<close>] set_is_sing_hd[OF \<open>v \<in> \<C>\<close>]
+  by (intro marked[OF \<open>u \<in> \<C>\<close> \<open>v \<in> \<C>\<close>]) simp
+
+lemma pref_overlap_imp_same:
+  assumes "u \<in> \<C>" "v \<in> \<C>"
+      and "p \<cdot> u \<le>p q \<cdot> v"
+      and "\<^bold>|q\<^bold>| < \<^bold>|p\<^bold>| + \<^bold>|u\<^bold>|"
+  shows "u = v"
+using assms(1-2) proof (rule common_letter_imp_same)
+  have *: "\<^bold>|p\<^bold>| \<le> \<^bold>|p\<^bold>| + \<^bold>|u\<^bold>| - 1"
+    unfolding diff_add_assoc[OF nemp_le_len[OF nemp[OF \<open>u \<in> \<C>\<close>]]] using le_add1.
+  have **: "\<^bold>|q\<^bold>| \<le> \<^bold>|p\<^bold>| + \<^bold>|u\<^bold>| - 1"
+    using \<open>\<^bold>|q\<^bold>| < \<^bold>|p\<^bold>| + \<^bold>|u\<^bold>|\<close> unfolding discrete by (intro add_le_imp_le_diff)
+  have "\<^bold>|p\<^bold>| + \<^bold>|u\<^bold>| - 1 < \<^bold>|p \<cdot> u\<^bold>|"
+    unfolding One_nat_def lenmorph using nemp[OF \<open>u \<in> \<C>\<close>] by (intro diff_Suc_less) blast
+  from pref_index[OF \<open>p \<cdot> u \<le>p q \<cdot> v\<close> this] less_le_trans[OF this pref_len[OF \<open>p \<cdot> u \<le>p q \<cdot> v\<close>]]
+  show "u ! (\<^bold>|u\<^bold>| - 1) = v ! (\<^bold>|p\<^bold>| + \<^bold>|u\<^bold>| - 1 - \<^bold>|q\<^bold>|)" and "\<^bold>|p\<^bold>| + \<^bold>|u\<^bold>| - 1 - \<^bold>|q\<^bold>| < \<^bold>|v\<^bold>|"
+    unfolding nth_append if_not_P[OF leD[OF **]] if_not_P[OF leD[OF *]]
+    unfolding diff_add_inverse[of ] diff_commute[of _ _ "_ p"]
+    unfolding lenmorph add.commute[of "_ q"] Nat.less_diff_conv2[OF **].
+qed (simp add: nemp[OF \<open>u \<in> \<C>\<close>])
+
+lemma overlap_imp_same:
+  assumes "u \<in> \<C>" "v \<in> \<C>"
+      and "p \<cdot> u \<bowtie> q \<cdot> v"
+      and "\<^bold>|p\<^bold>| < \<^bold>|q\<^bold>| + \<^bold>|v\<^bold>|" "\<^bold>|q\<^bold>| < \<^bold>|p\<^bold>| + \<^bold>|u\<^bold>|"
+  shows "u = v"
+  using assms
+  by (blast intro: pref_overlap_imp_same pref_overlap_imp_same[symmetric])
+  
+lemma concat_pref_concat_conv:
+  assumes "us \<in> lists \<C>" "vs \<in> lists \<C>"
+  shows "concat us \<le>p concat vs \<longleftrightarrow> us \<le>p vs"
+  using assms(1) assms(2) code_unique_dec' concat_in_hull' dec_pref_unique pref_concat_pref by metis 
+
+lemmas concat_suf_concat_conv = concat_pref_concat_conv[reversed]
+     
+lemma two_interpretations:
+  assumes "us \<in> lists \<C>" "vs \<in> lists \<C>"
+      and "z <p hd vs" "z \<noteq> \<epsilon>"
+      and "z \<cdot> concat us \<le>p concat vs"
+  shows "set us \<subseteq> {hd vs}"
+using assms(1-3, 5) proof (induction us vs rule: list_induct2')
+  case (4 u us v vs)
+    note pref = \<open>z \<cdot> concat (u # us) \<le>p concat (v # vs)\<close>
+    \<comment> \<open>stating simple consequences of the hypotheses\<close>
+    have "u \<in> \<C>" "v \<in> \<C>" "us \<in> lists \<C>" "vs \<in> lists \<C>"
+      using \<open>u # us \<in> lists \<C>\<close> \<open>v # vs \<in> lists \<C>\<close> by simp_all
+     \<comment> \<open>first step is to show the equality of u and v\<close>
+    have "z \<cdot> u \<bowtie> \<epsilon> \<cdot> v"
+      using pref by (intro ruler'[OF append_prefixD triv_pref]) simp
+    moreover have "\<^bold>|z\<^bold>| < \<^bold>|\<epsilon>\<^bold>| + \<^bold>|v\<^bold>|" and "\<^bold>|\<epsilon>\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|u\<^bold>|"
+      using \<open>z <p hd (v # vs)\<close> \<open>z \<noteq> \<epsilon>\<close> by (simp_all add: prefix_length_less)
+    ultimately have "u = v"
+      by (rule overlap_imp_same[OF \<open>u \<in> \<C>\<close> \<open>v \<in> \<C>\<close>])
+    \<comment> \<open>empty vs leads to contradiction, so we can express vs as @{term "v' # vs'"}\<close> 
+    have False if "vs = \<epsilon>"
+      using \<open>z \<noteq> \<epsilon>\<close> pref unfolding \<open>vs = \<epsilon>\<close> \<open>u = v\<close>
+        by simp (rule notE[OF _ same_sufix_nil[OF pref_ext]])
+    from hd_Cons_tl[OF notI[OF this]]
+    obtain v' vs' where "vs = v' # vs'" unfolding eq_commute[of "_#_"]..
+    have "v' \<in> \<C>" "vs' \<in> lists \<C>"
+      using \<open>vs \<in> lists \<C>\<close> unfolding \<open>vs = v' # vs'\<close> by simp_all
+    \<comment> \<open>now we show the equality of v' and v similarly as above\<close> 
+    have "z \<cdot> v \<bowtie> v \<cdot> v'"
+      using pref unfolding \<open>u = v\<close> \<open>vs = v' # vs'\<close>
+      by (intro ruler'[OF append_prefixD triv_pref]) simp
+    moreover have "\<^bold>|z\<^bold>| < \<^bold>|v\<^bold>| + \<^bold>|v'\<^bold>|" and "\<^bold>|v\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|v\<^bold>|"
+      using \<open>z <p hd (v # vs)\<close> \<open>z \<noteq> \<epsilon>\<close> by (simp_all add: prefix_length_less trans_less_add1)
+    ultimately have "v' = v"
+      by (elim overlap_imp_same[OF \<open>v \<in> \<C>\<close> \<open>v' \<in> \<C>\<close>, symmetric])
+    \<comment> \<open> since @{term "z \<cdot> v"} is prefix of @{term "v \<cdot> v"}, the words z and v commute\<close>
+    have "z \<cdot> v \<le>p v \<cdot> v"
+      using comp_shorter[OF \<open>z \<cdot> v \<bowtie> v \<cdot> v'\<close>] \<open>\<^bold>|z\<^bold>| < \<^bold>|\<epsilon>\<^bold>| + \<^bold>|v\<^bold>|\<close>  unfolding \<open>v' = v\<close> lenmorph 
+      by fastforce
+    with this[folded same_prefix_prefix[of v "z \<cdot> v" "v \<cdot> v"]]
+    have "z \<cdot> v = v \<cdot> z"
+      using pref_prod_pref pref_prolong pref_comm_eq' triv_pref by metis 
+    \<comment> \<open>finally we check premises of the induction hypothesis and conclude the proof\<close>
+    note \<open>us \<in> lists \<C>\<close> \<open>vs \<in> lists \<C>\<close>
+    moreover have "z <p hd vs"
+      using \<open>z <p hd (v # vs)\<close> unfolding \<open>vs = v' # vs'\<close> \<open>v' = v\<close> list.sel(1).
+    moreover have "z \<cdot> concat us \<le>p concat vs"
+      using pref \<open>z \<cdot> v = v \<cdot> z\<close> unfolding \<open>u = v\<close>
+      by (intro pref_cancel[of _ "z \<cdot> _"]) (simp flip: rassoc)
+    ultimately have "set us \<subseteq> {hd vs}" by (fact "4.IH")
+    then show "set (u # us) \<subseteq> {hd (v # vs)}"
+      unfolding \<open>vs = v' # vs'\<close> \<open>v' = v\<close> \<open>u = v\<close> by simp
+qed (simp_all add: \<open>z \<noteq> \<epsilon>\<close>)
+
+lemma unique_interpretation:
+  assumes "us \<in> lists \<C>" "vs \<in> lists \<C>"
+      and "1 < card (set us)"
+      and "z \<cdot> concat us \<le>p concat vs"
+  obtains ws where "ws \<le>p vs" and "concat ws = z" and "ws \<cdot> us \<le>p vs"
+using assms proof (induction "\<^bold>|z\<^bold>|" arbitrary: z us vs thesis rule: less_induct)
+  case less
+    \<comment> \<open> stating simple facts \<close>
+    have "us \<noteq> \<epsilon>" using \<open>1 < card (set us)\<close> by fastforce
+    then have "hd us \<noteq> \<epsilon>" using \<open>us \<in> lists \<C>\<close> by (intro nemp lists_hd_in_set)
+    then have "vs \<noteq> \<epsilon>" using \<open>z \<cdot> concat us \<le>p concat vs\<close>
+     unfolding hd_concat_tl[OF \<open>us \<noteq> \<epsilon>\<close>, symmetric] by (intro notI) simp
+    then have "hd vs \<noteq> \<epsilon>" using \<open>vs \<in> lists \<C>\<close> by (intro nemp lists_hd_in_set)
+    have "z \<bowtie> hd vs"
+      using \<open>z \<cdot> concat us \<le>p concat vs\<close> concat_hd_pref[OF \<open>vs \<noteq> \<epsilon>\<close>]
+      by (intro ruler'[OF pref_trans[OF triv_pref]])
+    \<comment> \<open> splitting into three cases\<close>
+    then consider "z = \<epsilon>" | "z <p hd vs" and "z \<noteq> \<epsilon>" | "hd vs \<le>p z"
+      by (blast dest: pref_comp_not_spref)
+    then show thesis
+    proof (cases)
+      assume "z = \<epsilon>"
+      \<comment> \<open> first case follows from the fact @{thm "concat_pref_concat_conv"}\<close>
+      have "\<epsilon> \<le>p vs" "concat \<epsilon> = z" "\<epsilon> \<cdot> us \<le>p vs" 
+        using emp_pref concat.simps(1) \<open>z \<cdot> concat us \<le>p concat vs\<close>
+        unfolding \<open>z = \<epsilon>\<close> append_Nil concat_pref_concat_conv[OF \<open>us \<in> lists \<C>\<close> \<open>vs \<in> lists \<C>\<close>].
+      then show thesis by fact
+    next
+      assume "z <p hd vs" and "z \<noteq> \<epsilon>"
+      \<comment> \<open>second case leads to contradiction\<close>
+      with \<open>us \<in> lists \<C>\<close> \<open>vs \<in> lists \<C>\<close> have "set us \<subseteq> {hd vs}"
+         using \<open>z \<cdot> concat us \<le>p concat vs\<close> by (rule two_interpretations)
+      then show R for R using \<open>1 < card (set us)\<close>
+        by (simp add: \<open>us \<noteq> \<epsilon>\<close> subset_singleton_iff)
+    next
+      assume "hd vs \<le>p z"
+      \<comment> \<open>the last case follows using induction hypotheses for z'\<close>
+      then obtain z' where "z = hd vs \<cdot> z'"..
+      note \<open>us \<in> lists \<C>\<close> tl_in_lists[OF \<open>vs \<in> lists \<C>\<close>] \<open>1 < card (set us)\<close>
+      moreover have "z' \<cdot> concat us \<le>p concat (tl vs)"
+        using \<open>z \<cdot> concat us \<le>p concat vs\<close>
+        unfolding \<open>z = hd vs \<cdot> z'\<close> hd_concat_tl[OF \<open>vs \<noteq> \<epsilon>\<close>, symmetric] by simp
+      moreover have "\<^bold>|z'\<^bold>| < \<^bold>|z\<^bold>|" using \<open>z = hd vs \<cdot> z'\<close> \<open>hd vs \<noteq> \<epsilon>\<close> by simp
+      ultimately obtain ws'
+        where "hd vs # ws' \<le>p hd vs # tl vs"
+          and "concat (hd vs # ws') = hd vs \<cdot> z'"
+          and "hd vs # (ws' \<cdot> us) \<le>p hd vs # tl vs"
+        unfolding pref_cancel_hd_conv concat.simps(2) cancel
+        by (rule less.hyps[rotated 2])
+      then show thesis
+        unfolding \<open>z = hd vs \<cdot> z'\<close>[symmetric] hd_Cons_tl[OF \<open>vs \<noteq> \<epsilon>\<close>] append_Cons[symmetric]
+        by fact
+    qed
+qed
+
+theorem sings_prim_morph:
+  assumes "ws \<in> lists \<C>"
+      and "\<^bold>|ws\<^bold>| \<noteq> 1"
+      and "primitive ws"
+  shows "primitive (concat ws)"
+proof (rule ccontr)
+  have "ws \<in> lists \<C>" and "ws \<cdot> ws \<in> lists \<C>"
+    using \<open>ws \<in> lists \<C>\<close> by simp_all
+  moreover have "1 < card (set ws)" using \<open>primitive ws\<close> \<open>\<^bold>|ws\<^bold>| \<noteq> 1\<close> by (rule prim_card_set)
+  moreover assume "\<not> primitive (concat ws)"
+  then obtain k z where "2 \<le> k" and "z \<^sup>@ k = concat ws" by (elim not_prim_pow)
+  have "z \<cdot> concat ws \<le>p concat (ws \<cdot> ws)"
+    using \<open>2 \<le> k\<close> unfolding \<open>z \<^sup>@ k = concat ws\<close>[symmetric] concat_append
+    by (simp add: le_exps_pref flip: power_Suc power_add)
+  ultimately obtain vs where "vs \<le>p ws \<cdot> ws" and "concat vs = z" and "vs \<cdot> ws \<le>p ws \<cdot> ws"
+    by (rule unique_interpretation)
+  have "vs \<^sup>@ k \<in> lists \<C>"
+    using \<open>vs \<le>p ws \<cdot> ws\<close> \<open>ws \<cdot> ws \<in> lists \<C>\<close> by (intro pow_in_lists) (rule pref_in_lists)
+  moreover have "concat (vs \<^sup>@ k) = concat ws"
+    unfolding concat_pow \<open>concat vs = z\<close> \<open>z \<^sup>@ k = concat ws\<close>..
+  ultimately have "vs \<^sup>@ k = ws" using \<open>ws \<in> lists \<C>\<close> by (intro is_code)
+  show False
+    using prim_exp_one[OF \<open>primitive ws\<close> \<open>vs \<^sup>@ k = ws\<close>] \<open>2 \<le> k\<close> by presburger
+qed
+
+lemma sings_prim_concat_conv:
+  assumes "ws \<in> lists \<C>"
+      and "\<^bold>|ws\<^bold>| \<noteq> 1"
+  shows "primitive (concat ws) \<longleftrightarrow> primitive ws"
+  using prim_concat_prim sings_prim_morph[OF assms]..
+
+end
+
+\<comment> \<open>Exporting out of context\<close>
+lemmas sings_prim_morph = sings_code.sings_prim_morph[OF sings_code.intro]
+
+lemma (in code) code_roots_sings_code: "sings_code ((\<lambda> x. [\<rho> x]\<^sup>@(e\<^sub>\<rho> x)) ` \<C>)"
+proof
+  fix c assume "c \<in> (\<lambda>x. [\<rho> x] \<^sup>@ e\<^sub>\<rho> x) ` \<C>"
+  then obtain u where "u \<in> \<C>" and "c = [\<rho> u] \<^sup>@ e\<^sub>\<rho> u" by blast
+  have "u \<noteq> \<epsilon>" using \<open>u \<in> \<C>\<close> emp_not_in by auto  
+  from sing_pow_set[OF primroot_exp_nemp[OF \<open>u \<noteq> \<epsilon>\<close>], of "\<rho> u", folded \<open>c = [\<rho> u] \<^sup>@ e\<^sub>\<rho> u\<close>]  
+  show "card (set c) = 1" 
+    by simp
+
+  fix d assume "d \<in> (\<lambda>x. [\<rho> x] \<^sup>@ e\<^sub>\<rho> x) ` \<C>" and "c \<noteq> d"
+  then obtain v where "v \<in> \<C>" and "d = [\<rho> v] \<^sup>@ e\<^sub>\<rho> v" by blast
+  have "v \<noteq> \<epsilon>" using \<open>v \<in> \<C>\<close> emp_not_in by auto  
+  have "u \<noteq> v"
+    using \<open>c = [\<rho> u] \<^sup>@ e\<^sub>\<rho> u\<close> \<open>c \<noteq> d\<close> \<open>d = [\<rho> v] \<^sup>@ e\<^sub>\<rho> v\<close> by blast
+  hence "\<rho> u \<noteq> \<rho> v"
+    using code_not_comm[OF \<open>u \<in> \<C>\<close> \<open>v \<in> \<C>\<close>]
+    unfolding comm_primroots[OF \<open>u \<noteq> \<epsilon>\<close> \<open>v \<noteq> \<epsilon>\<close>] by blast 
+  with \<open>set c = {\<rho> u}\<close>
+        sing_pow_set[OF primroot_exp_nemp[OF \<open>v \<noteq> \<epsilon>\<close>], of "\<rho> v", folded \<open>d = [\<rho> v] \<^sup>@ e\<^sub>\<rho> v\<close>]
+  show "set c \<noteq> set d" 
+    by simp
+qed
+
+theorem (in code) roots_prim_morph: 
+  assumes "ws \<in> lists \<C>"
+      and "\<^bold>|ws\<^bold>| \<noteq> 1"
+      and "primitive ws"
+    shows "primitive (concat (map (\<lambda> x. [\<rho> x]\<^sup>@(e\<^sub>\<rho> x)) ws))"
+ (is "primitive (concat (map ?R ws))")
+proof-
+  interpret rc: sings_code "?R ` \<C>"
+    using code_roots_sings_code. 
+ 
+  show ?thesis 
+  proof (rule rc.sings_prim_morph)
+    show "primitive (map ?R ws)"
+    using  inj_map_prim[OF root_dec_inj_on
+           \<open>ws \<in> lists \<C>\<close> \<open>primitive ws\<close>].
+    show "map ?R ws \<in> lists (?R ` \<C>)"
+      using \<open>ws \<in> lists \<C>\<close> lists_image[of ?R \<C>] by force
+    show "\<^bold>|map (\<lambda>x. [\<rho> x] \<^sup>@ e\<^sub>\<rho> x) ws\<^bold>| \<noteq> 1"  
+      using \<open>\<^bold>|ws\<^bold>| \<noteq> 1\<close> by simp 
+  qed
+qed
+
 section \<open>Binary code\<close>
 
-text\<open>We pay a special attention to two element codes.
-In particular, we show that two words form a code if and only if they do not commute. This means that two
+text\<open>We pay a special attention to two element codes. 
+In particular, we show that two words form a code if and only if they do not commute. This means that two 
 words either commute, or do not satisfy any nontrivial relation.
 \<close>
 
-locale binary_code =
+definition  bin_lcp  where "bin_lcp x y  =  x\<cdot>y \<and>\<^sub>p y\<cdot>x" 
+definition  bin_lcs  where "bin_lcs x y  =  x\<cdot>y \<and>\<^sub>s y\<cdot>x" 
+
+definition  bin_mismatch where "bin_mismatch x y =  (x\<cdot>y)!\<^bold>|bin_lcp x y\<^bold>|"
+definition  bin_mismatch_suf where " bin_mismatch_suf x y = bin_mismatch (rev y) (rev x)"
+(* definition  bin_mismatch_suf where "bin_mismatch_suf x y =  (x\<cdot>y)!(\<^bold>|x \<cdot> y\<^bold>| - Suc(\<^bold>|bin_lcs x y\<^bold>|))" *)
+
+value[nbe] "[0::nat,1,0]!3"
+
+lemma bin_lcs_rev: "bin_lcs x y = rev (bin_lcp (rev x) (rev y))"
+  unfolding bin_lcp_def bin_lcs_def  longest_common_suffix_def rev_append using lcp_sym by fastforce
+
+lemma bin_lcp_sym: "bin_lcp x y = bin_lcp y x"
+  unfolding bin_lcp_def using lcp_sym.
+
+lemma bin_mismatch_comm: "(bin_mismatch x y = bin_mismatch y x) \<longleftrightarrow> (x \<cdot> y = y \<cdot> x)"
+  unfolding bin_mismatch_def bin_lcp_def lcp_sym[of "y \<cdot> x"]
+  using  lcp_mismatch'[of "x \<cdot> y" "y \<cdot> x", unfolded comm_comp_eq_conv[of x y]]   by fastforce
+
+lemma bin_lcp_pref_fst_snd: "bin_lcp x y \<le>p x \<cdot> y"
+  unfolding bin_lcp_def using lcp_pref.
+
+lemma bin_lcp_pref_snd_fst: "bin_lcp x y \<le>p y \<cdot> x"
+  using bin_lcp_pref_fst_snd[of y x, unfolded bin_lcp_sym[of y x]].
+
+lemma bin_lcp_bin_lcs [reversal_rule]:  "bin_lcp (rev x) (rev y) = rev (bin_lcs x y)"
+  unfolding bin_lcp_def bin_lcs_def rev_append[symmetric] lcs_lcp
+           lcs_sym[of "x \<cdot> y"]..  
+
+lemmas bin_lcs_sym = bin_lcp_sym[reversed]
+
+lemma bin_lcp_len: "x \<cdot> y \<noteq> y \<cdot> x \<Longrightarrow> \<^bold>|bin_lcp x y\<^bold>| < \<^bold>|x \<cdot> y\<^bold>|" 
+  unfolding bin_lcp_def
+  using lcp_len' pref_comm_eq by blast 
+
+lemmas bin_lcs_len = bin_lcp_len[reversed]
+
+lemma bin_mismatch_pref_suf'[reversal_rule]:  
+ "bin_mismatch (rev y) (rev x) =  bin_mismatch_suf x y"
+  unfolding bin_mismatch_suf_def..
+
+locale binary_code = 
   fixes u\<^sub>0 u\<^sub>1
-  assumes non_comm: "u\<^sub>0 \<cdot> u\<^sub>1 \<noteq> u\<^sub>1 \<cdot> u\<^sub>0"
+  assumes non_comm: "u\<^sub>0 \<cdot> u\<^sub>1 \<noteq> u\<^sub>1 \<cdot> u\<^sub>0" 
 
 begin
 
-lemma bin_fst_nemp: "u\<^sub>0 \<noteq> \<epsilon>"
-  using non_comm by auto
-
 text\<open>A crucial property of two element codes is the constant decoding delay given by the word $\alpha$,
-which is a prefix of any generating word (sufficiently long), while the letter
+which is a prefix of any generating word (sufficiently long), while the letter 
 immediately after this common prefix indicates the first element of the decomposition.
 \<close>
 
-definition  \<alpha> where bin_lcp_def [simp]: "\<alpha> =  u\<^sub>0\<cdot>u\<^sub>1 \<and>\<^sub>p u\<^sub>1\<cdot>u\<^sub>0"
-definition  c\<^sub>0 where fst_mismatch_def: "c\<^sub>0 =  (u\<^sub>0\<cdot>u\<^sub>1)!\<^bold>|\<alpha>\<^bold>|"
-definition  c\<^sub>1 where snd_mismatch_def: "c\<^sub>1 =  (u\<^sub>1\<cdot>u\<^sub>0)!\<^bold>|\<alpha>\<^bold>|"
+lemma bin_code_swap: "binary_code u\<^sub>1 u\<^sub>0"
+  using binary_code.intro[OF non_comm[symmetric]].
 
-lemma bin_mismatch_neq: "c\<^sub>0 \<noteq> c\<^sub>1"
-  unfolding fst_mismatch_def snd_mismatch_def bin_lcp_def
-  using non_comm lcp_mismatch' pref_comp_eq[of "u\<^sub>0 \<cdot> u\<^sub>1" "u\<^sub>1 \<cdot> u\<^sub>0", OF _ swap_len]
-  unfolding prefix_comparable_def
-  by blast
+lemma bin_code_neq: "u\<^sub>0 \<noteq> u\<^sub>1"
+  using non_comm by auto
 
-lemma bin_lcp_pref_fst_snd: "\<alpha> \<le>p u\<^sub>0 \<cdot> u\<^sub>1" and bin_lcp_pref_snd_fst: "\<alpha> \<le>p u\<^sub>1 \<cdot> u\<^sub>0"
-  unfolding bin_lcp_def using longest_common_prefix_prefix1 longest_common_prefix_prefix2.
+lemma bin_fst_nemp: "u\<^sub>0 \<noteq> \<epsilon>" and bin_snd_nemp: "u\<^sub>1 \<noteq> \<epsilon>"
+  using non_comm by auto 
+
+lemma bin_not_comp: "\<not> u\<^sub>0 \<cdot> u\<^sub>1 \<bowtie> u\<^sub>1 \<cdot> u\<^sub>0"
+  using comm_comp_eq_conv non_comm by blast 
+
+lemma bin_not_comp_suf: "\<not> u\<^sub>0 \<cdot> u\<^sub>1 \<bowtie>\<^sub>s u\<^sub>1 \<cdot> u\<^sub>0" 
+  using comm_comp_eq_conv_suf non_comm[reversed] by blast 
+
+lemma bin_mismatch_neq: "bin_mismatch u\<^sub>0 u\<^sub>1 \<noteq> bin_mismatch u\<^sub>1 u\<^sub>0"
+  using non_comm[folded bin_mismatch_comm].
+
+abbreviation bin_code_lcp ("\<alpha>") where  "bin_code_lcp \<equiv> bin_lcp u\<^sub>0 u\<^sub>1"
+abbreviation bin_code_lcs where "bin_code_lcs \<equiv> bin_lcs u\<^sub>0 u\<^sub>1"
+abbreviation bin_code_mismatch_fst ("c\<^sub>0") where "bin_code_mismatch_fst \<equiv> bin_mismatch u\<^sub>0 u\<^sub>1"
+abbreviation bin_code_mismatch_snd ("c\<^sub>1") where "bin_code_mismatch_snd \<equiv> bin_mismatch u\<^sub>1 u\<^sub>0"
+(* abbreviation "bin_code_lcp' \<equiv> bin_lcp u\<^sub>1 u\<^sub>0" *)
+(* abbreviation "bin_code_lcs' \<equiv> bin_lcs u\<^sub>1 u\<^sub>0" *)
+(* abbreviation "bin_code_mismatch_suf_fst \<equiv> bin_mismatch_suf u\<^sub>0 u\<^sub>1" *)
+(* abbreviation "bin_code_mismatch_suf_snd \<equiv> bin_mismatch_suf u\<^sub>1 u\<^sub>0" *)
+
+lemmas bin_lcp_swap = bin_lcp_sym[of u\<^sub>0 u\<^sub>1, symmetric]
 
 lemma bin_lcp_short: "\<^bold>|\<alpha>\<^bold>| < \<^bold>|u\<^sub>0\<^bold>| + \<^bold>|u\<^sub>1\<^bold>|"
 proof-
   have "\<not> u\<^sub>0\<cdot>u\<^sub>1 \<le>p u\<^sub>1\<cdot>u\<^sub>0"
     using comm_ruler non_comm by blast
-  from lcp_len'[OF this, folded bin_lcp_def, unfolded length_append]
+  from lcp_len'[OF this, folded bin_lcp_def, unfolded lenmorph]
   show  "\<^bold>|\<alpha>\<^bold>| < \<^bold>|u\<^sub>0\<^bold>| + \<^bold>|u\<^sub>1\<^bold>|".
 qed
 
-lemma bin_lcp_fst_mismatch_pref:  "\<alpha> \<cdot> [c\<^sub>0] \<le>p u\<^sub>0 \<cdot> \<alpha>"
+lemma bin_fst_mismatch': "\<alpha> \<cdot> [c\<^sub>0] \<le>p u\<^sub>0 \<cdot> u\<^sub>1"
+  by (simp add: append_one_prefix bin_lcp_pref_fst_snd bin_lcp_short bin_mismatch_def) 
+
+lemma bin_fst_mismatch: "\<alpha> \<cdot> [c\<^sub>0] \<le>p u\<^sub>0 \<cdot> \<alpha>"
 proof-
-  have "\<alpha> \<cdot> [c\<^sub>0] \<le>p u\<^sub>0 \<cdot> u\<^sub>1"
-    using  append_one_prefix[of \<alpha> "u\<^sub>0 \<cdot> u\<^sub>1", folded fst_mismatch_def, OF bin_lcp_pref_fst_snd, unfolded length_append, OF bin_lcp_short].
-  hence "\<alpha> \<cdot> [c\<^sub>0] \<le>p u\<^sub>0 \<cdot> (u\<^sub>1 \<cdot> u\<^sub>0)"
+  from bin_fst_mismatch'
+  have "\<alpha> \<cdot> [c\<^sub>0] \<le>p u\<^sub>0 \<cdot> (u\<^sub>1 \<cdot> u\<^sub>0)"
     using pref_prolong by blast
-  from pref_prod_pref_short[OF this bin_lcp_pref_snd_fst, unfolded length_append sing_len]
+  from pref_prod_pref_short[OF this bin_lcp_pref_snd_fst, unfolded lenmorph sing_len]
   show "\<alpha> \<cdot> [c\<^sub>0] \<le>p u\<^sub>0 \<cdot> \<alpha>"
     using  nemp_len[OF bin_fst_nemp] by linarith
 qed
 
-lemma not_fst_snd_pref:  "\<not> u\<^sub>0 \<cdot> u\<^sub>1 \<le>p \<alpha>"
-  using bin_lcp_short[folded length_append[of u\<^sub>0 u\<^sub>1]]  prefix_order.antisym[OF bin_lcp_pref_fst_snd] by fastforce
-
-lemma bin_lcp_fst_mismatch_pref':  "\<alpha> \<cdot> [c\<^sub>0] \<le>p u\<^sub>0 \<cdot> u\<^sub>1"
-  using strict_prefixI[OF bin_lcp_pref_fst_snd, THEN add_nth_pref, folded fst_mismatch_def] not_fst_snd_pref
-  self_pref[of \<alpha>] by fastforce
+lemmas bin_snd_mismatch' = binary_code.bin_fst_mismatch'[OF bin_code_swap, unfolded bin_lcp_swap] and
+       bin_snd_mismatch  = binary_code.bin_fst_mismatch[OF bin_code_swap, unfolded bin_lcp_swap]
 
-interpretation symcode: binary_code u\<^sub>1 u\<^sub>0
-  rewrites  "symcode.c\<^sub>0 = c\<^sub>1" and  "symcode.c\<^sub>1 = c\<^sub>0" and "symcode.\<alpha> = \<alpha>"
-proof-
-  show "binary_code u\<^sub>1 u\<^sub>0"
-    unfolding  binary_code_def using non_comm by simp
-  show "binary_code.\<alpha> u\<^sub>1 u\<^sub>0 = \<alpha>"
-    by (simp add: \<open>binary_code u\<^sub>1 u\<^sub>0\<close> binary_code.bin_lcp_def lcp_sym)
-  show "binary_code.c\<^sub>0 u\<^sub>1 u\<^sub>0 = c\<^sub>1"
-    by (simp add: \<open>binary_code u\<^sub>1 u\<^sub>0\<close> \<open>binary_code.\<alpha> u\<^sub>1 u\<^sub>0 = \<alpha>\<close> binary_code.fst_mismatch_def snd_mismatch_def)
-  show "binary_code.c\<^sub>1 u\<^sub>1 u\<^sub>0 = c\<^sub>0"
-    by (simp add: \<open>binary_code u\<^sub>1 u\<^sub>0\<close> \<open>binary_code.\<alpha> u\<^sub>1 u\<^sub>0 = \<alpha>\<close> binary_code.snd_mismatch_def fst_mismatch_def)
+lemma bin_lcp_pref_all: "xs \<in> lists {u\<^sub>0,u\<^sub>1} \<Longrightarrow> \<alpha> \<le>p concat xs \<cdot> \<alpha>"
+proof (induct xs, simp)
+  case (Cons a xs)
+  have "a \<in> {u\<^sub>0,u\<^sub>1}" and "xs \<in> lists {u\<^sub>0, u\<^sub>1}"
+      using \<open>a # xs \<in> lists {u\<^sub>0, u\<^sub>1}\<close> by simp_all
+  show ?case
+  proof (rule two_elemP[OF \<open>a \<in> {u\<^sub>0,u\<^sub>1}\<close>], simp_all)
+    show "\<alpha> \<le>p u\<^sub>0 \<cdot> concat xs \<cdot> \<alpha>"
+      using pref_extD[OF bin_fst_mismatch] Cons.hyps[OF \<open>xs \<in> lists {u\<^sub>0, u\<^sub>1}\<close>] pref_prolong by blast 
+  next 
+    show "\<alpha> \<le>p u\<^sub>1 \<cdot> concat xs \<cdot> \<alpha>"
+      using pref_extD[OF bin_snd_mismatch] Cons.hyps[OF \<open>xs \<in> lists {u\<^sub>0, u\<^sub>1}\<close>] pref_prolong by blast 
+  qed
 qed
 
-lemmas bin_snd_nemp = symcode.bin_fst_nemp and
-       bin_snd_mismatch = symcode.bin_lcp_fst_mismatch_pref
+lemma bin_lcp_pref_all_hull: "w \<in> \<langle>{u\<^sub>0,u\<^sub>1}\<rangle> \<Longrightarrow> \<alpha> \<le>p w \<cdot> \<alpha>" 
+  using bin_lcp_pref_all using hull_concat_listsE by metis
+
+lemma bin_fst_mismatch_all: "xs \<in> lists {u\<^sub>0,u\<^sub>1} \<Longrightarrow> \<alpha> \<cdot> [c\<^sub>0] \<le>p u\<^sub>0 \<cdot> concat xs \<cdot> \<alpha>"
+using pref_prolong[OF bin_fst_mismatch bin_lcp_pref_all].
+
+lemma bin_fst_mismatch_all_hull: assumes "w \<in> \<langle>{u\<^sub>0,u\<^sub>1}\<rangle>" shows "\<alpha> \<cdot> [c\<^sub>0] \<le>p u\<^sub>0 \<cdot> w \<cdot> \<alpha>"
+  using bin_fst_mismatch_all hull_concat_listsE[OF assms] by metis 
+
+lemma bin_snd_mismatch_all: assumes "xs \<in> lists {u\<^sub>0,u\<^sub>1}" 
+  shows "\<alpha> \<cdot> [c\<^sub>1] \<le>p u\<^sub>1 \<cdot> concat xs \<cdot> \<alpha>"
+  using pref_prolong[OF bin_snd_mismatch bin_lcp_pref_all[OF assms]]. 
+
+lemma bin_snd_mismatch_all_hull: assumes "w \<in> \<langle>{u\<^sub>0,u\<^sub>1}\<rangle>" 
+  shows "\<alpha> \<cdot> [c\<^sub>1] \<le>p u\<^sub>1 \<cdot> w \<cdot> \<alpha>"
+  using bin_snd_mismatch_all hull_concat_listsE[OF assms] by metis 
+
+lemma hd_lq_mismatch_fst: "hd (\<alpha>\<inverse>\<^sup>>(u\<^sub>0 \<cdot> \<alpha>)) = c\<^sub>0"
+  using hd_lq_conv_nth[OF prefix_snocD[OF bin_fst_mismatch]] bin_fst_mismatch
+   by (auto simp add: prefix_def)
+
+lemma hd_lq_mismatch_snd: "hd (\<alpha>\<inverse>\<^sup>>(u\<^sub>1 \<cdot> \<alpha>)) = c\<^sub>1"
+  using hd_lq_conv_nth[OF prefix_snocD[OF bin_snd_mismatch]] bin_snd_mismatch
+   by (auto simp add: prefix_def)
+
+lemma hds_bin_mismatch_neq: "hd (\<alpha>\<inverse>\<^sup>>(u\<^sub>0 \<cdot> \<alpha>)) \<noteq> hd (\<alpha>\<inverse>\<^sup>>(u\<^sub>1 \<cdot> \<alpha>))"
+  unfolding hd_lq_mismatch_fst hd_lq_mismatch_snd
+  using bin_mismatch_neq. 
+
+lemma bin_lcp_fst_pow_pref: "\<alpha> \<cdot> [c\<^sub>0] \<le>p u\<^sub>0\<^sup>@Suc k \<cdot> u\<^sub>1 \<cdot> z" 
+proof (induct k)
+case 0
+then show ?case
+  using pref_ext[OF bin_fst_mismatch'] by auto 
+next
+case (Suc k)
+  from pref_prolong[OF bin_fst_mismatch, OF pref_extD[OF this]]
+  show ?case
+    unfolding pow_Suc rassoc.
+qed
+
+lemmas bin_lcp_snd_pow_pref = binary_code.bin_lcp_fst_pow_pref[OF bin_code_swap, unfolded bin_lcp_swap]
 
 lemma bin_lcp_fst_lcp: "\<alpha> \<le>p u\<^sub>0 \<cdot> \<alpha>" and bin_lcp_snd_lcp: "\<alpha> \<le>p u\<^sub>1 \<cdot> \<alpha>"
-  using bin_lcp_fst_mismatch_pref  bin_snd_mismatch by auto
-
-lemma bin_all_nemp: "ws \<in> lists {u\<^sub>0,u\<^sub>1} \<Longrightarrow> concat ws = \<epsilon> \<Longrightarrow> ws = \<epsilon>"
-using bin_fst_nemp bin_snd_nemp by(induct ws, simp, auto)
+  using pref_extD[OF bin_fst_mismatch]  pref_extD[OF bin_snd_mismatch].
 
-lemma bin_lcp_all_lcp: "ws \<in> lists {u\<^sub>0,u\<^sub>1} \<Longrightarrow> \<alpha> \<le>p concat ws \<cdot> \<alpha>"
-  proof(induct ws rule: rev_induct, simp)
-    case (snoc x xs)
-  have x_or: "x = u\<^sub>0 \<or> x = u\<^sub>1"
-    using \<open>xs \<cdot> [x] \<in> lists {u\<^sub>0, u\<^sub>1}\<close> by simp
-  have "xs \<in> lists {u\<^sub>0, u\<^sub>1}"
-      using \<open>xs \<cdot> [x] \<in> lists {u\<^sub>0, u\<^sub>1}\<close> by auto
-  from pref_prolong[OF snoc.hyps, OF this, of "x\<cdot>\<alpha>", unfolded lassoc]
-  show ?case
-    using bin_lcp_fst_lcp bin_lcp_snd_lcp disjE[OF x_or] by auto
+lemma bin_lcp_pref_all_set: assumes "set ws = {u\<^sub>0,u\<^sub>1}"
+  shows "\<alpha> \<le>p concat ws" 
+proof-
+  have "ws \<in> lists {u\<^sub>0, u\<^sub>1}" 
+    using assms by blast
+  have "\<^bold>|u\<^sub>0\<^bold>| + \<^bold>|u\<^sub>1\<^bold>| \<le> \<^bold>|concat ws\<^bold>|"
+    using assms two_in_set_concat_len[OF bin_code_neq] by simp
+  with pref_prod_le[OF bin_lcp_pref_all[OF \<open>ws \<in> lists {u\<^sub>0, u\<^sub>1}\<close>]] bin_lcp_short 
+  show ?thesis 
+    by simp
 qed
 
-lemma bin_code_alpha: assumes "us \<in> lists {u\<^sub>0,u\<^sub>1}" and "vs \<in> lists {u\<^sub>0,u\<^sub>1}" and "hd us  \<noteq> hd vs"
+lemma bin_lcp_conjug_morph: 
+  assumes "u \<in> \<langle>{u\<^sub>0,u\<^sub>1}\<rangle>" and "v \<in> \<langle>{u\<^sub>0,u\<^sub>1}\<rangle>"
+  shows "\<alpha>\<inverse>\<^sup>>(u \<cdot> \<alpha>) \<cdot> \<alpha>\<inverse>\<^sup>>(v \<cdot> \<alpha>) = \<alpha>\<inverse>\<^sup>>((u \<cdot> v) \<cdot> \<alpha>)"
+  unfolding lq_reassoc[OF bin_lcp_pref_all_hull[OF \<open>u \<in> \<langle>{u\<^sub>0,u\<^sub>1}\<rangle>\<close>]] rassoc
+   lq_pref[OF bin_lcp_pref_all_hull[OF \<open>v \<in> \<langle>{u\<^sub>0,u\<^sub>1}\<rangle>\<close>]].. 
+
+lemma lcp_bin_conjug_prim_iff:
+  "set ws = {u\<^sub>0,u\<^sub>1} \<Longrightarrow> primitive (\<alpha>\<inverse>\<^sup>>(concat ws) \<cdot> \<alpha>) \<longleftrightarrow> primitive (concat ws)"
+  using conjug_prim_iff[OF root_conjug[OF pref_ext[OF bin_lcp_pref_all_set]], symmetric]
+  unfolding lq_reassoc[OF bin_lcp_pref_all_set] by simp
+
+lemma bin_lcp_conjug_inj_on: "inj_on (\<lambda>u. \<alpha>\<inverse>\<^sup>>(u \<cdot> \<alpha>)) \<langle>{u\<^sub>0,u\<^sub>1}\<rangle>"
+  unfolding inj_on_def using bin_lcp_pref_all_hull cancel_right lq_pref
+  by metis
+
+lemma bin_code_lcp_marked: assumes "us \<in> lists {u\<^sub>0,u\<^sub>1}" and "vs \<in> lists {u\<^sub>0,u\<^sub>1}" and "hd us \<noteq> hd vs" 
+  shows "concat us \<cdot> \<alpha> \<and>\<^sub>p concat vs \<cdot> \<alpha> = \<alpha>"
+proof (cases "us = \<epsilon> \<or> vs = \<epsilon>")
+  assume "us = \<epsilon> \<or> vs = \<epsilon>"
+  thus ?thesis
+    using append_self_conv2 assms(1) assms(2) bin_lcp_pref_all concat.simps(1) lcp_pref_conv lcp_sym by metis 
+next
+  assume "\<not> (us = \<epsilon> \<or> vs = \<epsilon>)" hence "us \<noteq> \<epsilon>" and "vs \<noteq> \<epsilon>" by blast+
+  have spec_case: "concat us \<cdot> \<alpha> \<and>\<^sub>p concat vs \<cdot> \<alpha> = \<alpha>" if "us \<in> lists {u\<^sub>0,u\<^sub>1}" and "vs \<in> lists {u\<^sub>0,u\<^sub>1}" and "hd us = u\<^sub>0" and "hd vs = u\<^sub>1" and "us \<noteq> \<epsilon>" and "vs \<noteq> \<epsilon>" for us vs
+  proof-
+    have "concat us = u\<^sub>0 \<cdot> concat (tl us)"
+      unfolding hd_concat_tl[OF \<open>us \<noteq> \<epsilon>\<close>, symmetric] \<open>hd us = u\<^sub>0\<close>..
+    from bin_fst_mismatch_all[OF tl_in_lists[OF \<open>us \<in> lists {u\<^sub>0,u\<^sub>1}\<close>], folded rassoc this]
+    have pref1: "\<alpha> \<cdot> [c\<^sub>0] \<le>p concat us \<cdot> \<alpha>".
+    have "concat vs = u\<^sub>1 \<cdot> concat (tl vs)"
+      unfolding hd_concat_tl[OF \<open>vs \<noteq> \<epsilon>\<close>, symmetric] \<open>hd vs = u\<^sub>1\<close>..
+    from bin_snd_mismatch_all[OF tl_in_lists[OF \<open>vs \<in> lists {u\<^sub>0,u\<^sub>1}\<close>], folded rassoc this]
+    have pref2: "\<alpha> \<cdot> [c\<^sub>1] \<le>p concat vs \<cdot> \<alpha>".
+    show ?thesis
+      using  lcp_first_mismatch_pref[OF pref1 pref2 bin_mismatch_neq].
+  qed
+  have "hd us \<in>  {u\<^sub>0,u\<^sub>1}" and "hd vs \<in>  {u\<^sub>0,u\<^sub>1}" using
+    lists_hd_in_set[OF \<open>us \<noteq> \<epsilon>\<close> \<open>us \<in> lists {u\<^sub>0, u\<^sub>1}\<close>] lists_hd_in_set[OF \<open>vs \<noteq> \<epsilon>\<close> \<open>vs \<in> lists {u\<^sub>0, u\<^sub>1}\<close>].
+  then consider "hd us = u\<^sub>0 \<and> hd vs = u\<^sub>1" | "hd us = u\<^sub>1 \<and> hd vs = u\<^sub>0"
+    using \<open>hd us \<noteq> hd vs\<close> by fastforce 
+  then show ?thesis
+    using spec_case[rule_format] \<open>us \<noteq> \<epsilon>\<close> \<open>vs \<noteq> \<epsilon>\<close> assms lcp_sym by metis
+qed
+
+\<comment> \<open>ALT PROOF\<close> 
+lemma  assumes "us \<in> lists {u\<^sub>0,u\<^sub>1}" and "vs \<in> lists {u\<^sub>0,u\<^sub>1}" and "hd us \<noteq> hd vs" 
   shows "concat us \<cdot> \<alpha> \<and>\<^sub>p concat vs \<cdot> \<alpha> = \<alpha>"
   using assms
 proof (induct us vs rule: list_induct2', simp)
   case (2 x xs)
   show ?case
-    using bin_lcp_all_lcp[OF \<open>x # xs \<in> lists {u\<^sub>0, u\<^sub>1}\<close>, folded lcp_pref_conv, unfolded lcp_sym[of \<alpha>]] by simp
+    using bin_lcp_pref_all[OF \<open>x # xs \<in> lists {u\<^sub>0, u\<^sub>1}\<close>, folded lcp_pref_conv, unfolded lcp_sym[of \<alpha>]] by simp
 next
   case (3 y ys)
   show ?case
-    using bin_lcp_all_lcp[OF \<open>y # ys \<in> lists {u\<^sub>0, u\<^sub>1}\<close>, folded lcp_pref_conv] by simp
+    using bin_lcp_pref_all[OF \<open>y # ys \<in> lists {u\<^sub>0, u\<^sub>1}\<close>, folded lcp_pref_conv] by simp
 next
   case (4 x xs y ys)
   interpret i: binary_code x y
-    using "4.prems"(1) "4.prems"(2) "4.prems"(3) non_comm binary_code.intro by auto
+    using "4.prems"(1) "4.prems"(2) "4.prems"(3) non_comm binary_code.intro by auto 
   have alph: "{u\<^sub>0,u\<^sub>1} = {x,y}"
     using "4.prems"(1) "4.prems"(2) "4.prems"(3) by auto
   from disjE[OF this[unfolded doubleton_eq_iff]]
-  have \<alpha>id: "i.\<alpha> = \<alpha>"
-    unfolding bin_lcp_def i.bin_lcp_def using lcp_sym by auto
-  have c0: "i.\<alpha> \<cdot> [i.c\<^sub>0] \<le>p x \<cdot> concat xs \<cdot> i.\<alpha>"
-    using  i.bin_lcp_all_lcp[of xs] \<open>x # xs \<in> lists {u\<^sub>0, u\<^sub>1}\<close>[unfolded Cons_in_lists_iff alph]
-      pref_prolong[OF i.bin_lcp_fst_mismatch_pref] by blast
-  have c1: "i.\<alpha> \<cdot> [i.c\<^sub>1] \<le>p y \<cdot> concat ys \<cdot> i.\<alpha>"
-    using  i.bin_lcp_all_lcp[of ys] \<open>y # ys \<in> lists {u\<^sub>0, u\<^sub>1}\<close>[unfolded Cons_in_lists_iff alph]
-      pref_prolong[OF i.bin_snd_mismatch] by blast
-  have "i.\<alpha>\<cdot>[i.c\<^sub>0] \<and>\<^sub>p i.\<alpha>\<cdot>[i.c\<^sub>1] = i.\<alpha>"
+  have "i.bin_code_lcp = \<alpha>"  
+    using i.bin_lcp_swap[symmetric] by blast
+  have c0: "i.bin_code_lcp \<cdot> [i.bin_code_mismatch_fst] \<le>p x \<cdot> concat xs \<cdot> i.bin_code_lcp"
+    using  i.bin_lcp_pref_all[of xs] \<open>x # xs \<in> lists {u\<^sub>0, u\<^sub>1}\<close>[unfolded Cons_in_lists_iff alph] 
+      pref_prolong[OF i.bin_fst_mismatch] by blast
+  have c1: "i.bin_code_lcp \<cdot> [i.bin_code_mismatch_snd] \<le>p y \<cdot> concat ys \<cdot> i.bin_code_lcp"
+    using pref_prolong[OF conjunct2[OF \<open>y # ys \<in> lists {u\<^sub>0, u\<^sub>1}\<close>[unfolded      Cons_in_lists_iff alph],
+          THEN i.bin_snd_mismatch_all[of ys]], OF self_pref]. 
+  have "i.bin_code_lcp\<cdot>[i.bin_code_mismatch_fst] \<and>\<^sub>p i.bin_code_lcp\<cdot>[i.bin_code_mismatch_snd] = i.bin_code_lcp"
     by (simp add: i.bin_mismatch_neq lcp_first_mismatch')
-  from lcp_rulers[OF c0 c1, unfolded this, unfolded \<alpha>id]
-  show ?case
-    unfolding concat.simps(2) rassoc pref_cancel_conv  using i.bin_mismatch_neq by simp
+  from lcp_rulers[OF c0 c1, unfolded this, unfolded bin_lcp_swap]
+  show ?case                               
+    unfolding concat.simps(2) rassoc using i.bin_mismatch_neq
+     \<open>i.bin_code_lcp = \<alpha>\<close> by force 
+         
 qed
 
+lemma bin_code_lcp_concat: assumes "us \<in> lists {u\<^sub>0,u\<^sub>1}" and "vs \<in> lists {u\<^sub>0,u\<^sub>1}" and "\<not> us \<bowtie> vs" 
+  shows "concat us \<cdot> \<alpha> \<and>\<^sub>p concat vs \<cdot> \<alpha> = concat (us \<and>\<^sub>p vs) \<cdot> \<alpha>"
+proof-
+  obtain us' vs' where us: "(us \<and>\<^sub>p vs) \<cdot> us' = us" and vs: "(us \<and>\<^sub>p vs) \<cdot> vs' = vs" and "us' \<noteq> \<epsilon>" and "vs' \<noteq> \<epsilon>" and "hd us' \<noteq> hd vs'"
+    using lcp_mismatchE[OF \<open>\<not> us \<bowtie> vs\<close>].
+  have cu: "concat us \<cdot> \<alpha> = concat (us \<and>\<^sub>p vs) \<cdot> concat us' \<cdot> \<alpha>"
+    unfolding lassoc concat_morph[symmetric] us..
+  have cv: "concat vs \<cdot> \<alpha> = concat (us \<and>\<^sub>p vs) \<cdot> concat vs' \<cdot> \<alpha>"
+    unfolding lassoc concat_morph[symmetric] vs..
+  have "us' \<in> lists {u\<^sub>0,u\<^sub>1}"
+    using \<open>us \<in> lists {u\<^sub>0,u\<^sub>1}\<close> us by inlists
+  have "vs' \<in> lists {u\<^sub>0,u\<^sub>1}"
+    using \<open>vs \<in> lists {u\<^sub>0,u\<^sub>1}\<close> vs by inlists
+  show "concat us \<cdot> \<alpha> \<and>\<^sub>p concat vs \<cdot> \<alpha> = concat (us \<and>\<^sub>p vs) \<cdot> \<alpha>"
+    unfolding cu cv 
+    using bin_code_lcp_marked[OF \<open>us' \<in> lists {u\<^sub>0,u\<^sub>1}\<close> \<open>vs' \<in> lists {u\<^sub>0,u\<^sub>1}\<close> \<open>hd us' \<noteq> hd vs'\<close>]
+    unfolding lcp_ext_left by fast
+qed
+
+lemma bin_code_lcp_concat': assumes "us \<in> lists {u\<^sub>0,u\<^sub>1}" and "vs \<in> lists {u\<^sub>0,u\<^sub>1}" and "\<not> concat us \<bowtie> concat vs" 
+  shows "concat us \<and>\<^sub>p concat vs = concat (us \<and>\<^sub>p vs) \<cdot> \<alpha>"
+  using bin_code_lcp_concat[OF assms(1-2)] assms(3) lcp_ext_right_conv pref_concat_pref prefix_comparable_def by metis
+
+lemma bin_lcp_pows:  "u\<^sub>0\<^sup>@Suc k \<cdot> u\<^sub>1 \<cdot> z \<and>\<^sub>p u\<^sub>1\<^sup>@Suc l \<cdot> u\<^sub>0 \<cdot> z' = \<alpha>"
+  using lcp_first_mismatch_pref[OF bin_lcp_fst_pow_pref bin_lcp_snd_pow_pref bin_mismatch_neq].
+
 theorem bin_code: assumes "us \<in> lists {u\<^sub>0,u\<^sub>1}" and "vs \<in> lists {u\<^sub>0,u\<^sub>1}" and "concat us = concat vs"
   shows "us = vs"
   using assms
 proof (induct us vs rule: list_induct2', simp)
 case (2 x xs)
   then show ?case
-    using bin_fst_nemp bin_snd_nemp by auto
+    using bin_fst_nemp bin_snd_nemp by auto 
 next
   case (3 y ys)
-  then show ?case
-    using bin_fst_nemp bin_snd_nemp by auto
+  then show ?case 
+    using bin_fst_nemp bin_snd_nemp by auto 
 next
   case (4 x xs y ys)
-  then show ?case
+  then show ?case 
   proof(cases "x = y")
-    assume "x = y"  thus "x # xs = y # ys"
-      using "4.hyps" \<open>concat (x # xs) = concat (y # ys)\<close>[unfolded  concat.simps(2) \<open>x = y\<close>, unfolded cancel]
+    assume "x = y"  thus "x # xs = y # ys" 
+      using "4.hyps" \<open>concat (x # xs) = concat (y # ys)\<close>[unfolded  concat.simps(2) \<open>x = y\<close>, unfolded cancel]  
       \<open>y # ys \<in> lists {u\<^sub>0, u\<^sub>1}\<close>[unfolded Cons_in_lists_iff] \<open>x # xs \<in> lists {u\<^sub>0, u\<^sub>1}\<close>[unfolded Cons_in_lists_iff]
-      by simp
+      by simp   
   next
     assume "x \<noteq> y"
     have "concat(y # ys) = \<epsilon>"
-      using bin_code_alpha[OF \<open>x # xs \<in> lists {u\<^sub>0, u\<^sub>1}\<close> \<open>y # ys \<in> lists {u\<^sub>0, u\<^sub>1}\<close>, unfolded list.sel(1) \<open>concat (x # xs) = concat (y # ys)\<close>, OF \<open>x \<noteq> y\<close>]
+      using bin_code_lcp_marked[OF \<open>x # xs \<in> lists {u\<^sub>0, u\<^sub>1}\<close> \<open>y # ys \<in> lists {u\<^sub>0, u\<^sub>1}\<close>, unfolded list.sel(1) \<open>concat (x # xs) = concat (y # ys)\<close>, OF \<open>x \<noteq> y\<close>]
       by simp
-    from bin_all_nemp[OF \<open>y # ys \<in> lists {u\<^sub>0, u\<^sub>1}\<close> this]
-    have False by simp
-    thus "x # xs = y # ys" by blast
+    hence "x = \<epsilon>" and "y = \<epsilon>"
+      using \<open> concat (x # xs) = concat (y # ys)\<close> unfolding concat.simps(2) pref_nemp by force+
+    with  \<open>x \<noteq> y\<close>  
+    show "x # xs = y # ys" by blast  
   qed
 qed
 
-end
+lemma code_bin_roots: "binary_code (\<rho> u\<^sub>0) (\<rho> u\<^sub>1)" 
+  using non_comm comp_primroot_conv' by unfold_locales blast 
+
+sublocale code "{u\<^sub>0,u\<^sub>1}"
+  using bin_code by unfold_locales
+
+lemma bin_code_prefs: assumes "w0 \<in> \<langle>{u\<^sub>0,u\<^sub>1}\<rangle>" and "p \<le>p w0" "w1 \<in> \<langle>{u\<^sub>0,u\<^sub>1}\<rangle>" and "\<^bold>|u\<^sub>1\<^bold>| \<le> \<^bold>|p\<^bold>|"
+      shows " \<not> u\<^sub>0 \<cdot>  p \<le>p u\<^sub>1 \<cdot> w1"
+proof
+  assume contr: "u\<^sub>0 \<cdot> p  \<le>p u\<^sub>1 \<cdot> w1" 
+  have "\<^bold>|\<alpha>\<^bold>| < \<^bold>|u\<^sub>0 \<cdot> p\<^bold>|"
+    using \<open>\<^bold>|u\<^sub>1\<^bold>| \<le> \<^bold>|p\<^bold>|\<close> bin_lcp_short by auto
+  obtain ws0 where "ws0 \<in> lists {u\<^sub>0,u\<^sub>1}" and "concat ws0 = w0"
+    using \<open>w0 \<in> \<langle>{u\<^sub>0,u\<^sub>1}\<rangle>\<close> hull_concat_lists0 by blast
+  obtain ws1 where "ws1 \<in> lists {u\<^sub>0,u\<^sub>1}" and "concat ws1 = w1"
+    using \<open>w1 \<in> \<langle>{u\<^sub>0,u\<^sub>1}\<rangle>\<close> hull_concat_lists0 by blast
+  from bin_code_lcp_marked[of "[u\<^sub>0] \<cdot> ws0" "[u\<^sub>1] \<cdot> ws1"]
+  have "u\<^sub>0 \<cdot> w0 \<cdot> \<alpha> \<and>\<^sub>p u\<^sub>1 \<cdot> w1 \<cdot> \<alpha> = \<alpha>"
+    using \<open>ws0 \<in> lists {u\<^sub>0,u\<^sub>1}\<close> \<open>ws1 \<in> lists {u\<^sub>0,u\<^sub>1}\<close> \<open>concat ws0 = w0\<close> \<open>concat ws1 = w1\<close> 
+    bin_code_neq by auto
+  with lcp_pref_ext[OF contr]
+  have "u\<^sub>0 \<cdot> p \<le>p \<alpha>"
+    using append_assoc  lq_pref[OF \<open>p \<le>p w0\<close>]  by metis
+  thus False
+    using \<open>\<^bold>|\<alpha>\<^bold>| < \<^bold>|u\<^sub>0 \<cdot> p\<^bold>|\<close> unfolding prefix_def  by fastforce
+qed
+
+lemma bin_code_rev: "binary_code (rev u\<^sub>0) (rev u\<^sub>1)"  
+  by (unfold_locales, unfold comm_rev_iff, simp add: non_comm)
+
+lemma bin_mismatch_pows: "\<not> u\<^sub>0\<^sup>@Suc k \<cdot> u\<^sub>1 \<cdot> z = u\<^sub>1\<^sup>@Suc l \<cdot> u\<^sub>0 \<cdot> z'"
+proof (rule notI)
+  assume eq: "u\<^sub>0 \<^sup>@ Suc k \<cdot> u\<^sub>1 \<cdot> z = u\<^sub>1 \<^sup>@ Suc l \<cdot> u\<^sub>0 \<cdot> z'"
+  have pref1: "\<alpha> \<cdot> [c\<^sub>0] \<le>p u\<^sub>0\<^sup>@Suc k \<cdot> u\<^sub>1" and pref2: "\<alpha> \<cdot> [c\<^sub>1] \<le>p u\<^sub>1\<^sup>@Suc l \<cdot> u\<^sub>0"
+    using bin_lcp_fst_pow_pref[of k \<epsilon>, unfolded clean_emp] bin_lcp_snd_pow_pref[of l \<epsilon>, unfolded clean_emp].
+  from ruler[OF pref_ext[OF pref1, unfolded rassoc, of z, unfolded eq] pref_ext[OF pref2, unfolded rassoc, of z', unfolded eq]] bin_mismatch_neq  
+  show False by simp
+qed
+
+lemma bin_lcp_pows_lcp: "u\<^sub>0\<^sup>@Suc k \<cdot> u\<^sub>1\<^sup>@Suc l \<and>\<^sub>p u\<^sub>1\<^sup>@Suc l \<cdot> u\<^sub>0\<^sup>@Suc k = u\<^sub>0 \<cdot> u\<^sub>1 \<and>\<^sub>p u\<^sub>1 \<cdot> u\<^sub>0"
+  using bin_lcp_def bin_lcp_pows by auto
+
+lemma bin_mismatch: "u\<^sub>0 \<cdot> \<alpha> \<and>\<^sub>p u\<^sub>1 \<cdot> \<alpha> = \<alpha>" 
+  using lcp_first_mismatch_pref[OF bin_fst_mismatch bin_snd_mismatch bin_mismatch_neq].  
+
+lemma not_comp_bin_fst_snd: "\<not> u\<^sub>0 \<cdot> \<alpha> \<bowtie> u\<^sub>1 \<cdot>  \<alpha>"
+  using prefs_comp_comp[OF bin_fst_mismatch bin_snd_mismatch] bin_mismatch_neq
+  unfolding prefix_comparable_def pref_cancel_conv by force
+
+
+theorem bin_bounded_delay: assumes "z \<le>p u\<^sub>0 \<cdot> w\<^sub>0" and "z \<le>p u\<^sub>1 \<cdot> w\<^sub>1" 
+            and "w\<^sub>0 \<in> \<langle>{u\<^sub>0,u\<^sub>1}\<rangle>" and "w\<^sub>1 \<in> \<langle>{u\<^sub>0,u\<^sub>1}\<rangle>"
+          shows "\<^bold>|z\<^bold>| \<le> \<^bold>|\<alpha>\<^bold>|"  
+proof (rule leI, rule notI)
+  assume "\<^bold>|\<alpha>\<^bold>| < \<^bold>|z\<^bold>|"
+  hence "\<^bold>|\<alpha> \<cdot> [a]\<^bold>| \<le> \<^bold>|z\<^bold>|" for a 
+    unfolding lenmorph sing_len by simp
+  have "z \<le>p u\<^sub>0 \<cdot> w\<^sub>0 \<cdot> \<alpha>" and "z \<le>p u\<^sub>1 \<cdot> w\<^sub>1 \<cdot> \<alpha>"
+    using  pref_prolong[OF \<open>z \<le>p u\<^sub>0 \<cdot> w\<^sub>0\<close> triv_pref] pref_prolong[OF \<open>z \<le>p u\<^sub>1 \<cdot> w\<^sub>1\<close> triv_pref].
+  have "\<alpha> \<cdot> [c\<^sub>0] \<le>p u\<^sub>0 \<cdot> w\<^sub>0 \<cdot> \<alpha>" and "\<alpha> \<cdot> [c\<^sub>1] \<le>p u\<^sub>1 \<cdot> w\<^sub>1 \<cdot> \<alpha>"
+     using bin_fst_mismatch_all_hull[OF \<open>w\<^sub>0 \<in> \<langle>{u\<^sub>0,u\<^sub>1}\<rangle>\<close>] bin_snd_mismatch_all_hull[OF \<open>w\<^sub>1 \<in> \<langle>{u\<^sub>0,u\<^sub>1}\<rangle>\<close>].
+   from \<open>z \<le>p u\<^sub>0 \<cdot> w\<^sub>0 \<cdot> \<alpha>\<close> \<open>\<alpha> \<cdot> [c\<^sub>0] \<le>p u\<^sub>0 \<cdot> w\<^sub>0 \<cdot> \<alpha>\<close> \<open>\<^bold>|\<alpha> \<cdot> [c\<^sub>0]\<^bold>| \<le> \<^bold>|z\<^bold>|\<close>  
+   have "\<alpha> \<cdot> [c\<^sub>0] \<le>p z"
+     using prefix_length_prefix by blast 
+   from \<open>z \<le>p u\<^sub>1 \<cdot> w\<^sub>1 \<cdot> \<alpha>\<close> \<open>\<alpha> \<cdot> [c\<^sub>1] \<le>p u\<^sub>1 \<cdot> w\<^sub>1 \<cdot> \<alpha>\<close> \<open>\<^bold>|\<alpha> \<cdot> [c\<^sub>1]\<^bold>| \<le> \<^bold>|z\<^bold>|\<close>  
+   have "\<alpha> \<cdot> [c\<^sub>1] \<le>p z"
+     using prefix_length_prefix by blast 
+   from \<open>\<alpha> \<cdot> [c\<^sub>1] \<le>p z\<close> \<open>\<alpha> \<cdot> [c\<^sub>0] \<le>p z\<close> bin_mismatch_neq
+   show False 
+     unfolding prefix_def by force
+qed  
+
+no_notation bin_code_lcp ("\<alpha>") and
+         (* bin_code_lcs ("\<beta>") and *)
+         (* bin_code_lcp' ("\<alpha>\<^sub>s") and *)
+         (* bin_code_lcs' ("\<beta>") and *)
+            bin_code_mismatch_fst ("c\<^sub>0") and
+            bin_code_mismatch_snd ("c\<^sub>1") 
+         (* bin_code_mismatch_suf_fst ("d\<^sub>0") and *)
+         (* bin_code_mismatch_suf_snd ("d\<^sub>1") *)
+
+end (*binary_code*)
 
 lemmas no_comm_bin_code = binary_code.bin_code[unfolded binary_code_def]
 
 theorem bin_code_code: assumes "u \<cdot> v \<noteq> v \<cdot> u" shows "code {u, v}"
-  unfolding code_def using no_comm_bin_code[OF assms] by blast
+  unfolding code_def using no_comm_bin_code[OF assms] by blast 
 
+lemma code_bin_code: "u \<noteq> v \<Longrightarrow> code {u,v} \<Longrightarrow> u \<cdot> v \<noteq> v \<cdot> u" 
+  by (elim code.code_not_comm) simp_all
+
+lemma lcp_roots_lcp: assumes "x \<cdot> y \<noteq> y \<cdot> x" shows "x \<cdot> y \<and>\<^sub>p y \<cdot> x = \<rho> x \<cdot> \<rho> y \<and>\<^sub>p \<rho> y \<cdot> \<rho> x"
+proof-
+  obtain k where "\<rho> x\<^sup>@Suc k = x"
+    using assms primroot_expE by auto
+  obtain m where "\<rho> y\<^sup>@Suc m = y"
+    using assms primroot_expE by auto
+  have "\<rho> x \<cdot> \<rho> y \<noteq> \<rho> y \<cdot> \<rho> x"
+    using assms comp_primroot_conv' by blast 
+  then interpret binary_code "\<rho> x" "\<rho> y" by unfold_locales
+  from bin_lcp_pows_lcp[of k m, unfolded \<open>\<rho> y\<^sup>@Suc m = y\<close> \<open>\<rho> x\<^sup>@Suc k = x\<close>]
+  show ?thesis.
+qed
+
+subsection \<open>Binary Mismatch tools\<close>
+
+thm binary_code.bin_mismatch_pows[unfolded binary_code_def]
+
+lemma bin_mismatch: "u\<^sup>@Suc k \<cdot> v \<cdot> z = v\<^sup>@Suc l \<cdot> u \<cdot> z' \<Longrightarrow> u \<cdot> v = v \<cdot> u"
+  using binary_code.bin_mismatch_pows[unfolded binary_code_def] by blast
+
+definition bin_mismatch_pref :: "'a list \<Rightarrow> 'a list \<Rightarrow> 'a list  \<Rightarrow> bool" where
+  "bin_mismatch_pref x y w \<equiv> \<exists> k. x\<^sup>@k \<cdot> y \<le>p w"
+
+\<comment> \<open>Binary mismatch elims\<close>
+
+lemma bm_pref_letter: assumes "x \<cdot> y \<noteq> y \<cdot> x" and "bin_mismatch_pref x y (w1 \<cdot> y)" 
+  shows "bin_lcp x y \<cdot> [bin_mismatch x y] \<le>p x \<cdot> w1 \<cdot> bin_lcp x y"
+proof-
+  interpret binary_code x y
+    using assms(1) by unfold_locales
+  from assms[unfolded bin_mismatch_pref_def prefix_def rassoc]
+  obtain k1 z1 where eq1: "w1 \<cdot> y = x\<^sup>@k1 \<cdot> y \<cdot> z1"
+    by blast
+  have "bin_lcp x y \<cdot> [bin_mismatch x y] \<le>p x \<cdot> w1 \<cdot> y \<cdot> bin_lcp x y"
+    unfolding lassoc \<open>w1 \<cdot> y = x\<^sup>@k1 \<cdot> y \<cdot> z1\<close> pow_Suc[symmetric] unfolding rassoc using bin_lcp_fst_pow_pref. 
+  have "\<^bold>|bin_lcp x y \<cdot> [bin_mismatch x y]\<^bold>| \<le> \<^bold>|(x \<cdot> w1) \<cdot> bin_lcp x y\<^bold>|"
+    unfolding lenmorph sing_len using nemp_len[OF bin_fst_nemp] by linarith
+  from ruler_le[OF \<open>bin_lcp x y \<cdot> [bin_mismatch x y] \<le>p x \<cdot> w1 \<cdot> y \<cdot> bin_lcp x y\<close> _ this]
+  show "bin_code_lcp \<cdot> [bin_mismatch x y] \<le>p x \<cdot> w1 \<cdot> bin_code_lcp"
+    unfolding shifts using bin_lcp_snd_lcp.
+qed
+
+lemma bm_eq_hard: assumes "x \<cdot> w1 = y \<cdot> w2" and  "bin_mismatch_pref x y (w1 \<cdot> y)" and "bin_mismatch_pref y x (w2 \<cdot> x)"
+  shows "x \<cdot> y = y \<cdot> x"
+proof(rule classical)
+  assume "x \<cdot> y \<noteq> y \<cdot> x"
+  note bm_pref_letter[OF this assms(2)] bm_pref_letter[OF this[symmetric] assms(3)]
+  from ruler_eq_len[OF this[unfolded lassoc \<open>x\<cdot>w1 = y\<cdot>w2\<close> bin_lcp_sym[of y]]]
+  have "bin_mismatch x y = bin_mismatch y x"
+    unfolding lenmorph sing_len cancel by blast
+  thus "x \<cdot> y = y \<cdot> x"
+    unfolding  bin_mismatch_comm. 
+qed    
+
+lemma bm_pref_hard: assumes "x \<cdot> w1 \<le>p y \<cdot> w2" and  "bin_mismatch_pref x y w1"
+  and "bin_mismatch_pref y x (w2 \<cdot> x)"
+shows "x \<cdot> y = y \<cdot> x"
+proof(rule classical)
+  assume "x \<cdot> y \<noteq> y \<cdot> x"
+  then interpret binary_code x y
+    by unfold_locales
+  from assms[unfolded bin_mismatch_pref_def prefix_def rassoc]
+  obtain k1 z1 where eq1: "w1 = x\<^sup>@k1 \<cdot> y \<cdot> z1"
+    by blast
+  have "bin_lcp x y \<cdot> [bin_mismatch x y] \<le>p x \<cdot> w1"
+    unfolding lassoc \<open>w1 = x\<^sup>@k1 \<cdot> y \<cdot> z1\<close> pow_Suc[symmetric] unfolding rassoc using bin_lcp_fst_pow_pref. 
+  note pref_ext[OF pref_trans[OF this assms(1)], unfolded rassoc] bm_pref_letter[OF \<open>x \<cdot> y \<noteq> y \<cdot> x\<close>[symmetric] assms(3), unfolded bin_lcp_sym[of y]] 
+  from ruler_eq_len[OF this]
+  have "bin_mismatch x y = bin_mismatch y x"  
+    unfolding lenmorph sing_len cancel by blast
+  thus "x \<cdot> y = y \<cdot> x"
+   unfolding  bin_mismatch_comm. 
+qed    
+
+lemmas bm_elims = bm_eq_hard  bm_eq_hard[symmetric] bm_pref_hard bm_pref_hard[symmetric]
+
+lemmas bm_elims_rev = bm_elims[reversed]
+
+\<comment> \<open>Binary mismatch predicate evaluation\<close>
+named_theorems bm_simps
+lemma [bm_simps]: " bin_mismatch_pref x y (y \<cdot> v)"
+  unfolding bin_mismatch_pref_def using  append_Nil pow_zero[of x] by fast
+lemma [bm_simps]: " bin_mismatch_pref x y y"
+  unfolding bin_mismatch_pref_def using  append_Nil pow_zero[of x] self_pref by metis
+lemma [bm_simps]:
+ "w1 \<in> \<langle>{x,y}\<rangle> \<Longrightarrow> bin_mismatch_pref x y w \<Longrightarrow> bin_mismatch_pref x y (w1 \<cdot> w)"
+  unfolding bin_mismatch_pref_def
+proof (induct w1 arbitrary: w rule: hull.induct[of _ "{x,y}"], simp)
+  case (prod_cl w1 w2)
+  from prod_cl.hyps(3)[OF prod_cl.prems] 
+  obtain k s where "w2 \<cdot> w = x \<^sup>@ k \<cdot> y \<cdot> s" by (auto simp add: prefix_def)
+  consider "w1 = x" | "w1 = y" using \<open>w1 \<in> {x,y}\<close> by blast
+  then show ?case 
+  proof (cases)
+    assume "w1 = x"
+    show ?thesis
+      unfolding rassoc \<open>w2 \<cdot> w = x \<^sup>@ k \<cdot> y \<cdot> s\<close> \<open>w1 = x\<close>
+      unfolding lassoc pow_Suc[symmetric] unfolding rassoc
+      using same_prefix_prefix by blast
+  next
+    assume "w1 = y"
+    have "x\<^sup>@0 \<cdot> y \<le>p y \<cdot> w2 \<cdot> w" by auto
+    thus ?thesis
+      unfolding rassoc \<open>w1 = y\<close> by blast 
+  qed
+qed
+
+lemmas bm_simps_rev = bm_simps[reversed]
+
+\<comment> \<open>Binary hull membership evaluation\<close>
+
+named_theorems bin_hull_in 
+lemma[bin_hull_in]: "x \<in> \<langle>{x,y}\<rangle>"
+  by blast
+lemma[bin_hull_in]: "y \<in> \<langle>{x,y}\<rangle>"
+  by blast
+lemma[bin_hull_in]: "w \<in> \<langle>{x,y}\<rangle> \<longleftrightarrow> w \<in> \<langle>{y,x}\<rangle>"
+  by (simp add: insert_commute) 
+lemmas[bin_hull_in] = hull_closed power_in rassoc
+
+lemmas bin_hull_in_rev =  bin_hull_in[reversed]
+
+method mismatch0 =
+    ((simp only: shifts)?, 
+     (elim bm_elims)?; 
+     (simp_all only: bm_simps bin_hull_in))
+
+
+method mismatch_rev =
+     ((simp only: shifts_rev)?, 
+     (elim bm_elims_rev)?; 
+     (simp_all only: bm_simps_rev bin_hull_in_rev))
+
+method mismatch = 
+    (insert method_facts, use nothing in
+    \<open>(mismatch0; fail)| mismatch_rev\<close>)
+
+subsubsection "Mismatch method demonstrations"
+
+lemma "y \<cdot> x \<le>p x\<^sup>@k \<cdot> x \<cdot> y \<cdot> w \<Longrightarrow> x \<cdot> y = y \<cdot> x"
+  by mismatch
+
+(* test hull *)
+lemma "w1 \<in> \<langle>{x,y}\<rangle> \<Longrightarrow> w2 \<in> \<langle>{x,y}\<rangle> \<Longrightarrow> x \<cdot> w2 \<cdot> y \<cdot> z = y \<cdot> w1 \<cdot> x \<cdot> v \<Longrightarrow> x \<cdot> y = y \<cdot> x"
+  by mismatch 
+
+thm bm_elims[elim_format]
+
+(* test simple eq *)
+lemma "w1 \<in> \<langle>{x,y}\<rangle> \<Longrightarrow> y \<cdot> x \<cdot> w2 \<cdot> z = x \<cdot> w1 \<Longrightarrow> x \<cdot> y = y \<cdot> x"
+  (* apply (elim bm_elims) *)   
+  by mismatch
+
+(* test hull' *)
+lemma "w1 \<in> \<langle>{x,y}\<rangle> \<Longrightarrow> w2 \<in> \<langle>{x,y}\<rangle> \<Longrightarrow> x \<cdot> y \<cdot> w2 \<cdot> x \<le>s x \<cdot> w1 \<cdot> y \<Longrightarrow> x \<cdot> y = y \<cdot> x"
+  by mismatch
+
+(* test eq *)
+lemma assumes "x \<cdot> y \<cdot> z = y \<cdot> y \<cdot> x \<cdot> v" shows "x \<cdot> y = y \<cdot> x"
+  using assms by mismatch
+
+(* test eq_cancel *)
+lemma assumes "y \<cdot> x \<cdot> x \<cdot> y \<cdot> z = y \<cdot> x \<cdot> y \<cdot> y \<cdot> x \<cdot> v" shows "x \<cdot> y = y \<cdot> x"
+  using assms by mismatch
+
+(* test eq_swap *)
+lemma "y \<cdot> y \<cdot> x \<cdot> v = x \<cdot> x \<cdot> y \<cdot> z \<Longrightarrow> x \<cdot> y = y \<cdot> x"
+  by mismatch
+
+(* test eq' *)
+lemma "x \<cdot> x \<cdot> y \<cdot> z = y \<cdot> y \<cdot> x \<cdot> z' \<Longrightarrow> x \<cdot> y = y \<cdot> x"
+  by mismatch
+
+(* test eq_suf *)
+lemma "z \<cdot> x \<cdot> y \<cdot> x \<cdot> x  = v \<cdot> x \<cdot> y \<cdot> y \<Longrightarrow> y \<cdot> x = x \<cdot> y"
+  by mismatch
+
+(* test pref *)
+lemma "x \<cdot> y \<le>p y \<cdot> y \<cdot> x \<Longrightarrow> x \<cdot> y = y \<cdot> x"
+  by mismatch
+
+(* test pref_cancel *)
+lemma "y \<cdot> x \<cdot> x \<cdot> x \<cdot> y \<le>p y \<cdot> x \<cdot> x \<cdot> y \<cdot> y \<cdot> x \<Longrightarrow> x \<cdot> y = y \<cdot> x"
+  by mismatch
+
+(* test pref_swap *)
+lemma "x \<cdot> y \<le>p y \<cdot> y \<cdot> x \<cdot> z \<Longrightarrow> y \<cdot> x = x \<cdot> y"
+  by mismatch
+
+(* test suf *)
+lemma "x \<cdot> x \<cdot> y \<cdot> y \<cdot> y \<le>s z\<cdot> y \<cdot> y \<cdot> x \<cdot> x \<Longrightarrow> x \<cdot> y = y \<cdot> x"
+  by mismatch
+
+lemma assumes "x \<cdot> x \<cdot> y \<cdot> y \<cdot> y \<cdot> y \<le>s z\<cdot> y \<cdot> y \<cdot> x \<cdot> x" shows "x \<cdot> y = y \<cdot> x"
+  using assms by mismatch  
+
+(* test power *)
+lemma "k \<noteq> 0 \<Longrightarrow> j \<noteq> 0 \<Longrightarrow> (x \<^sup>@ j \<cdot> y \<^sup>@ ka) \<cdot> y = y\<^sup>@k \<cdot> x \<^sup>@ j \<cdot> y \<^sup>@ (k - 1) \<Longrightarrow> x \<cdot> y = y \<cdot> x"
+  by mismatch
+
+lemma "dif \<noteq> 0 \<Longrightarrow> j \<noteq> 0 \<Longrightarrow> (x \<^sup>@ j \<cdot> y \<^sup>@ ka) \<cdot> y \<^sup>@ dif = y \<^sup>@ dif \<cdot> x \<^sup>@ j \<cdot> y \<^sup>@ ka \<Longrightarrow> x \<cdot> y = y \<cdot> x"
+  by mismatch
+
+subsection \<open>Applied mismatch\<close>
+
+lemma pows_eq_comm: "u\<^sup>@Suc k \<cdot> v\<^sup>@Suc m = u\<^sup>@Suc l \<cdot> v\<^sup>@Suc n \<Longrightarrow> k \<noteq> l \<Longrightarrow> u \<cdot> v = v \<cdot> u"
+  by (induct k l rule: diff_induct, mismatch+)
+
+section \<open>Two words hull (not necessarily a code)\<close>
+
+lemma bin_lists_len_count: assumes "x \<noteq> y" and "ws \<in> lists {x,y}" shows
+  "count_list ws x + count_list ws y = \<^bold>|ws\<^bold>|"
+proof-
+  have "finite {x,y}" by simp
+  have "set ws \<subseteq> {x,y}" using \<open>ws \<in> lists{x,y}\<close> by blast
+  show ?thesis
+    using sum_count_set[OF \<open>set ws \<subseteq> {x,y}\<close> \<open>finite {x,y}\<close>] \<open>x \<noteq> y\<close> by simp
+qed
+
+lemma two_elem_first_block: assumes "w \<in> \<langle>{u,v}\<rangle>"
+  obtains m where "u\<^sup>@m \<cdot> v \<bowtie> w" 
+  using assms
+proof-
+  obtain ws where "concat ws = w" and "ws \<in> lists {u,v}"
+    using concat_dec[OF \<open>w \<in> \<langle>{u,v}\<rangle>\<close>] dec_in_lists[OF \<open>w \<in> \<langle>{u,v}\<rangle>\<close>] by simp
+  consider (only_u) "takeWhile (\<lambda> x. x = u) ws = ws" | (some_v) "takeWhile (\<lambda> x. x = u) ws \<noteq> ws \<and> hd (dropWhile (\<lambda> x. x = u) ws) \<noteq> u"
+    using hd_dropWhile[of "(\<lambda> x. x = u)" ws] by auto
+  then show thesis
+  proof (cases)
+    case only_u
+    hence "ws = [u]\<^sup>@\<^bold>|ws\<^bold>|"
+      unfolding takeWhile_sing_pow by metis
+    hence "w = u\<^sup>@\<^bold>|ws\<^bold>|"
+      using \<open>concat ws = w\<close> concat_sing_pow by metis
+    then show thesis
+      using that by blast
+  next
+    case some_v
+    note some_v = conjunct1[OF this] conjunct2[OF this] 
+    hence "dropWhile (\<lambda> x. x = u) ws \<noteq> \<epsilon>" by force
+    from lists_hd_in_set[OF this]
+    have "hd (dropWhile (\<lambda>x. x = u) ws) \<in> {u,v}"
+      using \<open>ws \<in> lists {u,v}\<close> append_in_lists_conv  takeWhile_dropWhile_id by metis 
+    hence "hd (dropWhile (\<lambda>x. x = u) ws) = v"
+      using some_v(2) by simp
+    from dropWhile_distinct[of ws u, unfolded this] some_v(1)
+    have "(takeWhile (\<lambda>x. x = u) ws)\<cdot>[v] \<le>p ws"
+      unfolding takeWhile_letter_pref_exp by simp
+    from pref_concat_pref[OF this, unfolded concat_morph, unfolded \<open>concat ws = w\<close> concat_takeWhile_sing[unfolded this]] 
+    have "u\<^sup>@\<^bold>|takeWhile (\<lambda>x. x = u) ws\<^bold>|\<cdot> v \<le>p w" 
+      by simp
+    with that
+    show thesis 
+      by blast
+  qed
+qed
+
+lemmas two_elem_last_block = two_elem_first_block[reversed]
+
+lemma two_elem_pref: assumes  "v \<le>p u \<cdot> p" and "p \<in> \<langle>{u,v}\<rangle>"
+  shows "v \<le>p u \<cdot> v"
+proof-
+  obtain m where "u\<^sup>@m \<cdot> v \<bowtie> p"
+    using two_elem_first_block[OF \<open>p \<in> \<langle>{u,v}\<rangle>\<close>]. 
+  have "v \<le>p u\<^sup>@(Suc m) \<cdot> v"
+    using pref_prolong_comp[OF \<open>v \<le>p u \<cdot> p\<close> \<open>u\<^sup>@m \<cdot> v \<bowtie> p\<close>, unfolded lassoc, folded pow_Suc].
+  thus "v \<le>p u \<cdot> v"
+    using per_drop_exp' by blast
+qed
+
+lemmas two_elem_suf = two_elem_pref[reversed]
+
+lemma gen_drop_exp: assumes "p \<in> \<langle>{u,v\<^sup>@(Suc k)}\<rangle>" shows "p \<in> \<langle>{u,v}\<rangle>" 
+  by (rule hull.induct[OF assms], simp, blast)
+
+lemma gen_prim: "v \<noteq> \<epsilon> \<Longrightarrow> p \<in> \<langle>{u,v}\<rangle> \<Longrightarrow> p \<in> \<langle>{u,\<rho> v}\<rangle>"
+  using gen_drop_exp primroot_expE by metis
+
+lemma roots_hull: assumes "w \<in> \<langle>{u\<^sup>@k,v\<^sup>@m}\<rangle>" shows "w \<in> \<langle>{u,v}\<rangle>" 
+proof-
+  have "u\<^sup>@k \<in> \<langle>{u,v}\<rangle>" and "v\<^sup>@m \<in> \<langle>{u,v}\<rangle>"
+    by (simp_all add: gen_in power_in) 
+  hence "{u\<^sup>@k,v\<^sup>@m} \<subseteq> \<langle>{u,v}\<rangle>"
+    by blast
+  from hull_mono'[OF this] 
+  show "w \<in> \<langle>{u,v}\<rangle>"
+    using \<open>w \<in> \<langle>{u\<^sup>@k,v\<^sup>@m}\<rangle>\<close> by blast 
+qed
+
+lemma roots_hull_sub: "\<langle>{u\<^sup>@k,v\<^sup>@m}\<rangle> \<subseteq> \<langle>{u,v}\<rangle>"
+  using roots_hull by blast 
+
+lemma primroot_gen[intro]: "v \<in> \<langle>{u, \<rho> v}\<rangle>" 
+  using power_in[of "\<rho> v" "{u,\<rho> v}"]
+  by (cases "v = \<epsilon>", simp) (metis primroot_expE gen_in insert_iff) 
+
+lemma primroot_gen'[intro]: "u \<in> \<langle>{\<rho> u, v}\<rangle>" 
+  using primroot_gen insert_commute by metis
+
+lemma set_lists_primroot: "set ws \<subseteq> {x,y} \<Longrightarrow> ws \<in> lists \<langle>{\<rho> x, \<rho> y}\<rangle>"
+  by blast
 
 section \<open>Free hull\<close>
 
 text\<open>While not every set $G$ of generators is a code, there is a unique minimal free monoid containing it, called the \emph{free hull} of $G$.
 It can be defined inductively using the property known as the \emph{stability condition}.
 \<close>
 
 inductive_set free_hull :: "'a list set \<Rightarrow> 'a list set" ("\<langle>_\<rangle>\<^sub>F")
   for G where
     "\<epsilon> \<in> \<langle>G\<rangle>\<^sub>F"
   | free_gen_in: "w \<in> G \<Longrightarrow> w \<in> \<langle>G\<rangle>\<^sub>F"
   | "w1 \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> w2 \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> w1 \<cdot> w2 \<in> \<langle>G\<rangle>\<^sub>F"
   | "p \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> q \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> p \<cdot> w \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> w \<cdot> q \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> w \<in> \<langle>G\<rangle>\<^sub>F" \<comment> \<open>the stability condition\<close>
 
 lemmas [intro] = free_hull.intros
 
 text\<open>The defined set indeed is a hull.\<close>
 
-lemma free_hull_hull: "\<langle>\<langle>G\<rangle>\<^sub>F\<rangle> = \<langle>G\<rangle>\<^sub>F"
-proof
-  show "\<langle>G\<rangle>\<^sub>F \<subseteq> \<langle>\<langle>G\<rangle>\<^sub>F\<rangle>"
-    by (simp add: genset_sub)
-  show "\<langle>\<langle>G\<rangle>\<^sub>F\<rangle> \<subseteq> \<langle>G\<rangle>\<^sub>F"
-  proof
-    fix x assume "x \<in> \<langle>\<langle>G\<rangle>\<^sub>F\<rangle>"
-    thus "x \<in> \<langle>G\<rangle>\<^sub>F"
-    proof (rule hull.induct)
-      show " \<epsilon> \<in> \<langle>G\<rangle>\<^sub>F"
-        by (simp add: free_hull.intros(1))
-      show "\<And>w1 w2. w1 \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> w2 \<in> \<langle>\<langle>G\<rangle>\<^sub>F\<rangle> \<Longrightarrow> w2 \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> w1 \<cdot> w2 \<in> \<langle>G\<rangle>\<^sub>F"
-        by (simp add: free_hull.intros(3))
-    qed
-  qed
-qed
+lemma free_hull_hull[simp]: "\<langle>\<langle>G\<rangle>\<^sub>F\<rangle> = \<langle>G\<rangle>\<^sub>F"
+  by (intro antisym subsetI) (rule hull.induct, blast+)
 
 text\<open>The free hull is always (non-strictly) larger than the hull.\<close>
 
-lemma hull_in_free_hull: "\<langle>G\<rangle> \<subseteq> \<langle>G\<rangle>\<^sub>F"
+lemma hull_sub_free_hull: "\<langle>G\<rangle> \<subseteq> \<langle>G\<rangle>\<^sub>F"
 proof
   fix x assume "x \<in> \<langle>G\<rangle>"
-  then show "x \<in> \<langle>G\<rangle>\<^sub>F"
-    using free_hull.intros(3)
+  then show "x \<in> \<langle>G\<rangle>\<^sub>F" 
+    using free_hull.intros(3) 
       hull_induct[of x G "\<lambda> x. x \<in> \<langle>G\<rangle>\<^sub>F", OF \<open>x \<in> \<langle>G\<rangle>\<close> free_hull.intros(1)[of G] free_hull.intros(2)]
     by auto
 qed
 
 text\<open>On the other hand, it can be proved that the \emph{free basis}, defined as the basis of the free hull,  has a (non-strictly) smaller cardinality than the ordinary basis.\<close>
 
 definition free_basis ::  "'a list set \<Rightarrow> 'a list set" ("\<BB>\<^sub>F _" [54] 55)
   where  "free_basis G \<equiv> \<BB> \<langle>G\<rangle>\<^sub>F"
 
 lemma basis_gen_hull_free: "\<langle>\<BB>\<^sub>F G\<rangle> = \<langle>G\<rangle>\<^sub>F"
   unfolding free_basis_def using basis_gen_hull free_hull_hull by blast
 
 lemma genset_sub_free: "G \<subseteq> \<langle>G\<rangle>\<^sub>F"
   by (simp add: free_hull.free_gen_in subsetI)
 
 text
-\<open>We have developed two points of view on freeness:
+\<open>We have developed two points of view on freeness: 
 \<^item> being a free hull, that is, to satisfy the stability condition;
 \<^item> being generated by a code.\<close>
-
+ 
 text\<open>We now show their equivalence\<close>
 
 text\<open>First, basis of a free hull is a code.\<close>
 
-lemma free_basis_code: "code (\<BB>\<^sub>F G)"
+lemma free_basis_code[simp]: "code (\<BB>\<^sub>F G)"
 proof
-  fix xs ys
+  fix xs ys  
   show "xs \<in> lists (\<BB>\<^sub>F G) \<Longrightarrow> ys \<in> lists (\<BB>\<^sub>F G) \<Longrightarrow> concat xs = concat ys \<Longrightarrow> xs = ys"
   proof(induction xs ys rule: list_induct2', simp)
     case (2 x xs)
-    show ?case
-      using listsE[OF \<open>x # xs \<in> lists (\<BB>\<^sub>F G)\<close>, of "x \<in> \<BB>\<^sub>F G", unfolded free_basis_def, THEN emp_not_basis]
-      concat.simps(2)[of x xs, unfolded \<open>concat (x # xs) = concat \<epsilon>\<close>[unfolded concat.simps(1)], symmetric, unfolded append_is_Nil_conv[of x "concat xs"]]
+    show ?case 
+      using listsE[OF \<open>x # xs \<in> lists (\<BB>\<^sub>F G)\<close>, of "x \<in> \<BB>\<^sub>F G", unfolded free_basis_def, THEN emp_not_basis]    
+      concat.simps(2)[of x xs, unfolded \<open>concat (x # xs) = concat \<epsilon>\<close>[unfolded concat.simps(1)], symmetric, unfolded append_is_Nil_conv[of x "concat xs"]] 
       by blast
   next
     case (3 y ys)
-    show ?case
-      using  listsE[OF \<open>y # ys \<in> lists (\<BB>\<^sub>F G)\<close>, of "y \<in> \<BB>\<^sub>F G", unfolded free_basis_def, THEN emp_not_basis]
+    show ?case 
+      using  listsE[OF \<open>y # ys \<in> lists (\<BB>\<^sub>F G)\<close>, of "y \<in> \<BB>\<^sub>F G", unfolded free_basis_def, THEN emp_not_basis]    
       concat.simps(2)[of y ys, unfolded \<open>concat \<epsilon> = concat (y # ys)\<close>[unfolded concat.simps(1),symmetric],symmetric, unfolded append_is_Nil_conv[of y "concat ys"]]
-      by blast
+      by blast 
   next
     case (4 x xs y ys)
     have "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|"
     proof(rule ccontr)
       assume "\<^bold>|x\<^bold>| \<noteq> \<^bold>|y\<^bold>|"
-      have "x \<cdot> concat xs = y \<cdot> concat ys"
+      have "x \<cdot> concat xs = y \<cdot> concat ys" 
         using \<open>concat (x # xs) = concat (y # ys)\<close> by simp
       then obtain t where or: "x = y \<cdot> t \<and> t \<cdot> concat xs = concat ys \<or> x \<cdot> t = y \<and> concat xs = t \<cdot> concat ys"
         using append_eq_append_conv2[of x "concat xs" y "concat ys"]  by blast
       hence "t \<noteq> \<epsilon>"
         using \<open>\<^bold>|x\<^bold>| \<noteq> \<^bold>|y\<^bold>|\<close> by auto
       have "x \<in> \<BB>\<^sub>F G" and "y \<in> \<BB>\<^sub>F G"
         using  listsE[OF \<open>x # xs \<in> lists (\<BB>\<^sub>F G)\<close>, of "x \<in> \<BB>\<^sub>F G" ] listsE[OF \<open>y # ys \<in> lists (\<BB>\<^sub>F G)\<close>, of "y \<in> \<BB>\<^sub>F G" ] by blast+
       hence "x \<noteq> \<epsilon>" and "y \<noteq> \<epsilon>"
         unfolding free_basis_def using emp_not_basis by blast+
       have  "x \<in> \<langle>G\<rangle>\<^sub>F" and "y \<in> \<langle>G\<rangle>\<^sub>F"
-        using basis_sub[of "\<langle>G\<rangle>\<^sub>F", unfolded free_basis_def[symmetric] ] \<open>x # xs \<in> lists (\<BB>\<^sub>F G)\<close>
+        using basis_sub[of "\<langle>G\<rangle>\<^sub>F", unfolded free_basis_def[symmetric] ] \<open>x # xs \<in> lists (\<BB>\<^sub>F G)\<close> 
           \<open>y # ys \<in> lists (\<BB>\<^sub>F G)\<close> by auto
       have "concat xs \<in> \<langle>G\<rangle>\<^sub>F" and "concat ys \<in> \<langle>G\<rangle>\<^sub>F"
-        using concat_tl_basis[OF \<open>x # xs \<in> lists (\<BB>\<^sub>F G)\<close>[unfolded free_basis_def]]
-              concat_tl_basis[OF \<open>y # ys \<in> lists (\<BB>\<^sub>F G)\<close>[unfolded free_basis_def]] unfolding free_hull_hull.
-      have "t \<in> \<langle>G\<rangle>\<^sub>F"
+        using concat_tl_basis[OF \<open>x # xs \<in> lists (\<BB>\<^sub>F G)\<close>[unfolded free_basis_def]] 
+              concat_tl_basis[OF \<open>y # ys \<in> lists (\<BB>\<^sub>F G)\<close>[unfolded free_basis_def]] unfolding free_hull_hull. 
+      have "t \<in> \<langle>G\<rangle>\<^sub>F" 
         using or free_hull.intros(4) \<open>x \<in> \<langle>G\<rangle>\<^sub>F\<close> \<open>y \<in> \<langle>G\<rangle>\<^sub>F\<close> \<open>concat xs \<in> \<langle>G\<rangle>\<^sub>F\<close> \<open>concat ys \<in> \<langle>G\<rangle>\<^sub>F\<close> by metis
       thus False
-        using or basis_dec[of x "\<langle>G\<rangle>\<^sub>F" t, unfolded free_hull_hull, OF \<open>x \<in> \<langle>G\<rangle>\<^sub>F\<close> \<open>t \<in> \<langle>G\<rangle>\<^sub>F\<close>]
-          basis_dec[of y "\<langle>G\<rangle>\<^sub>F" t, unfolded free_hull_hull, OF \<open>y \<in> \<langle>G\<rangle>\<^sub>F\<close> \<open>t \<in> \<langle>G\<rangle>\<^sub>F\<close>]
+        using or basis_dec[of x "\<langle>G\<rangle>\<^sub>F" t, unfolded free_hull_hull, OF \<open>x \<in> \<langle>G\<rangle>\<^sub>F\<close> \<open>t \<in> \<langle>G\<rangle>\<^sub>F\<close>] 
+          basis_dec[of y "\<langle>G\<rangle>\<^sub>F" t, unfolded free_hull_hull, OF \<open>y \<in> \<langle>G\<rangle>\<^sub>F\<close> \<open>t \<in> \<langle>G\<rangle>\<^sub>F\<close>] 
         using  \<open>t \<noteq> \<epsilon>\<close> \<open>x \<noteq> \<epsilon>\<close> \<open>y \<noteq> \<epsilon>\<close> \<open>x \<in> \<BB>\<^sub>F G\<close> \<open>y \<in> \<BB>\<^sub>F G\<close> unfolding free_basis_def
         by auto
     qed
     thus "x # xs = y # ys"
       using "4.IH" \<open>x # xs \<in> lists (\<BB>\<^sub>F G)\<close> \<open>y # ys \<in> lists (\<BB>\<^sub>F G)\<close> \<open>concat (x # xs) = concat (y # ys)\<close>
       by auto
   next
   qed
 qed
 
+lemma gen_in_free_hull: "x \<in> G \<Longrightarrow> x \<in> \<langle>\<BB>\<^sub>F G\<rangle>"
+  using free_hull.free_gen_in[folded basis_gen_hull_free].
+
 text\<open>Second, a code generates its free hull.\<close>
 
-lemma code_gen_free_hull: "code C \<Longrightarrow> \<langle>C\<rangle>\<^sub>F = \<langle>C\<rangle>"
+lemma (in code) code_gen_free_hull: "\<langle>\<C>\<rangle>\<^sub>F = \<langle>\<C>\<rangle>"
 proof
-  assume "code C"
-  show "\<langle>C\<rangle> \<subseteq> \<langle>C\<rangle>\<^sub>F"
-    using hull_mon[of C "\<langle>C\<rangle>\<^sub>F"]
-          free_hull.free_gen_in[of _ C]  subsetI[of C "\<langle>C\<rangle>\<^sub>F"]
-    unfolding free_hull_hull[of C] by auto
-  show "\<langle>C\<rangle>\<^sub>F \<subseteq> \<langle>C\<rangle>"
+  show "\<langle>\<C>\<rangle> \<subseteq> \<langle>\<C>\<rangle>\<^sub>F"
+    using hull_mono[of \<C> "\<langle>\<C>\<rangle>\<^sub>F"] 
+          free_gen_in[of _ \<C>]  subsetI[of \<C> "\<langle>\<C>\<rangle>\<^sub>F"] 
+    unfolding free_hull_hull by auto
+  show "\<langle>\<C>\<rangle>\<^sub>F \<subseteq> \<langle>\<C>\<rangle>"
   proof
-    fix x assume "x \<in> \<langle>C\<rangle>\<^sub>F"
-    have "\<epsilon> \<in> \<langle>C\<rangle>"
-      by (simp add: hull.intros(1))
-    show "x \<in> \<langle>C\<rangle>"
-    proof(rule free_hull.induct[of x C],simp add: \<open>x \<in> \<langle>C\<rangle>\<^sub>F\<close>, (simp add: hull.intros hull_closed)+,
+    fix x assume "x \<in> \<langle>\<C>\<rangle>\<^sub>F" 
+    have "\<epsilon> \<in> \<langle>\<C>\<rangle>"
+      by simp
+    show "x \<in> \<langle>\<C>\<rangle>"
+    proof(rule free_hull.induct[of x \<C>],simp add: \<open>x \<in> \<langle>\<C>\<rangle>\<^sub>F\<close>, (simp add: hull_closed)+, 
         simp add: gen_in, simp add: hull_closed)
-      fix p q w assume "p \<in> \<langle>C\<rangle>" "q \<in> \<langle>C\<rangle>" "p \<cdot> w \<in> \<langle>C\<rangle>" "w \<cdot> q \<in> \<langle>C\<rangle>"
-      have eq: "(Dec C p) \<cdot> (Dec C w \<cdot> q) = (Dec C p \<cdot> w) \<cdot> (Dec C q)"
-        using code.code_dec_morph[OF \<open>code C\<close> \<open>p \<in> \<langle>C\<rangle>\<close> \<open>w \<cdot> q \<in> \<langle>C\<rangle>\<close>, unfolded lassoc]
-        unfolding code.code_dec_morph[OF \<open>code C\<close> \<open>p \<cdot> w \<in> \<langle>C\<rangle>\<close> \<open>q \<in> \<langle>C\<rangle>\<close>, symmetric].
-      have "Dec C p \<bowtie>  Dec C p \<cdot> w"
-        using eqd_comp[OF eq].
-      hence "Dec C p \<le>p  Dec C p \<cdot> w"
-        using \<open>p \<cdot> w \<in> \<langle>C\<rangle>\<close> \<open>p \<in> \<langle>C\<rangle>\<close> concat_morph decI prefD pref_antisym triv_pref
+      fix p q w assume "p \<in> \<langle>\<C>\<rangle>" "q \<in> \<langle>\<C>\<rangle>" "p \<cdot> w \<in> \<langle>\<C>\<rangle>" "w \<cdot> q \<in> \<langle>\<C>\<rangle>"
+      have eq: "(Dec \<C> p) \<cdot> (Dec \<C> w \<cdot> q) = (Dec \<C> p \<cdot> w) \<cdot> (Dec \<C> q)" 
+        using code_dec_morph[OF \<open>p \<in> \<langle>\<C>\<rangle>\<close> \<open>w \<cdot> q \<in> \<langle>\<C>\<rangle>\<close>, unfolded lassoc]  
+        unfolding code_dec_morph[OF \<open>p \<cdot> w \<in> \<langle>\<C>\<rangle>\<close> \<open>q \<in> \<langle>\<C>\<rangle>\<close>, symmetric]. 
+      have "Dec \<C> p \<bowtie>  Dec \<C> p \<cdot> w"
+        using eqd_comp[OF eq]. 
+      hence "Dec \<C> p \<le>p  Dec \<C> p \<cdot> w" 
+        using \<open>p \<cdot> w \<in> \<langle>\<C>\<rangle>\<close> \<open>p \<in> \<langle>\<C>\<rangle>\<close> concat_morph concat_dec prefD pref_antisym triv_pref
         unfolding prefix_comparable_def
         by metis
-      then obtain ts where "(Dec C p) \<cdot> ts =  Dec C p \<cdot> w"
+      then obtain ts where "(Dec \<C> p) \<cdot> ts =  Dec \<C> p \<cdot> w"
         using lq_pref by blast
-      hence  "ts \<in> lists C"
-        using  append_in_lists_conv[of "Dec C p" ts C] dec_dom'[OF \<open>p \<cdot> w \<in> \<langle>C\<rangle>\<close>]
-        unfolding \<open>(Dec C p) \<cdot> ts =  Dec C p \<cdot> w\<close> by blast
+      hence  "ts \<in> lists \<C>"
+        using \<open>p \<cdot> w \<in> \<langle>\<C>\<rangle>\<close> by inlists
       hence "concat ts = w"
-        using  concat_morph[of "Dec C p" ts]
-        unfolding \<open>(Dec C p) \<cdot> ts =  Dec C p \<cdot> w\<close> decI[OF \<open>p \<cdot> w \<in> \<langle>C\<rangle>\<close>]  decI[OF \<open>p \<in> \<langle>C\<rangle>\<close>] by auto
-      thus "w \<in> \<langle>C\<rangle>"
-        using \<open>ts \<in> lists C\<close> by auto
+        using  concat_morph[of "Dec \<C> p" ts]                   
+        unfolding \<open>(Dec \<C> p) \<cdot> ts =  Dec \<C> p \<cdot> w\<close> concat_dec[OF \<open>p \<cdot> w \<in> \<langle>\<C>\<rangle>\<close>]  concat_dec[OF \<open>p \<in> \<langle>\<C>\<rangle>\<close>] by auto
+      thus "w \<in> \<langle>\<C>\<rangle>"
+        using \<open>ts \<in> lists \<C>\<close> by auto
     qed
   qed
 qed
 
 text\<open>That is, a code is its own free basis\<close>
 
-lemma code_free_basis: assumes "code C" shows "C = \<BB>\<^sub>F C"
-  using basis_of_hull[of C, unfolded code_gen_free_hull[OF assms, symmetric]
-      code.code_is_basis[OF assms]]
-  unfolding free_basis_def.
+lemma (in code) code_free_basis: "\<C> = \<BB>\<^sub>F \<C>"
+  using basis_of_hull[of \<C>, unfolded code_gen_free_hull[symmetric] 
+      code_is_basis, symmetric] unfolding free_basis_def.
 
-text\<open>Moreover, the free hull of G is the smallest code-generated hull containing G.
+text\<open>This allows to use the introduction rules of the free hull to prove one of the basic characterizations
+ of the code, called the stability condition\<close>
+
+lemma (in code) stability: "p \<in> \<langle>\<C>\<rangle> \<Longrightarrow> q \<in> \<langle>\<C>\<rangle> \<Longrightarrow> p \<cdot> w \<in> \<langle>\<C>\<rangle> \<Longrightarrow> w \<cdot> q \<in> \<langle>\<C>\<rangle> \<Longrightarrow> w \<in> \<langle>\<C>\<rangle>"
+  unfolding code_gen_free_hull[symmetric] using free_hull.intros(4) by auto  
+
+text\<open>Moreover, the free hull of G is the smallest code-generated hull containing G. 
 In other words, the term free hull is appropriate.\<close>
 
+
+
 text\<open>First, several intuitive monotonicity and closure results.\<close>
 
 lemma free_hull_mono: "G \<subseteq> H \<Longrightarrow> \<langle>G\<rangle>\<^sub>F \<subseteq> \<langle>H\<rangle>\<^sub>F"
 proof
   assume "G \<subseteq> H"
   fix x assume "x \<in> \<langle>G\<rangle>\<^sub>F"
   have el: "\<And> w. w \<in> G \<Longrightarrow> w \<in> \<langle>H\<rangle>\<^sub>F"
     using \<open>G \<subseteq> H\<close> free_hull.free_gen_in by auto
   show "x \<in> \<langle>H\<rangle>\<^sub>F"
-  proof (rule free_hull.induct[of x G], simp add: \<open>x \<in> \<langle>G\<rangle>\<^sub>F\<close>, simp add: free_hull.intros(1),
+  proof (rule free_hull.induct[of x G], simp add: \<open>x \<in> \<langle>G\<rangle>\<^sub>F\<close>, simp add: free_hull.intros(1), 
       simp add: el, simp add: free_hull.intros(3))
     show "\<And>p q w. p \<in> \<langle>H\<rangle>\<^sub>F \<Longrightarrow>  q \<in> \<langle>H\<rangle>\<^sub>F \<Longrightarrow>  p \<cdot> w \<in> \<langle>H\<rangle>\<^sub>F \<Longrightarrow>  w \<cdot> q \<in> \<langle>H\<rangle>\<^sub>F \<Longrightarrow> w \<in> \<langle>H\<rangle>\<^sub>F"
-      using free_hull.intros(4) by auto
+      using free_hull.intros(4) by auto  
   qed
 qed
 
 lemma free_hull_idem: "\<langle>\<langle>G\<rangle>\<^sub>F\<rangle>\<^sub>F = \<langle>G\<rangle>\<^sub>F"
 proof
-  show "\<langle>\<langle>G\<rangle>\<^sub>F\<rangle>\<^sub>F \<subseteq> \<langle>G\<rangle>\<^sub>F"
-  proof
+  show "\<langle>\<langle>G\<rangle>\<^sub>F\<rangle>\<^sub>F \<subseteq> \<langle>G\<rangle>\<^sub>F" 
+  proof 
     fix x assume "x \<in> \<langle>\<langle>G\<rangle>\<^sub>F\<rangle>\<^sub>F"
     show "x \<in> \<langle>G\<rangle>\<^sub>F"
-    proof (rule free_hull.induct[of x "\<langle>G\<rangle>\<^sub>F"], simp add: \<open>x \<in> \<langle>\<langle>G\<rangle>\<^sub>F\<rangle>\<^sub>F\<close>,
+    proof (rule free_hull.induct[of x "\<langle>G\<rangle>\<^sub>F"], simp add: \<open>x \<in> \<langle>\<langle>G\<rangle>\<^sub>F\<rangle>\<^sub>F\<close>, 
         simp add: free_hull.intros(1), simp add: free_hull.intros(2), simp add: free_hull.intros(3))
       show "\<And>p q w. p \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow>  q \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow>  p \<cdot> w \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow>  w \<cdot> q \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> w \<in> \<langle>G\<rangle>\<^sub>F"
-        using free_hull.intros(4) by auto
+        using free_hull.intros(4) by auto  
     qed
   qed
 next
   show "\<langle>G\<rangle>\<^sub>F \<subseteq> \<langle>\<langle>G\<rangle>\<^sub>F\<rangle>\<^sub>F"
-    using free_hull_hull hull_in_free_hull by auto
+    using free_hull_hull hull_sub_free_hull by auto 
 qed
 
 lemma hull_gen_free_hull: "\<langle>\<langle>G\<rangle>\<rangle>\<^sub>F = \<langle>G\<rangle>\<^sub>F"
 proof
   show " \<langle>\<langle>G\<rangle>\<rangle>\<^sub>F \<subseteq> \<langle>G\<rangle>\<^sub>F"
-    using free_hull_idem free_hull_mono hull_in_free_hull by metis
+    using free_hull_idem free_hull_mono hull_sub_free_hull by metis
 next
   show "\<langle>G\<rangle>\<^sub>F \<subseteq> \<langle>\<langle>G\<rangle>\<rangle>\<^sub>F"
-    by (simp add: free_hull_mono genset_sub)
+    by (simp add: free_hull_mono) 
 qed
 
 text \<open>Code is also the free basis of its hull.\<close>
 
-lemma code_free_basis_hull: "code C \<Longrightarrow> C = \<BB>\<^sub>F \<langle>C\<rangle>"
+lemma (in code) code_free_basis_hull: "\<C> = \<BB>\<^sub>F \<langle>\<C>\<rangle>"
   unfolding free_basis_def using code_free_basis[unfolded free_basis_def]
-  unfolding  hull_gen_free_hull.
+  unfolding  hull_gen_free_hull. 
 
 text\<open>The minimality of the free hull easily follows.\<close>
 
-theorem free_hull_min: assumes "code C" and "G \<subseteq> \<langle>C\<rangle>" shows "\<langle>G\<rangle>\<^sub>F \<subseteq> \<langle>C\<rangle>"
-  using free_hull_mono[OF \<open>G \<subseteq> \<langle>C\<rangle>\<close>] unfolding hull_gen_free_hull
-  unfolding code_gen_free_hull[OF \<open>code C\<close>].
+theorem (in code) free_hull_min: assumes "G \<subseteq> \<langle>\<C>\<rangle>" shows "\<langle>G\<rangle>\<^sub>F \<subseteq> \<langle>\<C>\<rangle>"
+  using free_hull_mono[OF \<open>G \<subseteq> \<langle>\<C>\<rangle>\<close>] unfolding hull_gen_free_hull 
+  unfolding code_gen_free_hull.  
 
 theorem free_hull_inter: "\<langle>G\<rangle>\<^sub>F = \<Inter> {M. G \<subseteq> M \<and> M = \<langle>M\<rangle>\<^sub>F}"
 proof
   have "X \<in> {M. G \<subseteq> M \<and> M = \<langle>M\<rangle>\<^sub>F} \<Longrightarrow> \<langle>G\<rangle>\<^sub>F \<subseteq> X" for X
     unfolding mem_Collect_eq[of _ "\<lambda> M. G \<subseteq> M \<and> M = \<langle>M\<rangle>\<^sub>F"]
-    using free_hull_mono[of G X] by simp
-  from Inter_greatest[of "{M. G \<subseteq> M \<and> M = \<langle>M\<rangle>\<^sub>F}", OF this]
-  show "\<langle>G\<rangle>\<^sub>F \<subseteq> \<Inter> {M. G \<subseteq> M \<and> M = \<langle>M\<rangle>\<^sub>F}"
+    using free_hull_mono[of G X] by simp 
+  from Inter_greatest[of "{M. G \<subseteq> M \<and> M = \<langle>M\<rangle>\<^sub>F}", OF this]  
+  show "\<langle>G\<rangle>\<^sub>F \<subseteq> \<Inter> {M. G \<subseteq> M \<and> M = \<langle>M\<rangle>\<^sub>F}" 
     by blast
 next
   show " \<Inter> {M. G \<subseteq> M \<and> M = \<langle>M\<rangle>\<^sub>F} \<subseteq> \<langle>G\<rangle>\<^sub>F"
-    by (simp add: Inter_lower free_hull_idem genset_sub_free)
+    by (simp add: Inter_lower free_hull_idem genset_sub_free) 
 qed
 
 text\<open>Decomposition into the free basis is a morphism.\<close>
 
-lemma free_basis_dec_morph: "u \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> v \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow>
+lemma free_basis_dec_morph: "u \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow> v \<in> \<langle>G\<rangle>\<^sub>F \<Longrightarrow>  
     Dec (\<BB>\<^sub>F G) (u \<cdot> v) = (Dec (\<BB>\<^sub>F G) u) \<cdot> (Dec (\<BB>\<^sub>F G) v)"
-  using code.code_dec_morph[OF free_basis_code, of u G v, symmetric,
+  using code.code_dec_morph[OF free_basis_code, of u G v, symmetric, 
         unfolded  basis_gen_hull_free[of G]].
 
+section \<open>Reversing hulls and decompositions\<close>
+
+lemma basis_rev_commute[reversal_rule]: "\<BB> (rev ` G) = rev ` (\<BB> G)"
+proof
+  have "\<langle>rev ` \<BB> G\<rangle> = \<langle>rev ` G\<rangle>" and *: "\<langle>rev ` \<BB> (rev ` G)\<rangle> = \<langle>rev ` rev `G\<rangle>"
+    unfolding rev_hull[symmetric] basis_gen_hull by blast+
+  from basis_sub_gen[OF this(1)] 
+  show "\<BB> (rev ` G) \<subseteq> rev ` \<BB> G".
+  from image_mono[OF basis_sub_gen[OF *], of rev]
+  show "rev ` (\<BB> G) \<subseteq> \<BB> (rev ` G)"
+    unfolding rev_rev_image_eq.    
+qed
+
+lemma rev_free_hull_comm: "\<langle>rev ` X\<rangle>\<^sub>F = rev ` \<langle>X\<rangle>\<^sub>F"
+proof-
+  have "rev ` \<langle>X\<rangle>\<^sub>F \<subseteq> \<langle>rev ` X\<rangle>\<^sub>F" for X :: "'a list set"
+  proof
+    fix x assume "x \<in> rev ` \<langle>X\<rangle>\<^sub>F"
+    hence  "rev x \<in> \<langle>X\<rangle>\<^sub>F"
+      by (simp add: rev_in_conv) 
+    have "rev x \<in> rev ` \<langle>rev ` X\<rangle>\<^sub>F" 
+      by (induct rule: free_hull.induct[OF \<open>rev x \<in> \<langle>X\<rangle>\<^sub>F\<close>], blast, unfold rev_in_conv[symmetric] rev_append, auto+)
+    then show "x \<in> \<langle>rev ` X\<rangle>\<^sub>F"
+      by blast 
+  qed
+  from this
+    image_mono[OF this[of "rev ` X", unfolded rev_rev_image_eq], of rev, unfolded rev_rev_image_eq]
+  show  "\<langle>rev ` X\<rangle>\<^sub>F = rev ` \<langle>X\<rangle>\<^sub>F" 
+    by blast
+qed
+
+lemma free_basis_rev_commute [reversal_rule]: "\<BB>\<^sub>F rev ` X =  rev ` (\<BB>\<^sub>F X)"
+  unfolding free_basis_def basis_rev_commute free_basis_def rev_free_hull_comm..
+
+lemma rev_dec[reversal_rule]: assumes "x \<in> \<langle>X\<rangle>\<^sub>F" shows "Dec rev ` (\<BB>\<^sub>F X) (rev x) = map rev (rev (Dec (\<BB>\<^sub>F X) x))"
+proof-
+  have "x \<in> \<langle>\<BB>\<^sub>F X\<rangle>"
+    using \<open>x \<in> \<langle>X\<rangle>\<^sub>F\<close> by (simp add: basis_gen_hull_free)
+  from concat_dec[OF this]
+  have "concat (map rev (rev (Dec \<BB>\<^sub>F X x))) = rev x"
+    unfolding rev_concat[symmetric] by blast
+  from  rev_image_eqI[OF rev_in_lists[OF dec_in_lists[OF \<open>x \<in> \<langle>\<BB>\<^sub>F X\<rangle>\<close>]], of _ "map rev"]
+  have "map rev (rev (Dec \<BB>\<^sub>F X x)) \<in> lists (rev ` (\<BB>\<^sub>F X))"
+    unfolding lists_image by blast
+  from code.code_unique_dec'[OF code.code_rev_code[OF free_basis_code] this]
+  show ?thesis
+    unfolding \<open>concat (map rev (rev (Dec \<BB>\<^sub>F X x))) = rev x\<close>.
+qed
+
+lemma rev_hd_dec_last_eq[reversal_rule]: assumes "x \<in> X" and  "x \<noteq> \<epsilon>" shows
+  "rev (hd (Dec (rev ` (\<BB>\<^sub>F X)) (rev x))) = last (Dec \<BB>\<^sub>F X x)" 
+proof-
+  have "rev (Dec \<BB>\<^sub>F X x) \<noteq> \<epsilon>"
+    using \<open>x \<in> X\<close> basis_gen_hull_free dec_nemp'[OF \<open>x \<noteq> \<epsilon>\<close>] by blast
+  show ?thesis
+    unfolding hd_rev rev_dec[OF free_gen_in[OF \<open>x \<in> X\<close>]] hd_map[OF \<open>rev (Dec \<BB>\<^sub>F X x) \<noteq> \<epsilon>\<close>]
+    by simp 
+qed
+
+lemma rev_hd_dec_last_eq'[reversal_rule]: assumes "x \<in> X" and  "x \<noteq> \<epsilon>" shows 
+  "(hd (Dec (rev ` (\<BB>\<^sub>F X)) (rev x))) = rev (last (Dec \<BB>\<^sub>F X x))"
+  using assms(1) assms(2) rev_hd_dec_last_eq rev_swap by blast 
+
 section \<open>Lists as the free hull of singletons\<close>
 
-text\<open>A crucial property of free monoids of words is that they can be seen as lists over the free basis,
+text\<open>A crucial property of free monoids of words is that they can be seen as lists over the free basis, 
 instead as lists over the original alphabet.\<close>
 
 abbreviation sings where "sings B \<equiv> {[b] | b. b \<in> B}"
 
-lemma sings_image: "sings B =  (\<lambda> x. [x]) ` B"
+lemma sings_image: "sings B =  (\<lambda> x. [x]) ` B" 
   using Setcompr_eq_image.
 
-lemma lists_sing_map_concat_ident: "xs \<in> lists (sings B) \<Longrightarrow> xs = map (\<lambda> x. [x]) (concat xs)"
+lemma lists_sing_map_concat_ident: "xs \<in> lists (sings B) \<Longrightarrow> xs = map (\<lambda> x. [x]) (concat xs)" 
   by (induct xs, simp, auto)
 
 lemma code_sings: "code (sings B)"
 proof
-  fix xs ys assume xs: "xs \<in> lists (sings B)" and ys: "ys \<in> lists (sings B)"
-     and eq: "concat xs = concat ys"
+  fix xs ys assume xs: "xs \<in> lists (sings B)" and ys: "ys \<in> lists (sings B)" 
+     and eq: "concat xs = concat ys" 
   from lists_sing_map_concat_ident[OF xs, unfolded eq]
   show "xs = ys" unfolding  lists_sing_map_concat_ident[OF ys, symmetric].
 qed
 
 lemma sings_gen_lists: "\<langle>sings B\<rangle> = lists B"
   unfolding hull_concat_lists
 proof(intro equalityI subsetI, standard)
   fix xs
   show "xs \<in> concat ` lists (sings B) \<Longrightarrow> \<forall>x\<in>set xs. x \<in> B"
-    by force
+    by force 
   assume "xs \<in> lists B"
   hence "map (\<lambda>x. x # \<epsilon>) xs \<in> lists (sings B)"
     by force
-  from imageI[OF this, of concat]
+  from imageI[OF this, of concat] 
   show "xs \<in> concat ` lists (sings B)"
-    unfolding concat_map_sing_ident[of xs].
-qed
+    unfolding concat_map_sing_ident[of xs]. 
+qed    
+
+lemma sing_gen_lists: "lists {x} = \<langle>{[x]}\<rangle>"  
+  using sings_gen_lists[of "{x}"] by simp
+
+lemma bin_gen_lists: "lists {x, y} = \<langle>{[x],[y]}\<rangle>" 
+  using sings_gen_lists[of "{x,y}"] unfolding Setcompr_eq_image by simp
 
 lemma "sings B = \<BB>\<^sub>F (lists B)"
-  using code_free_basis_hull[OF code_sings, of B, unfolded sings_gen_lists].
+  using code.code_free_basis_hull[OF code_sings, of B, unfolded sings_gen_lists].
 
 lemma map_sings: "xs \<in> lists B \<Longrightarrow> map (\<lambda>x. x # \<epsilon>) xs \<in> lists (sings B)"
   by (induct xs) auto
 
 lemma dec_sings: "xs \<in> lists B \<Longrightarrow> Dec (sings B) xs = map (\<lambda> x. [x]) xs"
-  using code.code_unique_dec[OF code_sings, of "map (\<lambda> x. [x]) xs" B, OF map_sings]
+  using code.code_unique_dec'[OF code_sings, of "map (\<lambda> x. [x]) xs" B, OF map_sings]
   unfolding concat_map_sing_ident.
 
+lemma sing_lists_exp: assumes "ws \<in> lists {x}"
+  obtains k where "ws = [x]\<^sup>@k"
+  using  unique_letter_wordE''[OF assms[folded in_lists_conv_set_subset]]. 
+
+lemma sing_lists_exp_len: "ws \<in> lists {x} \<Longrightarrow> [x]\<^sup>@\<^bold>|ws\<^bold>| = ws"
+  by  (induct ws, auto)
+
+lemma sing_lists_exp_count: "ws \<in> lists {x} \<Longrightarrow> [x]\<^sup>@(count_list ws x) = ws"
+  by  (induct ws, auto)
+
+lemma sing_set_pow_count_list: "set ws \<subseteq> {a} \<Longrightarrow> [a]\<^sup>@(count_list ws a) = ws"
+  unfolding in_lists_conv_set_subset using  sing_lists_exp_count.
+
+lemma sing_set_pow: "set ws \<subseteq> {a} \<Longrightarrow> [a]\<^sup>@\<^bold>|ws\<^bold>| = ws"
+  by auto 
+
+lemma count_sing_exp: "count_list ([a]\<^sup>@k) a = k" 
+  by (induct k, simp, simp add: count_list_append)
+
+lemma count_sing_distinct: "a \<noteq> b \<Longrightarrow> count_list ([a]\<^sup>@k) b = 0" 
+  by (induct k, simp, auto simp add: count_list_append)
+
+lemma sing_code: "x \<noteq> \<epsilon> \<Longrightarrow> code {x}"
+proof (rule code.intro)
+  fix xs ys
+  assume "x \<noteq> \<epsilon>" "xs \<in> lists {x}" "ys \<in> lists {x}" "concat xs = concat ys"
+  show "xs = ys"
+    using \<open>concat xs = concat ys\<close>
+      [unfolded concat_sing_list_pow'[OF \<open>xs \<in> lists {x}\<close>]
+        concat_sing_list_pow'[OF \<open>ys \<in> lists {x}\<close>]
+        eq_pow_exp[OF \<open>x \<noteq> \<epsilon>\<close>]]   
+      sing_lists_exp_len[OF \<open>xs \<in> lists {x}\<close>]
+      sing_lists_exp_len[OF \<open>ys \<in> lists {x}\<close>] by argo
+qed
+
+section \<open>Various additional lemmas\<close>
+
+subsection \<open>Roots of binary set\<close>
+
+(* TODO Generalized?*)
+lemma two_roots_code: assumes "x \<noteq> \<epsilon>" and  "y \<noteq> \<epsilon>" shows "code {\<rho> x, \<rho> y}"
+  using assms
+proof (cases "\<rho> x = \<rho> y")
+  assume "\<rho> x = \<rho> y"
+  thus "code {\<rho> x, \<rho> y}" using sing_code[OF primroot_nemp[OF \<open>x \<noteq> \<epsilon>\<close>]] by simp
+next
+  assume "\<rho> x \<noteq> \<rho> y"
+  hence "\<rho> x \<cdot> \<rho> y \<noteq> \<rho> y \<cdot> \<rho> x" 
+    using comm_prim[OF primroot_prim[OF \<open>x \<noteq> \<epsilon>\<close>] primroot_prim[OF \<open>y \<noteq> \<epsilon>\<close>]] by blast
+  thus "code {\<rho> x, \<rho> y}"
+    by (simp add: bin_code_code)
+qed
+
+lemma primroot_in_set_dec: assumes "x \<noteq> \<epsilon>" and  "y \<noteq> \<epsilon>" shows "\<rho> x \<in> set (Dec {\<rho> x, \<rho> y} x)"
+proof-
+  obtain k where "concat ([\<rho> x]\<^sup>@Suc k) = x"
+    using primroot_expE[OF \<open>x \<noteq> \<epsilon>\<close>] 
+      concat_sing_pow[symmetric, of "\<rho> x"] by metis
+  from code.code_unique_dec'[OF two_roots_code[OF assms], of "[\<rho> x]\<^sup>@Suc k", unfolded \<open>concat ([\<rho> x]\<^sup>@Suc k) = x\<close>]
+  have "Dec {\<rho> x, \<rho> y} x = [\<rho> x]\<^sup>@Suc k" 
+    using insertI1 sing_pow_lists by metis
+  show ?thesis
+    unfolding \<open>Dec {\<rho> x, \<rho> y} x = [\<rho> x]\<^sup>@Suc k\<close> by simp
+qed
+
+lemma primroot_dec: assumes "x \<cdot> y \<noteq> y \<cdot> x" 
+ obtains k where "(Dec {\<rho> x, \<rho> y} x) = [\<rho> x]\<^sup>@Suc k"
+proof-
+  have "x \<noteq> \<epsilon>" and "y \<noteq> \<epsilon>" using \<open>x \<cdot> y \<noteq> y \<cdot> x\<close> by blast+
+  note rcode = \<open>x \<cdot> y \<noteq> y \<cdot> x\<close>[unfolded comp_primroot_conv'[OF this]] 
+  interpret binary_code "\<rho> x" "\<rho> y" 
+    using rcode by unfold_locales
+  have "x \<in> \<langle>{\<rho> x, \<rho> y}\<rangle>"
+    by blast 
+  obtain k where "concat ([\<rho> x]\<^sup>@Suc k) = x"
+    using primroot_expE[OF \<open>x \<noteq> \<epsilon>\<close>] 
+      concat_sing_pow[symmetric, of "\<rho> x"] by metis
+  from code_unique_dec[OF _ this] 
+  show thesis  
+    by (simp add: sing_pow_lists that) 
+qed
+
+lemma primroot_dec': assumes "x \<cdot> y \<noteq> y \<cdot> x" 
+ obtains k where "(Dec {\<rho> x, \<rho> y} y) = [\<rho> y]\<^sup>@Suc k"
+  using primroot_dec[OF assms[symmetric], unfolded insert_commute].
+
+lemma (in binary_code) bin_roots_sings_code: "sings_code {Dec {\<rho> u\<^sub>0, \<rho> u\<^sub>1} u\<^sub>0, Dec {\<rho> u\<^sub>0, \<rho> u\<^sub>1} u\<^sub>1}"
+proof
+  interpret rcode: binary_code "\<rho> u\<^sub>0" "\<rho> u\<^sub>1"
+    using binary_code.intro non_comm[unfolded comp_primroot_conv'[OF bin_fst_nemp bin_snd_nemp]].
+    
+  obtain k\<^sub>0 where dec0: "(Dec {\<rho> u\<^sub>0,\<rho> u\<^sub>1} u\<^sub>0) = [\<rho> u\<^sub>0]\<^sup>@Suc k\<^sub>0"
+    using primroot_dec[OF non_comm].
+  obtain k\<^sub>1 where dec1: "(Dec {\<rho> u\<^sub>0,\<rho> u\<^sub>1} u\<^sub>1) = [\<rho> u\<^sub>1]\<^sup>@Suc k\<^sub>1"
+    using primroot_dec'[OF non_comm].
+  show "c \<in> {Dec {\<rho> u\<^sub>0, \<rho> u\<^sub>1} u\<^sub>0, Dec {\<rho> u\<^sub>0, \<rho> u\<^sub>1} u\<^sub>1} \<Longrightarrow> card (set c) = 1" for c     
+    unfolding dec0 dec1 using sing_pow_card_set  by (elim two_elem_cases) fast+
+  show  "set c \<noteq> set d" if "c \<in> {Dec {\<rho> u\<^sub>0, \<rho> u\<^sub>1} u\<^sub>0, Dec {\<rho> u\<^sub>0, \<rho> u\<^sub>1} u\<^sub>1}" and 
+           "d \<in> {Dec {\<rho> u\<^sub>0, \<rho> u\<^sub>1} u\<^sub>0, Dec {\<rho> u\<^sub>0, \<rho> u\<^sub>1} u\<^sub>1}" and "c \<noteq> d"  for c d
+    using that unfolding dec0 dec1 
+  proof (elim two_elem_cases) 
+    assume c: "c = [\<rho> u\<^sub>0] \<^sup>@ Suc k\<^sub>0" and d: "d = [\<rho> u\<^sub>1] \<^sup>@ Suc k\<^sub>1"
+    show "set c \<noteq> set d" 
+      unfolding c d sing_pow_set_Suc using rcode.bin_code_neq by blast 
+  next
+    assume c: "c = [\<rho> u\<^sub>1] \<^sup>@ Suc k\<^sub>1" and d: "d = [\<rho> u\<^sub>0] \<^sup>@ Suc k\<^sub>0"
+    show "set c \<noteq> set d" 
+      unfolding c d sing_pow_set_Suc using rcode.bin_code_neq[symmetric] by blast 
+  qed simp_all
+qed
+
+subsection Other
+
+lemma bin_count_one_decompose: assumes "ws \<in> lists {x,y}" and "x \<noteq> y" and  "count_list ws y = 1"
+  obtains k m where "[x]\<^sup>@k \<cdot> [y] \<cdot> [x]\<^sup>@m = ws"
+proof-
+  have "ws \<notin> [x]*"               
+    using count_sing_distinct[OF \<open>x \<noteq> y\<close>] \<open>count_list ws y = 1\<close> unfolding root_def by force
+  from distinct_letter_in[OF this]
+  obtain ws' k  b where "[x]\<^sup>@k \<cdot> [b] \<cdot> ws' = ws" and "b \<noteq> x" by blast
+  hence "b = y" 
+    using \<open>ws \<in> lists {x,y}\<close>  by force
+  have "ws' \<in> lists {x,y}"
+    using \<open>ws \<in> lists {x,y}\<close>[folded \<open>[x]\<^sup>@k \<cdot> [b] \<cdot> ws' = ws\<close>] by simp 
+  have "count_list ws' y = 0"
+    using arg_cong[OF \<open>[x]\<^sup>@k \<cdot> [b] \<cdot> ws' = ws\<close>, of "\<lambda> x. count_list x y"]
+    unfolding count_list_append \<open>count_list ws y = 1\<close> \<open>b = y\<close>  by force 
+  from sing_lists_exp[OF bin_lists_count_zero'[OF \<open>ws' \<in> lists {x,y}\<close> this]] 
+  obtain m where "ws' = [x]\<^sup>@m".
+  from that[OF \<open>[x]\<^sup>@k \<cdot> [b] \<cdot> ws' = ws\<close>[unfolded this \<open>b = y\<close>]]  
+  show thesis.
+qed
+
+lemma bin_count_one_conjug: assumes "ws \<in> lists {x,y}" and "x \<noteq> y" and "count_list ws y = 1"
+  shows "ws \<sim> [x]\<^sup>@(count_list ws x) \<cdot> [y]" 
+proof-
+  obtain e1 e2 where "[x]\<^sup>@e1 \<cdot> [y] \<cdot> [x]\<^sup>@e2 = ws" 
+    using bin_count_one_decompose[OF assms].
+  from conjugI'[of "[x] \<^sup>@ e1 \<cdot> [y]" "[x]\<^sup>@e2", unfolded rassoc this]
+  have "ws \<sim> [x]\<^sup>@(e2 + e1) \<cdot> [y]"
+    unfolding add_exps rassoc.
+  moreover have "count_list ([x]\<^sup>@(e2 + e1) \<cdot> [y]) x = e2 + e1"
+    using \<open>x \<noteq> y\<close> by (simp add: count_list_append count_sing_exp) 
+  ultimately show ?thesis
+    by (simp add: count_list_conjug)  
+qed
+
+lemma bin_prim_long_set: assumes "ws \<in> lists {x,y}" and "primitive ws" and  "2 \<le> \<^bold>|ws\<^bold>|"
+    shows "set ws = {x,y}" 
+proof-
+  have "\<not> set ws \<subseteq> {c}" for c
+    using \<open>primitive ws\<close> pow_nemp_imprim \<open>2 \<le> \<^bold>|ws\<^bold>|\<close>
+          sing_lists_exp_len[folded in_lists_conv_set_subset] by metis 
+  then show "set ws = {x,y}"
+    unfolding subset_singleton_iff using \<open>ws \<in> lists {x,y}\<close>[folded in_lists_conv_set_subset] doubleton_subset_cases by metis 
+qed
+
+lemma bin_prim_long_pref: assumes "ws \<in> lists {x,y}" and "primitive ws" and  "2 \<le> \<^bold>|ws\<^bold>|"
+  obtains ws' where "ws \<sim> ws'" and "[x,y] \<le>p ws'" 
+proof-
+  from pow_nemp_imprim[OF \<open>2 \<le> \<^bold>|ws\<^bold>|\<close>, of "[x]"] sing_lists_exp_len[of ws x]
+  have "\<not> ws \<in> lists {x}" 
+   using \<open>primitive ws\<close> \<open>2 \<le> \<^bold>|ws\<^bold>|\<close> by fastforce
+  hence "x \<noteq> y"
+   using \<open>ws \<in> lists {x,y}\<close> by fastforce
+  from switch_fac[OF \<open>x \<noteq> y\<close> bin_prim_long_set[OF assms]]
+  show thesis
+    using \<open>2 \<le> \<^bold>|ws\<^bold>|\<close> rotate_into_pos_sq[of \<epsilon> "[x,y]" ws thesis, unfolded clean_emp, OF \<open>[x, y] \<le>f ws \<cdot> ws\<close> _ _ that, of id]
+    by force
+qed
 
 end
\ No newline at end of file
diff --git a/thys/Combinatorics_Words_Graph_Lemma/Glued_Codes.thy b/thys/Combinatorics_Words_Graph_Lemma/Glued_Codes.thy
new file mode 100644
--- /dev/null
+++ b/thys/Combinatorics_Words_Graph_Lemma/Glued_Codes.thy
@@ -0,0 +1,481 @@
+(*  Title:      Glued Codes
+    File:       CoW_Graph_Lemma.Glued_Codes
+    Author:     Štěpán Holub, Charles University
+    Author:     Martin Raška, Charles University
+
+Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/
+*)
+
+theory Glued_Codes
+  imports Combinatorics_Words.Submonoids
+begin
+
+chapter "Glued codes"
+
+section \<open>Lists that do not end with a fixed letter\<close>
+
+lemma append_last_neq: 
+  "us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> vs = \<epsilon> \<or> last vs \<noteq> w \<Longrightarrow> us \<cdot> vs = \<epsilon> \<or> last (us \<cdot> vs) \<noteq> w"
+  by (auto simp only: last_append split: if_split)   
+
+lemma last_neq_induct [consumes 1, case_names emp hd_eq hd_neq]:
+  assumes invariant: "us = \<epsilon> \<or> last us \<noteq> w"
+      and emp: "P \<epsilon>"
+      and hd_eq: "\<And>us. us \<noteq> \<epsilon> \<Longrightarrow> last us \<noteq> w \<Longrightarrow> P us \<Longrightarrow> P (w # us)"
+      and hd_neq: "\<And>u us. u \<noteq> w \<Longrightarrow> us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> P us \<Longrightarrow> P (u # us)"
+  shows "P us"
+using invariant proof (induction us)
+  case (Cons u us)
+    have inv: "us = \<epsilon> \<or> last us \<noteq> w"
+      using Cons.prems by (intro disjI) simp
+    show "P (u # us)"
+    proof (cases)
+      assume "u = w"
+      have *: "us \<noteq> \<epsilon>" and "last us \<noteq> w"
+        using Cons.prems unfolding \<open>u = w\<close> by auto
+      then show "P (u # us)" unfolding \<open>u = w\<close> using Cons.IH[OF inv] by (fact hd_eq)
+    qed (use inv Cons.IH[OF inv] in \<open>fact hd_neq\<close>)
+qed (rule \<open>P \<epsilon>\<close>)
+
+lemma last_neq_blockE:
+  assumes last_neq: "us \<noteq> \<epsilon>" and "last us \<noteq> w"
+  obtains k u us' where "u \<noteq> w" and "us' = \<epsilon> \<or> last us' \<noteq> w" and "[w] \<^sup>@ k \<cdot> u # us' = us"
+using disjI2[OF \<open>last us \<noteq> w\<close>] \<open>us \<noteq> \<epsilon>\<close> proof (induction us rule: last_neq_induct)
+  case (hd_eq us)
+    from \<open>us \<noteq> \<epsilon>\<close> show ?case
+      by (rule hd_eq.IH[rotated]) (intro hd_eq.prems(1)[of _ _ "Suc _"], assumption+, simp)
+next
+  case (hd_neq u us)
+    from hd_neq.hyps show ?case
+     by (rule hd_neq.prems(1)[of _ _ 0]) simp
+qed blast
+
+lemma last_neq_block_induct [consumes 1, case_names emp block]:
+  assumes last_neq: "us = \<epsilon> \<or> last us \<noteq> w"
+      and emp: "P \<epsilon>"
+      and block: "\<And>k u us. u \<noteq> w \<Longrightarrow> us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> P us \<Longrightarrow> P ([w] \<^sup>@ k \<cdot> (u # us))"
+  shows "P us"
+using last_neq proof (induction us rule: ssuf_induct)
+  case (ssuf us)
+    show ?case proof (cases "us = \<epsilon>")
+      assume "us \<noteq> \<epsilon>"
+      obtain k u us' where "u \<noteq> w" and "us' = \<epsilon> \<or> last us' \<noteq> w" and "[w] \<^sup>@ k \<cdot> u # us' = us"
+        using \<open>us \<noteq> \<epsilon>\<close> \<open>us = \<epsilon> \<or> last us \<noteq> w\<close> by (elim last_neq_blockE) (simp add: \<open>us \<noteq> \<epsilon>\<close>)
+      have "us' <s us" and "us' = \<epsilon> \<or> last us' \<noteq> w"
+        using \<open>us = \<epsilon> \<or> last us \<noteq> w\<close> by (auto simp flip: \<open>[w] \<^sup>@ k \<cdot> u # us' = us\<close>)
+      from \<open>u \<noteq> w\<close> \<open>us' = \<epsilon> \<or> last us' \<noteq> w\<close> ssuf.IH[OF this]
+      show "P us" unfolding \<open>[w] \<^sup>@ k \<cdot> u # us' = us\<close>[symmetric] by (fact block)
+    qed (simp only: emp)
+qed
+
+section \<open>Glue a list element with its successors/predecessors\<close>
+
+function glue :: "'a list \<Rightarrow> 'a list list \<Rightarrow> 'a list list" where
+  glue_emp:  "glue w \<epsilon> = \<epsilon>" |
+  glue_Cons: "glue w (u # us) =
+    (let glue_tl = glue w us in
+      if u = w then (u \<cdot> hd glue_tl) # tl glue_tl
+      else u # glue_tl)"
+  unfolding prod_eq_iff prod.sel by (cases rule: list.exhaust[of "snd _"]) blast+
+  termination by (relation "measure (length \<circ> snd)") simp_all
+
+lemma no_gluing: "w \<notin> set us \<Longrightarrow> glue w us = us"
+  by (induction us) auto
+
+lemma glue_nemp [simp, intro!]: "us \<noteq> \<epsilon> \<Longrightarrow> glue w us \<noteq> \<epsilon>"
+  by (elim hd_tlE) (auto simp only: glue.simps Let_def split!: if_split)
+
+lemma glue_is_emp_iff [simp]: "glue w us = \<epsilon> \<longleftrightarrow> us = \<epsilon>"
+  using glue_nemp glue_emp by blast
+
+lemma len_glue: "us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> \<^bold>|glue w us\<^bold>| + count_list us w = \<^bold>|us\<^bold>|"
+  by (induction rule: last_neq_induct) (auto simp add: Let_def)
+
+lemma len_glue_le: assumes "us = \<epsilon> \<or> last us \<noteq> w" shows "\<^bold>|glue w us\<^bold>| \<le> \<^bold>|us\<^bold>|"
+  using len_glue[OF assms] unfolding nat_le_iff_add eq_commute[of "\<^bold>|us\<^bold>|"] by blast
+
+lemma len_glue_less []: "us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> w \<in> set us \<Longrightarrow> \<^bold>|glue w us\<^bold>| < \<^bold>|us\<^bold>|"
+  by (simp add: count_list_gr_0_iff flip: len_glue[of us])
+
+lemma assumes "us = \<epsilon> \<or> last us \<noteq> w" and "\<epsilon> \<notin> set us"
+  shows emp_not_in_glue: "\<epsilon> \<notin> set (glue w us)"
+    and glued_not_in_glue: "w \<notin> set (glue w us)"
+  unfolding atomize_conj using assms by (induction us rule: last_neq_induct)
+    (auto simp: Let_def dest!: tl_set lists_hd_in_set[OF glue_nemp[of _ w]])
+
+lemma glue_glue: "us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> \<epsilon> \<notin> set us \<Longrightarrow> glue w (glue w us) = glue w us"
+  using no_gluing[OF glued_not_in_glue].
+
+lemma glue_block_append: assumes "u \<noteq> w"
+  shows "glue w ([w] \<^sup>@ k \<cdot> (u # us)) = (w \<^sup>@ k \<cdot> u) # glue w us"
+  by (induction k) (simp_all add: \<open>u \<noteq> w\<close>)
+
+lemma concat_glue [simp]: "us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> concat (glue w us) = concat us"
+  by (induction us rule: last_neq_block_induct) (simp_all add: glue_block_append)
+
+lemma glue_append:
+  "us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> glue w (us \<cdot> vs) = glue w us \<cdot> glue w vs"
+  by (induction us rule: last_neq_block_induct) (simp_all add: glue_block_append)
+
+lemma glue_pow:
+  assumes "us = \<epsilon> \<or> last us \<noteq> w"
+  shows "glue w (us \<^sup>@ k) = (glue w us) \<^sup>@ k"
+  by (induction k) (simp_all add: assms glue_append)
+
+lemma glue_in_lists_hull [intro]:
+  "us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> us \<in> lists G \<Longrightarrow> glue w us \<in> lists \<langle>G\<rangle>"
+  by (induction rule: last_neq_induct) (simp_all add: Let_def tl_in_lists prod_cl gen_in)
+
+\<comment> \<open>Gluing from the right (gluing a letter with its predecessor)\<close>
+function gluer :: "'a list \<Rightarrow> 'a list list \<Rightarrow> 'a list list" where
+  gluer_emp:  "gluer w \<epsilon> = \<epsilon>" |
+  gluer_Cons: "gluer w (u # us) =
+    (let gluer_butlast = gluer w (butlast (u # us)) in
+      if last (u # us) = w then (butlast gluer_butlast) \<cdot> [last gluer_butlast \<cdot> last (u # us)]
+      else gluer_butlast \<cdot> [last (u # us)])"
+  unfolding prod_eq_iff prod.sel by (cases rule: list.exhaust[of "snd _"]) blast+
+  termination by (relation "measure (length \<circ> snd)") simp_all
+
+lemma gluer_nemp_def: assumes "us \<noteq> \<epsilon>"
+  shows "gluer w us = 
+    (let gluer_butlast = gluer w (butlast us) in
+      if last us = w then (butlast gluer_butlast) \<cdot> [last gluer_butlast \<cdot> last us]
+      else gluer_butlast \<cdot> [last us])"
+  using gluer_Cons[of w "hd us" "tl us"] unfolding hd_Cons_tl[OF \<open>us \<noteq> \<epsilon>\<close>].
+
+lemma gluer_nemp: assumes "us \<noteq> \<epsilon>" shows "gluer w us \<noteq> \<epsilon>"
+  unfolding gluer_nemp_def[OF \<open>us \<noteq> \<epsilon>\<close>]
+  by (simp only: Let_def split!: if_split)
+
+lemma hd_neq_induct [consumes 1, case_names emp snoc_eq snoc_neq]:
+  assumes invariant: "us = \<epsilon> \<or> hd us \<noteq> w"
+      and emp: "P \<epsilon>"
+      and snoc_eq: "\<And>us. us \<noteq> \<epsilon> \<Longrightarrow> hd us \<noteq> w \<Longrightarrow> P us \<Longrightarrow> P (us \<cdot> [w])"
+      and snoc_neq: "\<And>u us. u \<noteq> w \<Longrightarrow> us = \<epsilon> \<or> hd us \<noteq> w \<Longrightarrow> P us \<Longrightarrow> P (us \<cdot> [u])"
+  shows "P us"
+using last_neq_induct[where P="\<lambda>x. P (rev x)" for P, reversed, unfolded rev_rev_ident, OF assms].
+
+lemma gluer_rev [reversal_rule]: assumes "us = \<epsilon> \<or> last us \<noteq> w"
+  shows "gluer (rev w) (rev (map rev us)) =  rev (map rev (glue w us))"
+  using assms by (induction us rule: last_neq_induct)
+    (simp_all add: gluer_nemp_def Let_def map_tl last_rev hd_map)
+
+lemma glue_rev [reversal_rule]: assumes "us = \<epsilon> \<or> hd us \<noteq> w"
+  shows "glue (rev w) (rev (map rev us)) =  rev (map rev (gluer w us))"
+  using assms by (induction us rule: hd_neq_induct)
+    (simp_all add: gluer_nemp_def Let_def map_tl last_rev hd_map)
+
+section \<open>Generators with glued element\<close>
+
+text \<open>The following set will turn out to be the generating set of all words whose
+ decomposition into a generating code does not end with w\<close>
+
+inductive_set glued_gens :: "'a list \<Rightarrow> 'a list set \<Rightarrow> 'a list set"
+  for w G where
+    other_gen: "g \<in> G \<Longrightarrow> g \<noteq> w \<Longrightarrow> g \<in> glued_gens w G" 
+  | glued [intro!]: "u \<in> glued_gens w G \<Longrightarrow>  w \<cdot> u \<in> glued_gens w G"
+
+lemma in_glued_gensI: assumes "g \<in> G" "g \<noteq> w"
+  shows "w \<^sup>@ k \<cdot> g = u \<Longrightarrow> u \<in> glued_gens w G"
+  by (induction k arbitrary: u) (auto simp: other_gen[OF \<open>g \<in> G\<close> \<open>g \<noteq> w\<close>])
+
+lemma in_glued_gensE:
+  assumes "u \<in> glued_gens w G"
+  obtains k g where "g \<in> G" and "g \<noteq> w" and "w \<^sup>@ k \<cdot> g = u"
+using assms proof (induction)
+  case (glued u)
+    show ?case by (auto intro!: glued.IH[OF glued.prems[of _ "Suc _"]])
+qed (use pow_zero in blast)
+
+lemma glued_gens_alt_def: "glued_gens w C = {w \<^sup>@ k \<cdot> g | k g. g \<in> C \<and> g \<noteq> w}"
+  by (blast elim!: in_glued_gensE intro: in_glued_gensI)
+
+lemma glued_hull_sub_hull [simp, intro!]: "w \<in> G \<Longrightarrow> \<langle>glued_gens w G\<rangle> \<subseteq> \<langle>G\<rangle>"
+  by (rule hull_mono') (auto elim!: in_glued_gensE)
+
+lemma glued_hull_sub_hull': "w \<in> G \<Longrightarrow> u \<in> \<langle>glued_gens w G\<rangle> \<Longrightarrow> u \<in> \<langle>G\<rangle>"
+  using set_mp[OF glued_hull_sub_hull].
+
+lemma in_glued_hullE:
+  assumes "w \<in> G" and "u \<in> \<langle>glued_gens w G\<rangle>"
+  obtains us where "concat us = u" and "us \<in> lists G" and "us = \<epsilon> \<or> last us \<noteq> w"
+using \<open>u \<in> \<langle>glued_gens w G\<rangle>\<close> proof (induction arbitrary: thesis)
+  case (prod_cl v u)
+    obtain k g where "g \<in> G" and "g \<noteq> w" and "concat ([w] \<^sup>@ k \<cdot> [g]) = v"
+      using \<open>v \<in> glued_gens w G\<close> by (simp add: concat_pow) (elim in_glued_gensE)
+    obtain us where u: "concat us = u" and "us \<in> lists G" and "(us = \<epsilon> \<or> last us \<noteq> w)" by fact
+    have "concat ([w] \<^sup>@ k \<cdot> [g] \<cdot> us) = v \<cdot> u"
+      by (simp flip: \<open>concat ([w] \<^sup>@ k \<cdot> [g]) = v\<close> \<open>concat us = u\<close>)
+    with \<open>(us = \<epsilon> \<or> last us \<noteq> w)\<close> show thesis
+      by (elim prod_cl.prems, intro lists.intros 
+          append_in_lists pow_in_lists \<open>w \<in> G\<close> \<open>g \<in> G\<close> \<open>us \<in> lists G\<close>)
+         (auto simp: \<open>g \<noteq> w\<close>)
+qed (use concat.simps(1) in blast)
+
+lemma glue_in_lists [simp, intro!]:
+  assumes "us = \<epsilon> \<or> last us \<noteq> w"
+  shows "us \<in> lists G \<Longrightarrow> glue w us \<in> lists (glued_gens w G)"
+  using assms by (induction rule: last_neq_block_induct)
+    (auto simp: glue_block_append intro: in_glued_gensI)
+
+lemma concat_in_glued_hull[intro]:
+  "us \<in> lists G \<Longrightarrow> us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> concat us \<in> \<langle>glued_gens w G\<rangle>"
+  unfolding concat_glue[symmetric] by (intro concat_in_hull' glue_in_lists)
+
+lemma glued_hull_conv: assumes "w \<in> G"
+  shows "\<langle>glued_gens w G\<rangle> = {concat us | us. us \<in> lists G \<and> (us = \<epsilon> \<or> last us \<noteq> w)}"
+  by (blast elim!: in_glued_hullE[OF \<open>w \<in> G\<close>])
+
+section \<open>Bounded gluing\<close>
+
+lemma bounded_glue_in_lists:
+  assumes "us = \<epsilon> \<or> last us \<noteq> w" and "\<not> [w] \<^sup>@ n \<le>f us"
+  shows "us \<in> lists G \<Longrightarrow> glue w us \<in> lists {w \<^sup>@ k \<cdot> g | k g. g \<in> G \<and> g \<noteq> w \<and> k < n}"
+using assms proof (induction us rule: last_neq_block_induct)
+  case (block k u us)
+    have "k < n" and "\<not> [w] \<^sup>@ n \<le>f us"
+      using \<open>\<not> [w] \<^sup>@ n \<le>f [w] \<^sup>@ k \<cdot> u # us\<close>
+      by (blast intro!: not_le_imp_less pref_ext le_exps_pref, blast intro!: fac_ext_pref fac_ext_hd)
+    then show ?case
+      using \<open>[w] \<^sup>@ k \<cdot> u # us \<in> lists G\<close> \<open>u \<noteq> w\<close> unfolding glue_block_append[OF \<open>u \<noteq> w\<close>]
+      by (blast intro!: block.IH del: in_listsD in_listsI)
+qed simp
+
+subsection \<open>Gluing on binary alphabet\<close>
+
+lemma bounded_bin_glue_in_lists: \<comment> \<open>meaning: a binary code\<close>
+  assumes "us = \<epsilon> \<or> last us \<noteq> x"
+      and "\<not> [x] \<^sup>@ n \<le>f us"
+      and "us \<in> lists {x, y}"
+  shows "glue x us \<in> lists {x \<^sup>@ k \<cdot> y | k. k < n}"
+using bounded_glue_in_lists[OF assms] by blast
+
+lemma single_bin_glue_in_lists: \<comment> \<open>meaning: a single occurrence\<close>
+  assumes "us = \<epsilon> \<or> last us \<noteq> x"
+      and "\<not> [x,x] \<le>f us"
+      and "us \<in> lists {x, y}"
+  shows "glue x us \<in> lists {x \<cdot> y, y}"
+  using bounded_bin_glue_in_lists[of _ _ 2, simplified, OF assms] unfolding numeral_nat
+  by (auto elim!: sub_lists_mono[rotated] less_SucE)
+
+lemma count_list_single_bin_glue:
+  assumes "x \<noteq> \<epsilon>" and "x \<noteq> y"
+      and "us = \<epsilon> \<or> last us \<noteq> x"
+      and "us \<in> lists {x,y}"
+      and "\<not> [x,x] \<le>f us"
+  shows "count_list (glue x us) (x \<cdot> y) = count_list us x"
+    and "count_list (glue x us) y + count_list us x = count_list us y"
+using assms(3-5) unfolding atomize_conj pow_Suc[symmetric]
+proof (induction us rule: last_neq_block_induct)
+  case (block k u us)
+    have "u = y" using \<open>[x] \<^sup>@ k \<cdot> u # us \<in> lists {x, y}\<close> \<open>u \<noteq> x\<close> by simp
+    have IH: "count_list (glue x us) (x \<cdot> y) = count_list us x \<and>
+              count_list (glue x us) y + count_list us x = count_list us y"
+      using block.prems by (intro block.IH) (simp, blast intro!: fac_ext_pref fac_ext_hd)
+    have "\<not> [x] \<^sup>@ Suc (Suc 0) \<le>f [x] \<^sup>@ k \<cdot> u # us"
+      using block.prems(2) by auto 
+    then have "k < Suc (Suc 0)"
+      by (blast intro!: not_le_imp_less pref_ext le_exps_pref)
+    then show ?case unfolding \<open>u = y\<close> glue_block_append[OF \<open>x \<noteq> y\<close>[symmetric]]
+      by (elim less_SucE less_zeroE) (simp_all add: \<open>x \<noteq> y\<close> \<open>x \<noteq> y\<close>[symmetric] \<open>x \<noteq> \<epsilon>\<close> IH)
+qed simp
+
+section \<open>Code with glued element\<close>
+
+context code
+begin
+
+text \<open>If the original generating set is a code, then also the glued generators form a code\<close>
+
+lemma glued_hull_last_dec: assumes "w \<in> \<C>" and  "u \<in> \<langle>glued_gens w \<C>\<rangle>" and "u \<noteq> \<epsilon>"
+  shows "last (Dec \<C> u) \<noteq> w"
+  using \<open>u \<in> \<langle>glued_gens w \<C>\<rangle>\<close>
+  by (elim in_glued_hullE[OF \<open>w \<in> \<C>\<close>]) (auto simp: code_unique_dec \<open>u \<noteq> \<epsilon>\<close>)
+
+lemma in_glued_hullI [intro]:
+  assumes "u \<in> \<langle>\<C>\<rangle>" and "(u = \<epsilon> \<or> last (Dec \<C> u) \<noteq> w)"
+  shows "u \<in> \<langle>glued_gens w \<C>\<rangle>"
+  using concat_in_glued_hull[OF dec_in_lists[OF \<open>u \<in> \<langle>\<C>\<rangle>\<close>], of w]  
+  by (simp add: \<open>u \<in> \<langle>\<C>\<rangle>\<close> \<open>u = \<epsilon> \<or> last (Dec \<C> u) \<noteq> w\<close>)
+
+lemma code_glued_hull_conv: assumes "w \<in> \<C>"
+  shows "\<langle>glued_gens w \<C>\<rangle> = {u \<in> \<langle>\<C>\<rangle>. u = \<epsilon> \<or> last (Dec \<C> u) \<noteq> w}"
+proof
+  show "\<langle>glued_gens w \<C>\<rangle> \<subseteq> {u \<in> \<langle>\<C>\<rangle>. u = \<epsilon> \<or> last (Dec \<C> u) \<noteq> w}"
+    using glued_hull_sub_hull'[OF \<open>w \<in> \<C>\<close>] glued_hull_last_dec[OF \<open>w \<in> \<C>\<close>] by blast
+  show "{u \<in> \<langle>\<C>\<rangle>. u = \<epsilon> \<or> last (Dec \<C> u) \<noteq> w} \<subseteq> \<langle>glued_gens w \<C>\<rangle>"
+    using in_glued_hullI by blast
+qed
+
+lemma in_glued_hull_iff:
+  assumes "w \<in> \<C>" and "u \<in> \<langle>\<C>\<rangle>"
+  shows "u \<in> \<langle>glued_gens w \<C>\<rangle> \<longleftrightarrow> u = \<epsilon> \<or> last (Dec \<C> u) \<noteq> w"
+  by (simp add: \<open>w \<in> \<C>\<close> \<open>u \<in> \<langle>\<C>\<rangle>\<close> code_glued_hull_conv)
+
+lemma glued_not_in_glued_hull: "w \<in> \<C> \<Longrightarrow> w \<notin> \<langle>glued_gens w \<C>\<rangle>"
+  unfolding in_glued_hull_iff[OF _ gen_in] code_el_dec
+  by (simp add: in_code_nemp)
+
+lemma glued_gens_nemp: assumes "u \<in> glued_gens w \<C>" shows "u \<noteq> \<epsilon>"
+  using assms by (induction) (auto simp add: in_code_nemp) 
+
+lemma glued_gens_code: assumes "w \<in> \<C>" shows "code (glued_gens w \<C>)"
+proof
+  show "us = vs" if "us \<in> lists (glued_gens w \<C>)" and "vs \<in> lists (glued_gens w \<C>)"
+    and "concat us = concat vs" for us vs
+  using that proof (induction rule: list_induct2')
+    case (4 u us v vs)
+      have *: "us \<in> lists (glued_gens w \<C>) \<Longrightarrow> us \<in> lists \<langle>\<C>\<rangle>" for us
+        using sub_lists_mono[OF subset_trans[OF genset_sub glued_hull_sub_hull[OF \<open>w \<in> \<C>\<close>]]].
+      obtain k u' l v'
+        where "u' \<in> \<C>" "u' \<noteq> w" "w \<^sup>@ k \<cdot> u' = u"
+          and "v' \<in> \<C>" "v' \<noteq> w" "w \<^sup>@ l \<cdot> v' = v"
+        using "4.prems"(1-2) by simp (elim conjE in_glued_gensE)
+      from this(3, 6) "4.prems" \<open>w \<in> \<C>\<close>
+      have "concat (([w] \<^sup>@ k \<cdot> [u']) \<cdot> (Ref \<C> us)) = concat (([w] \<^sup>@ l \<cdot> [v']) \<cdot> (Ref \<C> vs))" 
+        by (simp add: concat_ref * concat_pow lassoc)
+      with \<open>w \<in> \<C>\<close> \<open>u' \<in> \<C>\<close> \<open>v' \<in> \<C>\<close> "4.prems"(1-2)
+      have "[w] \<^sup>@ k \<cdot> [u'] \<bowtie> [w] \<^sup>@ l \<cdot> [v']" 
+        by (elim eqd_comp[OF is_code, rotated 2])
+        (simp_all add: "*" pow_in_lists ref_in') 
+      with \<open>u' \<noteq> w\<close> \<open>v' \<noteq> w\<close> \<open>w \<^sup>@ k \<cdot> u' = u\<close> \<open>w \<^sup>@ l \<cdot> v' = v\<close>
+      have "u = v"
+        by (elim sing_pref_comp_mismatch[rotated 2, elim_format]) blast+
+      then show "u # us = v # vs"
+        using "4.IH" "4.prems"(1-3) by simp
+  qed (auto dest!: glued_gens_nemp)
+qed
+
+text \<open>A crucial lemma showing the relation between gluing and the decomposition into generators\<close>
+
+lemma dec_glued_gens: assumes "w \<in> \<C>" and "u \<in> \<langle>glued_gens w \<C>\<rangle>"
+  shows "Dec (glued_gens w \<C>) u = glue w (Dec \<C> u)"
+  using \<open>u \<in> \<langle>glued_gens w \<C>\<rangle>\<close> glued_hull_sub_hull'[OF \<open>w \<in> \<C>\<close> \<open>u \<in> \<langle>glued_gens w \<C>\<rangle>\<close>]
+  by (intro code.code_unique_dec glued_gens_code) 
+     (simp_all add: in_glued_hull_iff \<open>w \<in> \<C>\<close>)
+
+lemma ref_glue: "us = \<epsilon> \<or> last us \<noteq> w \<Longrightarrow> us \<in> lists \<C> \<Longrightarrow> Ref \<C> (glue w us) = us"
+  by (intro refI glue_in_lists_hull) simp_all
+
+end (* end of context code *)
+
+theorem glued_code:
+  assumes "code C" and "w \<in> C"
+  shows "code {w \<^sup>@ k \<cdot> u |k u. u \<in> C \<and> u \<noteq> w}"
+  using code.glued_gens_code[OF \<open>code C\<close> \<open>w \<in> C\<close>] unfolding glued_gens_alt_def.
+
+section \<open>Gluing is primitivity preserving\<close>
+
+text \<open>It is easy to obtain that gluing lists of code elements preserves primitivity.
+We provide the result under weaker condition where glue blocks of the list
+have unique concatenation.\<close>
+
+lemma (in code) code_prim_glue:
+  assumes last_neq: "us = \<epsilon> \<or> last us \<noteq> w"
+      and "us \<in> lists \<C>"
+  shows "primitive us \<Longrightarrow> primitive (glue w us)"
+  using prim_map_prim[OF prim_concat_prim, of "decompose \<C>" "glue w us"]
+  unfolding refine_def[symmetric] ref_glue[OF assms].
+
+\<comment> \<open>In the context of code the inverse to the glue function is the @{const refine} function,
+i.e. @{term "\<lambda>vs. concat (map (decompose \<C>) vs)"}, see @{thm code.ref_glue}.
+The role of the @{const decompose} function outside the code context supply the 'unglue' function,
+which maps glued blocks to its unique preimages (see below).\<close>
+
+definition glue_block :: "'a list \<Rightarrow>'a list list \<Rightarrow> 'a list list \<Rightarrow> bool"
+  where "glue_block w us bs =
+    (\<exists>ps k u ss. (ps = \<epsilon> \<or> last ps \<noteq> w) \<and> u \<noteq> w \<and> ps \<cdot> [w] \<^sup>@ k \<cdot> u # ss = us \<and> [w] \<^sup>@ k \<cdot> [u] = bs)"
+
+lemma glue_blockI [intro]:
+  "ps = \<epsilon> \<or> last ps \<noteq> w \<Longrightarrow> u \<noteq> w \<Longrightarrow> ps \<cdot> [w] \<^sup>@ k \<cdot> u # ss = us \<Longrightarrow> [w] \<^sup>@ k \<cdot> [u] = bs
+    \<Longrightarrow> glue_block w us bs"
+  unfolding glue_block_def by (intro exI conjI)
+
+lemma glue_blockE:
+  assumes "glue_block w us bs"
+  obtains ps k u ss where "ps = \<epsilon> \<or> last ps \<noteq> w" and "u \<noteq> w" "ps \<cdot> [w] \<^sup>@ k \<cdot> u # ss = us"
+      and "[w] \<^sup>@ k \<cdot> [u] = bs"
+  using assms unfolding glue_block_def by (elim exE conjE)
+
+lemma assumes "glue_block w us bs"
+  shows glue_block_of_appendL: "glue_block w (us \<cdot> vs) bs"
+    and glue_block_of_appendR: "vs = \<epsilon> \<or> last vs \<noteq> w \<Longrightarrow> glue_block w (vs \<cdot> us) bs"
+  using \<open>glue_block w us bs\<close> by (elim glue_blockE, use nothing in \<open>
+    intro glue_blockI[of _ w _ _ "_ \<cdot> vs" "us \<cdot> vs" bs]
+          glue_blockI[OF append_last_neq, of "vs"  w _ _ _ _ "vs \<cdot> us" bs],
+    simp_all only: eq_commute[of _ us] rassoc append_Cons refl not_False_eq_True\<close>)+
+
+lemma glue_block_of_block_append:
+  "u \<noteq> w \<Longrightarrow> glue_block w us bs \<Longrightarrow> glue_block w ([w] \<^sup>@ k \<cdot> u # us) bs"
+  by (simp only: hd_word[of _ us] lassoc) (elim glue_block_of_appendR, simp_all)
+
+lemma in_set_glueE:
+  assumes last_neq: "us = \<epsilon> \<or> last us \<noteq> w"
+      and "b \<in> set (glue w us)"
+  obtains bs where "glue_block w us bs" and "concat bs = b"
+using assms proof (induction us rule: last_neq_block_induct)
+  case (block k u us)
+    show thesis using \<open>b \<in> set (glue w ([w] \<^sup>@ k \<cdot> u # us))\<close>
+      proof (auto simp add: glue_block_append \<open>u \<noteq> w\<close>)
+        show "b = w \<^sup>@ k \<cdot> u \<Longrightarrow> thesis"
+          by (auto simp add: concat_pow intro!: block.prems(1) glue_blockI[OF _ \<open>u \<noteq> w\<close> _ refl])
+        show "b \<in> set (glue w us) \<Longrightarrow> thesis"
+          by (auto intro!: block.IH[OF block.prems(1)] glue_block_of_block_append \<open>u \<noteq> w\<close>)
+      qed
+qed simp
+
+definition unglue :: "'a list \<Rightarrow> 'a list list \<Rightarrow> 'a list \<Rightarrow> 'a list list"
+  where "unglue w us b = (THE bs. glue_block w us bs \<and> concat bs = b)"
+
+lemma unglueI:
+  assumes unique_blocks: "\<And>bs\<^sub>1 bs\<^sub>2. glue_block w us bs\<^sub>1 \<Longrightarrow> glue_block w us bs\<^sub>2
+            \<Longrightarrow> concat bs\<^sub>1 = concat bs\<^sub>2 \<Longrightarrow> bs\<^sub>1 = bs\<^sub>2"
+  shows "glue_block w us bs \<Longrightarrow> concat bs = b \<Longrightarrow> unglue w us b = bs"
+  unfolding unglue_def by (blast intro: unique_blocks)
+
+lemma concat_map_unglue_glue:
+  assumes last_neq: "us = \<epsilon> \<or> last us \<noteq> w"
+      and unique_blocks: "\<And>vs\<^sub>1 vs\<^sub>2. glue_block w us vs\<^sub>1 \<Longrightarrow> glue_block w us vs\<^sub>2
+            \<Longrightarrow> concat vs\<^sub>1 = concat vs\<^sub>2 \<Longrightarrow> vs\<^sub>1 = vs\<^sub>2"
+  shows "concat (map (unglue w us) (glue w us)) = us"
+using assms proof (induction us rule: last_neq_block_induct)
+  case (block k u us)
+    have IH: "concat (map (unglue w us) (glue w us)) = us"
+      using block.IH[OF block.prems] by (blast intro!: glue_block_of_block_append \<open>u \<noteq> w\<close>)
+    have *: "map (unglue w ([w] \<^sup>@ k \<cdot> u # us)) (glue w us) = map (unglue w us) (glue w us)"
+      by (auto simp only: map_eq_conv unglue_def del: the_equality
+          elim!: in_set_glueE[OF \<open>us = \<epsilon> \<or> last us \<noteq> w\<close>], intro the_equality)
+         (simp_all only: the_equality block.prems glue_block_of_block_append[OF \<open>u \<noteq> w\<close>])
+    show "concat (map (unglue w ([w] \<^sup>@ k \<cdot> u # us)) (glue w ([w] \<^sup>@ k \<cdot> u # us))) = [w] \<^sup>@ k \<cdot> u # us"
+      by (auto simp add: concat_pow glue_block_append[OF \<open>u \<noteq> w\<close>] * IH
+          intro!: unglueI intro: glue_blockI[OF _ \<open>u \<noteq> w\<close>] block.prems)
+qed simp
+
+lemma prim_glue:
+  assumes last_neq: "us = \<epsilon> \<or> last us \<noteq> w"
+      and unique_blocks: "\<And>bs\<^sub>1 bs\<^sub>2. glue_block w us bs\<^sub>1 \<Longrightarrow> glue_block w us bs\<^sub>2
+            \<Longrightarrow> concat bs\<^sub>1 = concat bs\<^sub>2 \<Longrightarrow> bs\<^sub>1 = bs\<^sub>2"
+  shows "primitive us \<Longrightarrow> primitive (glue w us)"
+  using prim_map_prim[OF prim_concat_prim, of "unglue w us" "glue w us"]
+  by (simp only: concat_map_unglue_glue assms)
+
+subsection \<open>Gluing on binary alphabet\<close>
+
+lemma bin_glue_blockE:
+  assumes "us \<in> lists {x, y}"
+      and "glue_block x us bs"
+  obtains k where "[x] \<^sup>@ k \<cdot> [y] = bs"
+  using assms by (auto simp only: glue_block_def del: in_listsD)
+
+lemma unique_bin_glue_blocks:
+  assumes "us \<in> lists {x, y}" and "x \<noteq> \<epsilon>"
+  shows "glue_block x us bs\<^sub>1 \<Longrightarrow> glue_block x us bs\<^sub>2 \<Longrightarrow> concat bs\<^sub>1 = concat bs\<^sub>2 \<Longrightarrow> bs\<^sub>1 = bs\<^sub>2"
+  by (auto simp: concat_pow eq_pow_exp[OF \<open>x \<noteq> \<epsilon>\<close>] elim!: bin_glue_blockE[OF \<open>us \<in> lists {x, y}\<close>])
+
+lemma prim_bin_glue:
+  assumes "us \<in> lists {x, y}" and "x \<noteq> \<epsilon>"
+      and "us = \<epsilon> \<or> last us \<noteq> x"
+  shows "primitive us \<Longrightarrow> primitive (glue x us)"
+  using prim_glue[OF \<open>us = \<epsilon> \<or> last us \<noteq> x\<close> unique_bin_glue_blocks[OF assms(1-2)]].
+
+end
diff --git a/thys/Combinatorics_Words_Graph_Lemma/Graph_Lemma.thy b/thys/Combinatorics_Words_Graph_Lemma/Graph_Lemma.thy
--- a/thys/Combinatorics_Words_Graph_Lemma/Graph_Lemma.thy
+++ b/thys/Combinatorics_Words_Graph_Lemma/Graph_Lemma.thy
@@ -1,449 +1,104 @@
-(*  Title:      CoW_Graph_Lemma.Graph_Lemma
+(*  Title:      Graph Lemma
+    File:       CoW_Graph_Lemma.Graph_Lemma
     Author:     Štěpán Holub, Charles University
-    Author:     Štěpán Starosta, CTU in Prague
+    Author:     Martin Raška, Charles University
+
+Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/
 *)
 
 theory Graph_Lemma
-  imports Combinatorics_Words.Submonoids
+  imports Combinatorics_Words.Submonoids Glued_Codes
 
 begin
 
 chapter \<open>Graph Lemma\<close>
 
 text\<open>The Graph Lemma is an important tool for gaining information about systems of word equations. 
 It yields an upper bound on the rank of the solution, that is, on the number of factors into all images of unknowns can be factorized.
 The most straightforward application is showing that a system of equations admits periodic solutions only, which
 in particular holds for any nontrivial equation over two words.
 
 The name refers to a graph whose vertices are the unknowns of the system, and edges connect front letters of the left- and right-
 hand sides of equations. The bound mentioned above is then the number of connected components of the graph.
 
-We formalize the algebraic proof from @{cite Berstel1979} \<close>
-
-text\<open>Let @{term C} be a set of generators, and $b$ its distinguished element. We define the set of all 
- products that do not start with $b$.\<close>
-
-inductive_set no_head :: "'a list set \<Rightarrow> 'a list \<Rightarrow> 'a list set"
-  for C b where
-  emp_in_no_head[simp]:  "\<epsilon> \<in> no_head C b"
-  | "u \<in> C \<Longrightarrow> u \<noteq> b \<Longrightarrow> u \<in> no_head C b" 
-  | "u \<noteq> \<epsilon> \<Longrightarrow> u \<in> no_head C b \<Longrightarrow> v \<in> \<langle>C\<rangle> \<Longrightarrow>  u \<cdot> v \<in> no_head C b"
-
-text\<open>The set is a submonoid of @{term "\<langle>C\<rangle>"}\<close>
-
-lemma no_head_sub: "no_head C b \<subseteq> \<langle>C\<rangle>"
-proof
-  fix u assume "u \<in> no_head C b"
-  show "u \<in> \<langle>C\<rangle>"
-  proof (induction rule: no_head.induct[OF \<open>u \<in> no_head C b\<close>], auto)
-    case (3 u v)
-    then show "u \<cdot> v \<in> \<langle>C\<rangle>"
-      using hull_closed by blast 
-  qed
-qed
-
-
-
-lemma no_head_closed:  "\<langle>no_head C b\<rangle> = no_head C b"
-proof(intro equalityI) 
-  show "no_head C b \<subseteq> \<langle>no_head C b\<rangle>" by (simp add: genset_sub) 
-next
-  show "\<langle>no_head C b\<rangle> \<subseteq> no_head C b"
-  proof
-    fix x assume "x \<in> \<langle>no_head C b\<rangle>"
-    thus "x \<in> no_head C b" 
-    proof (induction rule: hull.induct, simp)
-      case (prod_cl w1 w2)
-      then show "w1 \<cdot> w2 \<in> no_head C b"
-        using no_head.intros(3)[OF _ \<open>w1 \<in> no_head C b\<close>]
-          in_mono[OF no_head_sub, of w2] by fastforce
-    qed
-  qed
-qed
-
-text\<open>We are interested mainly in the situation when @{term C} is a code.\<close>
-
-context code
-begin
-
-text\<open>We characterize the set @{term no_head} in terms of the decomposition of its (nonempty) elements: the first factor is not b\<close>
-
-lemma no_head_hd: assumes "u \<in> no_head \<C> b" and "u \<noteq> \<epsilon>" shows "hd (Dec \<C> u) \<noteq> b"
-  using \<open>u \<noteq> \<epsilon>\<close> 
-proof(induct rule: no_head.induct[OF \<open>u \<in> no_head \<C> b\<close>], simp)
-  case (2 u)
-  then show ?case
-    using code_el_dec by auto
-next
-  case (3 u v)
-  have "Dec \<C> u \<noteq> \<epsilon>" and "u \<in> \<langle>\<C>\<rangle>" and "v \<in> \<langle>\<C>\<rangle>" 
-    using dec_nemp no_head_sub "3.hyps" by blast+
-  show "hd (Dec \<C> u \<cdot> v) \<noteq> b" 
-    using "3.hyps"(3)[OF \<open>u \<noteq> \<epsilon>\<close>] hd_append2[OF \<open>Dec \<C> u \<noteq> \<epsilon>\<close>, of "Dec \<C> v"] 
-    unfolding code_dec_morph[OF \<open> u \<in> \<langle>\<C>\<rangle>\<close> \<open>v \<in> \<langle>\<C>\<rangle>\<close>] by simp
-qed 
-
-lemma b_not_in_no_head: assumes "b \<in> \<C>" shows "b \<notin> no_head \<C> b"
-  using \<open>b \<in> \<C>\<close> code_el_dec emp_not_in_code no_head_hd by fastforce
+We formalize the algebraic proof from @{cite Berstel1979}. Key ingredients of the proof are in the theory @{theory Combinatorics_Words_Graph_Lemma.Glued_Codes}\<close>
 
-lemma hd_no_head: assumes "u \<in> \<langle>\<C>\<rangle>" and "hd (Dec \<C> u) \<noteq> b" shows "u \<in> no_head \<C> b"
-proof(cases "u \<noteq> \<epsilon>")
-  assume "u \<noteq> \<epsilon>"
-  have "Dec \<C> u \<noteq> \<epsilon>"
-    using dec_nemp'[OF \<open>u \<noteq> \<epsilon>\<close> \<open>u \<in> \<langle>\<C>\<rangle>\<close>].  
-  have "u = hd (Dec \<C> u) \<cdot> concat (tl (Dec \<C> u))"
-    using concat.simps(2)[of "hd (Dec \<C> u)" "tl(Dec \<C> u)"] 
-    unfolding hd_Cons_tl[OF \<open>Dec \<C> u \<noteq> \<epsilon>\<close>] decI[OF \<open>u \<in> \<langle>\<C>\<rangle>\<close>].
-  have "hd (Dec \<C> u) # tl (Dec \<C> u) \<in> lists \<C>" and "hd (Dec \<C> u) \<in> \<C>"
-    using \<open>Dec \<C> u \<noteq> \<epsilon>\<close> \<open>u \<in> \<langle>\<C>\<rangle>\<close> dec_dom' lists_hd by auto blast
-  have "concat (tl (decompose \<C> u)) \<in> \<langle>\<C>\<rangle>"
-    using concat_tl[of "hd (Dec \<C> u)" "tl(Dec \<C> u)" \<C>, OF \<open>hd (Dec \<C> u) # tl (Dec \<C> u) \<in> lists \<C>\<close>].
-  have "hd (Dec \<C> u) \<noteq> \<epsilon>" and "hd (Dec \<C> u) \<in> no_head \<C> b"
-    using no_head.intros(2)[OF \<open>hd (Dec \<C> u) \<in> \<C>\<close> \<open>hd (Dec \<C> u) \<noteq> b\<close>] \<open>hd (Dec \<C> u) \<in> \<C>\<close> emp_not_in_code by auto
-  from no_head.intros(3)[OF this \<open>concat (tl (decompose \<C> u)) \<in> \<langle>\<C>\<rangle>\<close> ] 
-  show "u \<in> no_head \<C> b"
-    unfolding sym[OF \<open>u = hd (Dec \<C> u) \<cdot> concat (tl (Dec \<C> u))\<close>].
-qed simp
+section \<open>Graph lemma\<close>
 
-corollary "no_head \<C> b = {u \<in> \<langle>\<C>\<rangle>. u = \<epsilon> \<or> hd (Dec \<C> u) \<noteq> b}"
-proof(intro equalityI subsetI, standard)
-  fix x assume  "x \<in> no_head \<C> b"
-  thus "x \<in> \<langle>\<C>\<rangle> \<and> (x = \<epsilon> \<or> hd (Dec \<C> x) \<noteq> b)"
-    using no_head_hd no_head_sub by blast
-next
-  fix x assume "x \<in> {u \<in> \<langle>\<C>\<rangle>. u = \<epsilon> \<or> hd (Dec \<C> u) \<noteq> b}"
-  thus "x \<in> no_head \<C> b"
-    using hd_no_head no_head.simps by blast 
-qed
-
-end
-
-text\<open>The set @{term no_head} is generated by the following set.\<close>
-
-inductive_set no_head_gen :: "'a list set \<Rightarrow> 'a list \<Rightarrow> 'a list set"
-  for C b where
-    "u \<in> C \<Longrightarrow> u \<noteq> b \<Longrightarrow> u \<in> no_head_gen C b" 
-  | "u \<in> no_head_gen C b \<Longrightarrow>  u \<cdot> b \<in> no_head_gen C b"
-
-lemma no_head_gen_set: "no_head_gen C b = {z \<cdot> b\<^sup>@k |z k. z \<in> C \<and> z \<noteq> b}"
-proof(intro equalityI subsetI)
-  fix x assume "x \<in> no_head_gen C b"
-  hence "\<exists> z k. z \<in> C \<and> z \<noteq> b \<and> x = z \<cdot> b\<^sup>@k" 
-  proof (rule no_head_gen.induct)
-    fix u assume "u \<in> C" and "u \<noteq> b"
-    show "\<exists>z k. z \<in> C \<and> z \<noteq> b \<and> u = z \<cdot> b\<^sup>@k"
-      using \<open>u \<in> C\<close> \<open>u \<noteq> b\<close> pow_zero by blast
-  next
-    fix u assume "u \<in> no_head_gen C b" and "\<exists>z k. z \<in> C \<and> z \<noteq> b \<and> u = z \<cdot> b\<^sup>@k"
-    thus "\<exists>z k. z \<in> C \<and> z \<noteq> b \<and> u \<cdot> b = z \<cdot> b\<^sup>@k"
-      using pow_Suc2_list append.assoc by metis         
+theorem graph_lemma_last: "\<BB>\<^sub>F G = {last (Dec (\<BB>\<^sub>F G) g) | g. g \<in> G \<and> g \<noteq> \<epsilon>}"
+proof
+  interpret code "\<BB>\<^sub>F G"
+    using free_basis_code.
+  \<comment> \<open>the core is to show that each element of the free basis must be a last of some word\<close>
+  show "\<BB>\<^sub>F G \<subseteq> {last (Dec \<BB>\<^sub>F G g) |g. g \<in> G \<and> g \<noteq> \<epsilon>}"
+  proof (rule ccontr)
+    \<comment> \<open>Assume the contrary.\<close>
+    assume "\<not> \<BB>\<^sub>F G \<subseteq> {last (Dec \<BB>\<^sub>F G g) |g. g \<in> G \<and> g \<noteq> \<epsilon>}"
+    \<comment> \<open>And let w be the not-last\<close>
+    then obtain w
+      where "w \<in> \<BB>\<^sub>F G" 
+        and hd_dec_neq: "\<And>g. g \<in> G \<Longrightarrow> g \<noteq> \<epsilon> \<Longrightarrow> last (Dec (\<BB>\<^sub>F G) g) \<noteq> w"
+      by blast
+    \<comment> \<open>For contradiction: We have a free hull which does not contain w but contains G.\<close>
+    have "G \<subseteq> \<langle>glued_gens w (\<BB>\<^sub>F G)\<rangle>"
+      by (blast intro!: gen_in_free_hull hd_dec_neq del: notI)
+    then have "\<langle>\<BB>\<^sub>F G\<rangle> \<subseteq> \<langle>glued_gens w (\<BB>\<^sub>F G)\<rangle>"
+      unfolding basis_gen_hull_free
+      by (intro code.free_hull_min glued_gens_code \<open>w \<in> \<BB>\<^sub>F G\<close>)
+    then show False
+      using \<open>w \<in> \<BB>\<^sub>F G\<close> glued_not_in_glued_hull by blast
   qed
-  thus "x \<in> {z \<cdot> b\<^sup>@k |z k. z \<in> C \<and> z \<noteq> b}"
-    by auto
-next
-  fix x assume "x \<in> {z \<cdot> b \<^sup>@ k |z k. z \<in> C \<and> z \<noteq> b}"
-  then obtain z k where "z \<in> C" and "z \<noteq> b" and "x = z\<cdot>b\<^sup>@k" by blast   
-  then show "x \<in> no_head_gen C b"
-  proof(induct k arbitrary: x)
-    case 0
-    then show ?case
-      by (simp add: \<open>z \<in> C\<close> \<open>z \<noteq> b\<close> no_head_gen.intros(1)) 
-  next
-    case (Suc k)
-    from this(1)[OF this(2) this(3), of "z \<cdot> b \<^sup>@ k", 
-        THEN no_head_gen.intros(2), unfolded rassoc, 
-        folded pow_Suc2_list[of b k] \<open>x = z\<cdot>b\<^sup>@Suc k\<close>]
-    show ?case
-      by blast      
-  qed
-qed
-
-lemma no_head_genE: assumes "u \<in> no_head_gen C b"
-  obtains z k where "z \<in> C" and  "z \<noteq> b" and "u = z \<cdot> b\<^sup>@k"
-proof(induct rule: no_head_gen.induct[OF assms])
-  case (1 u)
-  show ?case
-    using "1.prems"[OF "1.hyps", of 0] by simp  
-next
-  case (2 u)
-  have "(z \<cdot> b\<^sup>@k) \<cdot> b = z \<cdot> b\<^sup>@(Suc k)" for z k
-    by (simp add: power_commutes)  
-  then show ?case   
-    using "2.prems" "2.hyps"(2) by blast
-qed
-
-context code
-begin
-
-text\<open>We show that this indeed is a set of generators\<close>
-
-lemma emp_not_in_Cb: "\<epsilon> \<notin> no_head_gen \<C> b"
-  by (simp add: emp_not_in_code no_head_gen_set)
-
-lemma no_head_sub': "b \<in> \<C> \<Longrightarrow> no_head_gen \<C> b \<subseteq> no_head \<C> b"
-proof
-  fix u assume "b \<in> \<C>" "u \<in> no_head_gen \<C> b"
-  show "u \<in> no_head \<C> b"
-  proof (induction rule: no_head_gen.induct[OF \<open>u \<in> no_head_gen \<C> b\<close>], simp add: no_head.intros(2))
-    case (2 u)
-    show "u \<cdot> b \<in> no_head \<C> b"
-      using no_head.intros(3)[OF _ \<open>u \<in> no_head \<C> b\<close> gen_in[OF \<open>b \<in> \<C>\<close>]]
-       "2.hyps" emp_not_in_Cb by blast 
-  qed
+  \<comment> \<open>The opposite inclusion is easy\<close>
+  show "{last (Dec \<BB>\<^sub>F G g) |g. g \<in> G \<and> g \<noteq> \<epsilon>} \<subseteq> \<BB>\<^sub>F G"
+    by (auto intro!: dec_in_lists lists_hd_in_set[reversed] gen_in_free_hull del: notI)
 qed
 
-lemma no_head_generates0: assumes "v \<in> \<langle>\<C>\<rangle>" shows 
-  "u \<noteq> \<epsilon> \<longrightarrow> u \<in> \<langle>no_head_gen \<C> b\<rangle> \<longrightarrow> u \<cdot> v \<in>  \<langle>no_head_gen \<C> b\<rangle>"
-proof (induct arbitrary: u rule: hull.induct[OF \<open>v \<in> \<langle>\<C>\<rangle>\<close>], simp)
-  case (2 w1 w2)
-  then show ?case
-  proof(cases "w1 = b")
-    assume "w1 \<noteq> b" 
-    show ?thesis
-      using "2.hyps"(1) emp_not_in_code  no_head_gen.intros(1)[OF \<open>w1 \<in> \<C>\<close> \<open>w1 \<noteq> b\<close>,THEN gen_in]
-            "2.hyps"(3)[of w1] hull_closed[of u "no_head_gen \<C> b" "w1\<cdot> w2"] by blast
-  next 
-    assume "w1 = b"
-    show ?thesis
-    proof (standard, standard)
-      assume "u \<noteq> \<epsilon>" and "u \<in> \<langle>no_head_gen \<C> b\<rangle>"
-      hence dec_nemp: "Dec (no_head_gen \<C> b) u \<noteq> \<epsilon>"
-        using dec_nemp' by blast
-      from concat_butlast_last[OF this]
-      have u_w1: "u \<cdot> w1 = concat (butlast (Dec (no_head_gen \<C> b) u)) \<cdot> (last (Dec (no_head_gen \<C> b) u) \<cdot> w1)"
-        unfolding decI[OF \<open>u \<in> \<langle>no_head_gen \<C> b\<rangle>\<close>] by simp
-      from dec_dom'[OF \<open>u \<in> \<langle>no_head_gen \<C> b\<rangle>\<close>] append_butlast_last_id[OF dec_nemp]
-      have con_but: "concat (butlast (Dec (no_head_gen \<C> b) u)) \<in> \<langle>no_head_gen \<C> b\<rangle>" and last_in: "last (Dec (no_head_gen \<C> b) u) \<in> no_head_gen \<C> b"
-        using append_in_lists_conv[of "butlast (Dec (no_head_gen \<C> b) u)" "[last (Dec (no_head_gen \<C> b) u)]" "no_head_gen \<C> b"] 
-          concat_in_hull'[of "butlast (Dec (no_head_gen \<C> b) u)" "no_head_gen \<C> b"] by auto 
-      hence "last (Dec (no_head_gen \<C> b) u) \<cdot> w1 \<in> no_head_gen \<C> b"
-        unfolding \<open>w1 = b\<close> using  no_head_gen.intros(2)[of "last (Dec (no_head_gen \<C> b) u)" \<C> b] by blast
-      from this[THEN  gen_in,THEN[2] hull_closed, OF con_but]
-      have "u \<cdot> w1 \<in> \<langle>no_head_gen \<C> b\<rangle>"
-        unfolding u_w1.
-      from "2.hyps"(3)[rule_format, OF _ this, unfolded rassoc]
-      show "u \<cdot> w1 \<cdot> w2 \<in> \<langle>no_head_gen \<C> b\<rangle>"
-        using  pref_nemp[OF \<open>u\<noteq>\<epsilon>\<close>] by blast
-    qed
-  qed
-qed
-
-
-theorem no_head_generates: assumes "b \<in> \<C>" shows "\<langle>no_head_gen \<C> b\<rangle> =  no_head \<C> b"
-proof (intro equalityI)  
-  show "\<langle>no_head_gen \<C> b\<rangle> \<subseteq> no_head \<C> b"
-    using hull_mon[OF no_head_sub'[OF \<open>b \<in> \<C>\<close>]] unfolding no_head_closed.  
-  show "no_head \<C> b \<subseteq> \<langle>no_head_gen \<C> b\<rangle>"
-  proof (intro subsetI)
-    fix x assume "x \<in> no_head \<C> b" 
-    show "x \<in> \<langle>no_head_gen \<C> b\<rangle>"
-      by (induct rule: no_head.induct[OF \<open>x \<in> no_head \<C> b\<close>],auto, simp add: gen_in no_head_gen.intros(1),simp add: no_head_generates0)
-  qed
-qed
-
-text\<open>Moreover, the generating set @{term no_head_gen} is a code\<close>
-
-lemma lists_no_head_sub: "b \<in> \<C> \<Longrightarrow> us \<in> lists (no_head_gen \<C> b) \<Longrightarrow> us \<in> lists \<langle>\<C>\<rangle>"
-  using no_head_sub' no_head_sub by blast   
-
-lemma ref_hd: assumes "z \<in> \<C>" and  "b \<in> \<C>" and "z \<noteq> b" and "vs \<in> lists (no_head_gen \<C> b)" 
-  shows "refine \<C> ((z\<cdot>b\<^sup>@k) # vs) = [z]\<cdot>[b]\<^sup>@k \<cdot> refine \<C> vs" 
-proof-
-  have "refine \<C> ((z\<cdot>b\<^sup>@k) # vs) = (Dec \<C> (z\<cdot>b\<^sup>@k)) \<cdot> refine \<C> vs" 
-    using ref_pop_hd lists_no_head_sub[OF \<open>b \<in> \<C>\<close>]  by simp 
-  have "[z]\<cdot>[b]\<^sup>@k \<in> lists \<C>"
-    by (induct k, simp add: \<open>z \<in> \<C>\<close>, simp add: \<open>b \<in> \<C>\<close>)
-  have "concat ([z]\<cdot>[b]\<^sup>@k) = z \<cdot> b\<^sup>@k"
-    using concat_sing_pow by auto
-  hence "Dec \<C> (z\<cdot>b\<^sup>@k) = [z]\<cdot>[b]\<^sup>@k"
-    using  code.code_unique_dec[OF code_axioms \<open>[z]\<cdot>[b]\<^sup>@k \<in> lists \<C>\<close>] by auto
-  thus ?thesis
-    by simp
-qed
-
-
-lemma no_head_gen_code_ind_step:
-  assumes "vs \<in> lists (no_head_gen \<C> b)" "us \<in> lists (no_head_gen \<C> b)" "b \<in> \<C>"
-    and eq: "[b]\<^sup>@ku \<cdot> (refine \<C> us) = [b]\<^sup>@kv \<cdot> (refine \<C> vs)"
-  shows  "ku = kv"
-proof-
-  {fix ku :: nat and kv and us and vs and b 
-    assume "kv \<le> ku" "[b]\<^sup>@ku \<cdot> (refine \<C> us) = [b]\<^sup>@kv \<cdot> (refine \<C> vs)"
-      "vs \<in> lists (no_head_gen \<C> b)" "us \<in> lists (no_head_gen \<C> b)" "b \<in> \<C>"
-    have  "concat vs \<in> no_head \<C> b"
-      using  \<open>vs \<in> lists (no_head_gen \<C> b)\<close> no_head_generates[OF \<open>b \<in> \<C>\<close>] by fastforce
-    have  "Ref \<C> vs = Dec \<C> (concat vs)"
-      using \<open>vs \<in> lists (no_head_gen \<C> b)\<close> \<open>b \<in> \<C>\<close> code_unique_ref lists_no_head_sub by auto
-    have "vs \<noteq> \<epsilon> \<Longrightarrow> concat vs \<noteq> \<epsilon>"
-      using  emp_not_in_Cb[of b] concat.simps(2) \<open>vs \<in> lists (no_head_gen \<C> b)\<close>[unfolded lists.simps[of vs]]
-        pref_nemp by auto 
-    have "[b]\<^sup>@(ku - kv) \<cdot> (refine \<C> us) = refine \<C> vs"
-      using \<open>kv \<le> ku\<close> eq pop_pow_cancel \<open>[b]\<^sup>@ku \<cdot> (refine \<C> us) = [b]\<^sup>@kv \<cdot> (refine \<C> vs) \<close>by blast
-    hence "ku - kv \<noteq> 0 \<Longrightarrow> hd (refine \<C> vs) = b \<and> vs \<noteq> \<epsilon>"
-      using hd_append2[of "[b]\<^sup>@(ku - kv)" "refine \<C> us"]  \<open>[b]\<^sup>@(ku - kv) \<cdot> (refine \<C> us) = refine \<C> vs\<close>
-        hd_sing_power[of "ku - kv" b] 
-        append_is_Nil_conv[of "[b]\<^sup>@(ku - kv)" "refine \<C> us"]  sing_pow_empty[of b "ku - kv"]
-        dec_emp[of \<C>] by auto 
-    hence "ku = kv"
-      using \<open>kv \<le> ku\<close> no_head_hd[OF \<open>concat vs \<in> no_head \<C> b\<close>] \<open>vs \<noteq> \<epsilon> \<Longrightarrow> concat vs \<noteq> \<epsilon>\<close> 
-      unfolding \<open>Ref \<C> vs = Dec \<C> (concat vs)\<close> by auto} 
-  thus ?thesis  using assms nat_le_linear[of ku kv] by metis
-qed 
-
-lemma no_head_gen_code':
-  "b \<in> \<C> \<Longrightarrow> xs \<in> lists (no_head_gen \<C> b) 
-   \<Longrightarrow> ys \<in>  lists (no_head_gen \<C> b) \<Longrightarrow> concat xs = concat ys \<Longrightarrow> xs = ys"
-proof (induct xs ys rule: list_induct2', simp, simp add: emp_not_in_Cb, simp add: emp_not_in_Cb)
-  case (4 hx xs hy ys)
-  then show ?case 
-  proof-
-    have "hx # xs \<in> lists \<langle>\<C>\<rangle>" and "hy # ys \<in> lists \<langle>\<C>\<rangle>"
-      using \<open>b \<in> \<C>\<close>  \<open>hx # xs \<in> lists (no_head_gen \<C> b)\<close> \<open>hy # ys \<in> lists (no_head_gen \<C> b)\<close> lists_no_head_sub by blast+
-    have eq: "refine \<C> (hx#xs) = refine \<C>  (hy#ys)"
-      using \<open>concat (hx # xs) = concat (hy # ys)\<close> \<open>hx # xs \<in> lists \<langle>\<C>\<rangle>\<close> \<open>hy # ys \<in> lists \<langle>\<C>\<rangle>\<close>
-      using code_unique_ref by presburger 
-    have "hx \<in> (no_head_gen \<C> b)" and "hy \<in> (no_head_gen \<C> b)"
-      using \<open>hx # xs \<in> lists (no_head_gen \<C> b)\<close> \<open>hy # ys \<in> lists (no_head_gen \<C> b)\<close> by auto+
-    then obtain zx zy kx ky where "hx = zx \<cdot> b\<^sup>@kx" and "hy = zy \<cdot> b\<^sup>@ky" "zx \<noteq> b" "zy \<noteq> b" "zx \<in> \<C>" "zy \<in> \<C>"
-      using no_head_genE by metis
-    have r1: "refine \<C> (hx#xs) = [zx] \<cdot> [b]\<^sup>@kx \<cdot> refine \<C> xs"
-      using \<open>hx = zx \<cdot> b\<^sup>@kx\<close> \<open>zx \<in> \<C>\<close> \<open>zx \<noteq> b\<close> ref_hd \<open>b \<in> \<C>\<close> by auto
-    have r2: "refine \<C> (hy#ys) = [zy] \<cdot> [b]\<^sup>@ky \<cdot> refine \<C> ys"
-      using \<open>hy = zy \<cdot> b\<^sup>@ky\<close> \<open>zy \<in> \<C>\<close> \<open>zy \<noteq> b\<close> ref_hd \<open>b \<in> \<C>\<close> by auto
-    hence "zx = zy"
-      using r1 r2 eq by auto
-    hence "[b]\<^sup>@kx \<cdot> refine \<C> xs = [b]\<^sup>@ky \<cdot> refine \<C> ys"
-      using eq r1 r2 by auto 
-    hence "kx = ky" 
-      using no_head_gen_code_ind_step \<open>b \<in> \<C>\<close> \<open>hx # xs \<in> lists (no_head_gen \<C> b)\<close> \<open>hy # ys \<in> lists (no_head_gen \<C> b)\<close> 
-        listsE  by metis 
-    hence "hx = hy"
-      by (simp add: \<open>hx = zx \<cdot> b\<^sup>@kx\<close> \<open>hy = zy \<cdot> b\<^sup>@ky\<close> \<open>zx = zy\<close>)
-    hence "xs = ys" using "4.hyps" 
-      using \<open>hx # xs \<in> lists (no_head_gen \<C> b)\<close> \<open>hy # ys \<in> lists (no_head_gen \<C> b)\<close> 
-        \<open>concat (hx # xs) = concat (hy # ys)\<close> \<open>b \<in> \<C>\<close> by auto
-    thus ?thesis
-      by (simp add: \<open>hx = hy\<close>) 
-  qed
-qed  
-
-end
-
-theorem no_head_gen_code:
-  assumes "code C" and "b \<in> C"
-  shows "code {z \<cdot> b\<^sup>@k | z k. z \<in> C \<and> z \<noteq> b}"
-  using code.no_head_gen_code'[OF \<open>code C\<close> \<open>b \<in> C\<close>] code.intro
-  unfolding no_head_gen_set  by blast
-
-text\<open>We are now ready to prove the Graph Lemma \<close>
-
-theorem graph_lemma: "\<BB>\<^sub>F X = {hd (Dec (\<BB>\<^sub>F X) x) | x. x \<in> X \<and> x \<noteq> \<epsilon>}"
-proof 
-  \<comment> \<open>the core is to show that each element of the free basis must be a head\<close>
-  show "\<BB>\<^sub>F X \<subseteq> {hd (Dec (\<BB>\<^sub>F X) x) | x. x \<in> X \<and> x \<noteq> \<epsilon>}"
-  proof (rule ccontr)
-    \<comment> \<open>Assume the contrary.\<close>
-     assume "\<not> \<BB>\<^sub>F X \<subseteq> {hd (Dec \<BB>\<^sub>F X x) |x. x \<in> X \<and> x \<noteq> \<epsilon>}"  
-    \<comment> \<open>And let b be the not-head\<close>
-    then obtain b where "b \<in> \<BB>\<^sub>F X" and nohd: "\<And> x.   x \<in> X \<and> x \<noteq> \<epsilon> \<Longrightarrow> hd (Dec (\<BB>\<^sub>F X) x) \<noteq> b"
-      by blast
-    interpret code "\<BB>\<^sub>F X"
-        using free_basis_code by auto
-          \<comment> \<open>For contradiction: We have a free hull which does not contain b but contains X.\<close>
-      let ?Cb = "no_head_gen (\<BB>\<^sub>F X) b"
-      have "code ?Cb"
-        using \<open>b \<in> \<BB>\<^sub>F X\<close> code_def no_head_gen_code' by blast 
-      have "b \<notin> \<langle>?Cb\<rangle>"
-        using \<open>b \<in> \<BB>\<^sub>F X\<close> b_not_in_no_head no_head_generates by blast
-      have "X \<subseteq> \<langle>?Cb\<rangle>"
-      proof
-        fix x assume "x \<in> X" 
-        hence "x \<in> \<langle>\<BB>\<^sub>F X\<rangle>"
-          using basis_gen_hull free_hull.free_gen_in 
-          unfolding free_basis_def by blast
-        have " x \<in> X \<and> x \<noteq> \<epsilon> \<Longrightarrow> x \<in> \<langle>?Cb\<rangle>"
-          using hd_no_head[OF \<open>x \<in> \<langle>\<BB>\<^sub>F X\<rangle>\<close> nohd]
-            \<open>b \<in> \<BB>\<^sub>F X\<close> no_head_generates by blast
-        thus "x \<in> \<langle>?Cb\<rangle>"
-          using \<open>x \<in> X\<close> by blast 
-      qed
-      have "\<langle>X\<rangle>\<^sub>F \<subseteq> \<langle>?Cb\<rangle>" 
-        using free_hull_min[OF \<open>code ?Cb\<close> \<open>X \<subseteq> \<langle>?Cb\<rangle>\<close>].
-      from this[unfolded subset_eq, rule_format, of b]
-      show False
-        using \<open>b \<in> \<BB>\<^sub>F X\<close> \<open>b \<notin> \<langle>?Cb\<rangle>\<close> basisD simp_el_el unfolding free_basis_def by blast
-  qed
-next
-  \<comment> \<open>The opposite inclusion is easy\<close>
-  show "{hd (Dec (\<BB>\<^sub>F X) x) | x.  x \<in> X \<and> x \<noteq> \<epsilon>} \<subseteq> \<BB>\<^sub>F X"
-    using basis_gen_hull_free dec_hd genset_sub_free by blast
+theorem graph_lemma: "\<BB>\<^sub>F G = {hd (Dec (\<BB>\<^sub>F G) g) | g. g \<in> G \<and> g \<noteq> \<epsilon>}"
+proof -
+  have *: "rev u = last (Dec rev ` (\<BB>\<^sub>F G) (rev g)) \<and> g \<in> G \<and> g \<noteq> \<epsilon>
+           \<longleftrightarrow> u = hd (Dec (\<BB>\<^sub>F G) g) \<and> g \<in> G \<and> g \<noteq> \<epsilon>" for u g
+    by (cases "g \<in> G \<and> g \<noteq> \<epsilon>") (simp add: gen_in_free_hull last_rev hd_map code.dec_rev, blast)
+  show ?thesis
+    using graph_lemma_last[reversed, of G] unfolding *.
 qed
 
 section \<open>Binary code\<close>
 
-text\<open>We illustrate the use of the Graph Lemma in an alternative proof of the fact that two non-commuting words form a code.
+text \<open>We illustrate the use of the Graph Lemma in an alternative proof of the fact that two non-commuting words form a code.
 See also @{thm no_comm_bin_code [no_vars]} in @{theory Combinatorics_Words.CoWBasic}.
 
-First, we prove a lemma which is the core of the alternative proof.
-\<close>
+First, we prove a lemma which is the core of the alternative proof.\<close>
 
 lemma non_comm_hds_neq: assumes "u \<cdot> v \<noteq> v \<cdot> u" shows "hd (Dec \<BB>\<^sub>F {u,v} u) \<noteq> hd (Dec \<BB>\<^sub>F {u,v} v)"
-proof
-  have "u \<noteq> \<epsilon>" and "v \<noteq> \<epsilon>" using assms by auto
-  hence basis: "\<BB>\<^sub>F {u,v} = {hd (Dec \<BB>\<^sub>F {u,v} u),hd (Dec \<BB>\<^sub>F {u,v} v)}"
-    using graph_lemma[of "{u,v}"] by blast
-  assume eq: "hd (Dec \<BB>\<^sub>F {u,v} u) = hd (Dec \<BB>\<^sub>F {u,v} v)"
-  hence "u \<in> (hd (Dec \<BB>\<^sub>F {u,v} u))*" 
-    using basis unfolding free_basis_def
-    by (metis basis_gen_hull free_hull.simps free_hull_hull insertI1 insert_absorb2 sing_gen)
-  moreover have  "v \<in> (hd (Dec \<BB>\<^sub>F {u,v} u))*"
-    using basis eq unfolding free_basis_def
-    by (metis basis_gen_hull free_hull_hull genset_sub_free insert_absorb2 insert_subset sing_gen) 
-  ultimately show False
-    using comm_root assms by blast
+using assms proof (rule contrapos_nn)
+  assume hds_eq: "hd (Dec \<BB>\<^sub>F {u,v} u) = hd (Dec \<BB>\<^sub>F {u,v} v)"
+  have **: "\<BB>\<^sub>F {u,v} = {hd (Dec \<BB>\<^sub>F {u,v} u)}"
+    using graph_lemma by (rule trans) (use assms in \<open>auto intro: hds_eq[symmetric]\<close>)
+  show "u \<cdot> v = v \<cdot> u"
+    by (intro comm_rootI[of _ "hd (Dec \<BB>\<^sub>F {u,v} u)"] sing_gen)
+       (simp_all add: **[symmetric] gen_in_free_hull)
 qed
 
-theorem assumes "u \<cdot> v \<noteq> v \<cdot> u" 
-  shows "xs \<in> lists {u, v} \<Longrightarrow> ys \<in> lists {u, v} \<Longrightarrow> concat xs = concat ys \<Longrightarrow> xs = ys"
-proof (induct xs ys rule: list_induct2', simp)
-  case (2 x xs)
-  then show ?case
-    using Nil_is_append_conv append_Nil assms by auto 
-next
-  case (3 y ys)
-  then show ?case
-    using Nil_is_append_conv append_Nil assms by auto 
-next
-  case (4 x xs y ys)
-  then show ?case
-  proof-
-    have "u \<noteq> \<epsilon>" and "v \<noteq> \<epsilon>" using assms by force+
-    hence "x \<noteq> \<epsilon>" and "y \<noteq> \<epsilon>" using \<open>x # xs \<in> lists {u, v}\<close> \<open>y # ys \<in> lists {u, v}\<close> by auto
-    have or_x: "x = u \<or> x = v" and or_y: "y = u \<or> y = v" using \<open>x # xs \<in> lists {u, v}\<close> \<open>y # ys \<in> lists {u, v}\<close> by auto
-
-    have hd_z: "z \<noteq> \<epsilon> \<Longrightarrow> z # zs \<in> lists {u, v} \<Longrightarrow> hd (Dec \<BB>\<^sub>F {u,v} (concat (z#zs))) = hd (Dec \<BB>\<^sub>F {u,v} z)" for z zs
-    proof-
-      assume "z \<noteq> \<epsilon>" "z # zs \<in> lists {u, v}"
-      have "z \<in> \<langle>{u,v}\<rangle>\<^sub>F"
-        using \<open>z # zs \<in> lists {u, v}\<close> by auto
-      moreover have "concat zs \<in> \<langle>{u,v}\<rangle>\<^sub>F"
-        using concat_tl[OF \<open>z # zs \<in> lists {u, v}\<close>] hull_in_free_hull[of "{u,v}"] by blast 
-      ultimately have "Dec \<BB>\<^sub>F {u,v} (concat (z#zs)) = (Dec \<BB>\<^sub>F {u,v} z) \<cdot> (Dec \<BB>\<^sub>F {u,v} (concat zs))"
-        using free_basis_dec_morph[of z "{u,v}" "concat zs"] by fastforce
-      moreover have "Dec \<BB>\<^sub>F {u,v} z \<noteq> \<epsilon>"
-        using \<open>z \<in> \<langle>{u, v}\<rangle>\<^sub>F\<close> basis_gen_hull_free dec_nemp'[OF  \<open>z \<noteq> \<epsilon>\<close>] by blast
-      ultimately show "hd (Dec \<BB>\<^sub>F {u,v} (concat (z#zs))) = hd (Dec \<BB>\<^sub>F {u,v} z)"
-        using hd_append  by simp
-    qed
-    
-    have "hd (Dec \<BB>\<^sub>F {u,v} u) \<noteq> hd (Dec \<BB>\<^sub>F {u,v} v)" 
-      using non_comm_hds_neq[OF assms].
-    hence "x  = y"
-      using hd_z[OF \<open>x \<noteq> \<epsilon>\<close> \<open>x # xs \<in> lists {u, v}\<close> , unfolded \<open>concat (x # xs) = concat (y # ys)\<close> hd_z[OF \<open>y \<noteq> \<epsilon>\<close> \<open>y # ys \<in> lists {u, v}\<close>]] or_x or_y 
-      by fastforce
-    thus ?thesis
-      using "4.hyps" "4.prems" by auto 
-  qed
+theorem assumes "u \<cdot> v \<noteq> v \<cdot> u" shows "code {u, v}"
+proof
+  have *: "w \<in> {u, v} \<Longrightarrow> w \<noteq> \<epsilon>" for w
+    using \<open>u \<cdot> v \<noteq> v \<cdot> u\<close> by blast
+  fix xs ys
+  show "xs \<in> lists {u, v} \<Longrightarrow> ys \<in> lists {u, v} \<Longrightarrow> concat xs = concat ys \<Longrightarrow> xs = ys"
+  proof (induction xs ys rule: list_induct2')
+    case (4 x xs y ys)
+      have **: "hd (Dec \<BB>\<^sub>F {u,v} (concat (z # zs))) = hd (Dec \<BB>\<^sub>F {u,v} z)"
+        if "z # zs \<in> lists {u, v}" for z zs
+        using that by (elim listsE) (simp del: insert_iff
+          add: concat_in_hull' gen_in set_mp[OF hull_sub_free_hull]
+               free_basis_dec_morph * basis_gen_hull_free) 
+      have "hd (Dec \<BB>\<^sub>F {u,v} x) = hd (Dec \<BB>\<^sub>F {u,v} y)"
+        using "4.prems" by (simp only: **[symmetric])
+      then have "x = y"
+        using "4.prems"(1-2) non_comm_hds_neq[OF \<open>u \<cdot> v \<noteq> v \<cdot> u\<close>]
+        by (elim listsE insertE emptyE) simp_all
+      with 4 show "x # xs = y # ys" by simp
+  qed (simp_all add: *)
 qed
 
-end
\ No newline at end of file
+end
diff --git a/thys/Combinatorics_Words_Graph_Lemma/ROOT b/thys/Combinatorics_Words_Graph_Lemma/ROOT
--- a/thys/Combinatorics_Words_Graph_Lemma/ROOT
+++ b/thys/Combinatorics_Words_Graph_Lemma/ROOT
@@ -1,9 +1,10 @@
 chapter AFP
 
 session Combinatorics_Words_Graph_Lemma (AFP) = Combinatorics_Words +
   options [timeout = 300]
   theories
+    Glued_Codes
     Graph_Lemma
   document_files
     root.tex
     root.bib
diff --git a/thys/Combinatorics_Words_Lyndon/Lyndon.thy b/thys/Combinatorics_Words_Lyndon/Lyndon.thy
--- a/thys/Combinatorics_Words_Lyndon/Lyndon.thy
+++ b/thys/Combinatorics_Words_Lyndon/Lyndon.thy
@@ -1,858 +1,866 @@
 (*  Title:      CoW_Lyndon.Lyndon
     Author:     Štěpán Holub, Charles University
     Author:     Štěpán Starosta, CTU in Prague
+
+Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/
 *)
 theory Lyndon
   imports Combinatorics_Words.CoWBasic
 begin
 
 chapter "Lyndon words"
 
 text\<open>A Lyndon word is a non-empty word that is lexicographically 
 strictly smaller than any other word in its conjugacy class, i.e., than any its rotations.
 They are named after R. Lyndon who introduced them in @{cite Lyndon54} as ``standard'' sequences.
 
-We present elementary results on Lyndon words, mostly covered by results in @{cite \<open>Chapter 5\<close> Lo83
-} and @{cite Duval80 and Duval83}.
+We present elementary results on Lyndon words, mostly covered by results in @{cite \<open>Chapter 5\<close> Lo83} and @{cite Duval80 and Duval83}.
 
 This definition assumes a linear order on letters given by the context.
 \<close>
 
 
 section "Definition and elementary properties"
 
 subsection "Underlying order"
 
 lemma (in linorder) lexordp_mid_pref: "ord_class.lexordp u v \<Longrightarrow> ord_class.lexordp v (u\<cdot>s) \<Longrightarrow>
    u \<le>p v"
   by (induct rule: lexordp_induct, simp_all)
 
 lemma (in linorder) lexordp_ext: "ord_class.lexordp u v \<Longrightarrow>  \<not> u \<le>p v \<Longrightarrow> 
   ord_class.lexordp (u\<cdot>w) (v\<cdot>z)"
   by (induct rule: lexordp_induct, simp_all)                         
 
 lemmas [code] = lexordp_simps
 
 context linorder
 begin
 
 abbreviation Lyndon_less :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" (infixl "<lex" 50)
   where "Lyndon_less xs ys \<equiv> ord_class.lexordp xs ys"
 
 abbreviation Lyndon_le :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool" (infixl "\<le>lex" 50)
   where "Lyndon_le xs ys \<equiv> ord_class.lexordp_eq xs ys"
 
 interpretation rlex: linorder "(\<le>lex)" "(<lex)" 
   using lexordp_linorder.
 
 interpretation dual_rlex: linorder "\<lambda> x y. y \<le>lex x" "\<lambda> x y. y <lex x" 
   using rlex.dual_linorder.
 
 lemma sorted_dual_rev_iff: "dual_rlex.sorted ws \<longleftrightarrow> rlex.sorted (rev ws)"
   unfolding rlex.sorted_rev_iff_nth_mono dual_rlex.sorted_iff_nth_mono by blast 
 
 text \<open>Several useful lemmas that are formulated for relations, interpreted for the default linear order.\<close>
 
 lemmas lexord_suf_linorder = lexord_sufE[of _ _ _ _ "{(x, y). x < y}", folded lexordp_conv_lexord]
   and lexord_append_leftI_linorder = lexord_append_leftI[of  _ _  "{(x, y). x < y}" _, folded lexordp_conv_lexord]
   and lexord_app_right_linorder = lexord_sufI[of  _ _  "{(x, y). x < y}" _, folded lexordp_conv_lexord]
   and lexord_take_index_conv_linorder = lexord_take_index_conv[of  _ _  "{(x, y). x < y}", folded lexordp_conv_lexord]
   and mismatch_lexord_linorder = mismatch_lexord[of  _ _  "{(x, y). x < y}", folded lexordp_conv_lexord]
   and lexord_cancel_right_linorder = lexord_cancel_right[of _ _ _ _ "{(a,b). a < b}", folded lexordp_conv_lexord]
 
 subsection "Lyndon word definition"
 
 fun Lyndon :: "'a list \<Rightarrow> bool"
   where "Lyndon w = (w \<noteq> \<epsilon> \<and> (\<forall>n. 0 < n \<and> n < \<^bold>|w\<^bold>| \<longrightarrow> w <lex rotate n w))"
 
 lemma LyndonD: "Lyndon w \<Longrightarrow> 0 < n \<Longrightarrow> n < \<^bold>|w\<^bold>| \<Longrightarrow> w <lex rotate n w"
   unfolding Lyndon.simps by blast
 
 lemma LyndonD_nemp: "Lyndon w \<Longrightarrow> w \<noteq> \<epsilon>"
   unfolding Lyndon.simps by blast
 
 lemma LyndonI: "w \<noteq> \<epsilon> \<Longrightarrow> \<forall> n. 0 < n \<and> n < \<^bold>|w\<^bold>| \<longrightarrow> w <lex rotate n w \<Longrightarrow>  Lyndon w"
   unfolding  Lyndon.simps by blast
 
 lemma Lyndon_sing: "Lyndon [a]" 
   unfolding Lyndon.simps by auto
 
 lemma Lyndon_prim: assumes "Lyndon w"
   shows "primitive w"
 proof-
   have "0 < n \<Longrightarrow> n < \<^bold>|w\<^bold>| \<Longrightarrow> rotate n w \<noteq> w" for n
     using LyndonD[OF \<open>Lyndon w\<close>, of n] rlex.less_irrefl[of w] by argo
   from no_rotate_prim[OF LyndonD_nemp[OF \<open>Lyndon w\<close>]] this
   show ?thesis by blast
 qed
 
 lemma Lyndon_conj_greater: "Lyndon (u\<cdot>v) \<Longrightarrow> u \<noteq> \<epsilon> \<Longrightarrow> v \<noteq> \<epsilon> \<Longrightarrow> u\<cdot>v <lex v\<cdot>u"
   using LyndonD[of "u\<cdot>v" "\<^bold>|u\<^bold>|", unfolded rotate_append[of u v]] 
   by force
 
 subsection "Code equations for Lyndon words"
 
 primrec Lyndon_rec :: "'a list \<Rightarrow> nat \<Rightarrow> bool" where
     "Lyndon_rec w 0 = True" |
     "Lyndon_rec w (Suc n) = (if w <lex rotate (Suc n) w then Lyndon_rec w n else False)"
 
 lemma Lyndon_rec_all: assumes "Lyndon_rec (a # w) (\<^bold>|w\<^bold>|)"
   shows "n < \<^bold>|a#w\<^bold>| \<Longrightarrow> 0 < n \<Longrightarrow> Lyndon_rec (a#w) n"
 proof(induction n rule: strict_inc_induct)
   case (base i)
   then show ?case
     using assms by auto
 next
   case (step i)
   then show ?case
     by (meson Lyndon_rec.simps(2) zero_less_Suc)
 qed
 
 lemma Lyndon_Lyndon_rec: assumes "Lyndon w"
   shows "0 < n \<Longrightarrow> n < \<^bold>|w\<^bold>| \<Longrightarrow> Lyndon_rec w n"
 proof(induction n, simp)
   case (Suc n)
   have "w <lex rotate (Suc n) w"
     using LyndonD Suc.prems(2) assms by blast
   then show ?case
     using Suc.IH[OF _ Suc_lessD[OF \<open>Suc n < \<^bold>|w\<^bold>|\<close>], folded neq0_conv] Lyndon_rec.simps(1)[of w] 
     unfolding Lyndon_rec.simps(2)
     by metis
 qed
 
 lemma Lyndon_code [code]:
     "Lyndon Nil = False" 
     "Lyndon (a # w) = Lyndon_rec (a # w) (\<^bold>|w\<^bold>|)"
 proof-
   show "Lyndon Nil = False" by simp
   have "a # w \<noteq> \<epsilon>"
     by simp
   have ax: "0 < n \<Longrightarrow> Lyndon_rec (a#w) n \<Longrightarrow> (a#w) <lex rotate n (a#w)" for n
     using Lyndon_rec.simps(2)[of "a#w"] gr0_implies_Suc[of n] by metis
   have bx: "Lyndon_rec (a # w) (\<^bold>|w\<^bold>|) = (\<forall>n. n < \<^bold>|a#w\<^bold>| \<and> 0 < n \<longrightarrow> Lyndon_rec (a#w) n)"
   proof(cases "w = \<epsilon>", simp)
     assume "w \<noteq> \<epsilon>"
     from this[folded length_greater_0_conv]
     show ?thesis
       using Lyndon_rec_all[of a w] length_Cons[of a w] lessI[of "\<^bold>|w\<^bold>|"]
       by fastforce
   qed
   show "Lyndon (a # w) = Lyndon_rec (a # w) \<^bold>|w\<^bold>|"
     unfolding bx Lyndon.simps
     using ax  LyndonI[OF \<open>a # w \<noteq> \<epsilon>\<close>]Lyndon_Lyndon_rec by blast
 qed
 
 subsection "Properties of Lyndon words"
 
 subsubsection "Lyndon words are unbordered"
 
 theorem Lyndon_unbordered: assumes "Lyndon w" shows "\<not> bordered w"
 proof
   assume "bordered w"
   from bordered_dec[OF this]
   obtain u v where "u\<cdot>v\<cdot>u = w" and "u \<noteq> \<epsilon>". 
   hence "v \<cdot> u \<noteq> \<epsilon>" and "u \<cdot> v \<noteq> \<epsilon>" by blast+
   note lyn = \<open>Lyndon w\<close>[folded  \<open>u\<cdot>v\<cdot>u = w\<close>] 
   have "u\<cdot>v\<cdot>u <lex v\<cdot>u\<cdot>u"
     using Lyndon_conj_greater[of u "v\<cdot>u", OF lyn \<open>u \<noteq> \<epsilon>\<close> \<open>v \<cdot> u \<noteq> \<epsilon>\<close>, unfolded rassoc].
   from this[unfolded lassoc]
   have "u \<cdot> v \<noteq> v \<cdot> u" 
     by force
   from lexord_suf_linorder[OF _ this, of u u]
   have "u\<cdot>v <lex v\<cdot>u" 
     using  \<open>u\<cdot>v\<cdot>u <lex v\<cdot>u\<cdot>u\<close>  by simp
   from lexord_append_leftI_linorder[of  "u\<cdot>v" "v\<cdot>u", unfolded lassoc, OF this, unfolded rassoc]
   have "u\<cdot>u\<cdot>v <lex u\<cdot>v\<cdot>u".
   from this Lyndon_conj_greater[of "u\<cdot>v" u, unfolded rassoc, OF lyn \<open>u \<cdot> v \<noteq> \<epsilon>\<close>  \<open>u \<noteq> \<epsilon>\<close>]
   show False 
     by simp
 qed
 
 subsubsection "Each conjugacy class contains a Lyndon word"
 
 lemma conjug_Lyndon_ex: assumes "primitive w"
   obtains n where "Lyndon (rotate n w)"
 proof-
   have "w \<noteq> \<epsilon>"
     using  prim_nemp[OF \<open>primitive w\<close>].
 
   let ?ConClass = "{rotate n w | n. 0 \<le> n \<and> n < \<^bold>|w\<^bold>|}"
 
   have "?ConClass \<noteq> {}"
     using \<open>w \<noteq> \<epsilon>\<close> by blast 
   have "w \<in> ?ConClass"
     using \<open>w \<noteq> \<epsilon>\<close> id_apply[of w, folded rotate0]
     by force
   have "finite ?ConClass"
     by simp
   have all_rot: "rotate m w \<in> ?ConClass" for m
     using rotate_conv_mod[of _ w] mod_less_divisor[of "\<^bold>|w\<^bold>|"] \<open>w \<noteq> \<epsilon>\<close>
     by blast
 
   obtain w' n where "w' \<in> ?ConClass" and all_b: "\<forall> b \<in> ?ConClass. b \<le>lex w' \<longrightarrow> w' = b" and w': "w' = rotate n w"
     using rlex.finite_has_minimal[OF \<open>finite ?ConClass\<close> \<open>?ConClass \<noteq> {}\<close>] by auto 
 
   have "rotate n w <lex rotate na (rotate n w)" if  "0 < na" and "na < \<^bold>|w\<^bold>|" for na
   proof-
     from prim_no_rotate[OF assms[unfolded prim_rotate_conv[of w n]], of na] \<open>na < \<^bold>|w\<^bold>|\<close> \<open>0 < na\<close>
     have "rotate na (rotate n w) \<noteq> rotate n w" by force
     hence "\<not> rotate na (rotate n w) \<le>lex rotate n w"
       using all_b[rule_format, OF all_rot[of "na + n", folded rotate_rotate[of na n w]]] unfolding w'
       by auto
     from rlex.not_le_imp_less[OF this]
     show "rotate n w <lex rotate na (rotate n w)". 
   qed
   hence "Lyndon (rotate n w)"
     using \<open>w \<noteq> \<epsilon>\<close> by auto 
   from that[OF this] show thesis.
 qed
 
 lemma conjug_Lyndon_ex': assumes "primitive w"
   obtains v where "w \<sim> v" and "Lyndon v"
   unfolding conjug_rotate_iff
   using conjug_Lyndon_ex[OF \<open>primitive w\<close>]
   by metis
   
 section "Characterization by suffixes"
 
 lemma Lyndon_suf_less: assumes "Lyndon w" "s \<le>ns w" "s \<noteq> w"
   shows "w <lex s"
 proof-
   define p where "p = take \<^bold>|s\<^bold>| w" 
   have "\<^bold>|s\<^bold>| \<le> \<^bold>|w\<^bold>|" 
-    using nsD[OF \<open>s \<le>ns w\<close>] by force 
+    using nsD[OF \<open>s \<le>ns w\<close>]
+    by (simp add: suffix_length_le)  
   have "p \<le>p w" and "\<^bold>|p\<^bold>|  = \<^bold>|s\<^bold>|"
     unfolding p_def
     using take_is_prefix \<open>\<^bold>|s\<^bold>| \<le> \<^bold>|w\<^bold>|\<close> take_len by blast+ 
   hence "p \<noteq> s" 
     using Lyndon_unbordered[OF \<open>Lyndon w\<close>] \<open>s \<le>ns w\<close> \<open>s \<noteq> w\<close> assms 
     by auto
   define p' s' where "p' = drop \<^bold>|s\<^bold>| w" and "s' = take \<^bold>|p'\<^bold>| w"
-  have "p\<cdot>p' = w" and "s'\<cdot>s = w"
+  have "p \<cdot> p' = w" 
+    unfolding p'_def p_def s'_def by simp
+  have "s' \<cdot> s = w"
     unfolding p'_def p_def s'_def
-    using \<open>s \<le>ns w\<close> by auto
+     using suf_len[OF nsD[OF \<open>s \<le>ns w\<close>]] nsD[OF \<open>s \<le>ns w\<close>]
+     length_drop suffix_take by metis  
   have "\<^bold>|p'\<^bold>| = \<^bold>|s'\<^bold>|"
     using s'_def \<open>p\<cdot>p' = w\<close> by auto 
   have "w <lex s\<cdot>s'"
     using Lyndon_conj_greater[of s' s, unfolded \<open>s' \<cdot> s = w\<close>, OF \<open>Lyndon w\<close>] \<open>p \<noteq> s\<close> 
     unfolding \<open>s' \<cdot> s = w\<close> p_def using \<open>s' \<cdot> s = w\<close> assms(3) by fastforce
   from lexord_suf_linorder[OF _ \<open>p \<noteq> s\<close> \<open>\<^bold>|p\<^bold>| = \<^bold>|s\<^bold>|\<close> \<open>\<^bold>|p'\<^bold>| = \<^bold>|s'\<^bold>|\<close>, OF this[folded \<open>p \<cdot> p' = w\<close>]]
   have "p <lex s".
   from lexord_app_right_linorder[OF this, of p' \<epsilon>, unfolded \<open>p \<cdot> p' = w\<close>]  \<open>\<^bold>|p\<^bold>| = \<^bold>|s\<^bold>|\<close>
   show "w <lex s"
     by simp
 qed
 
-(* TODO zkusit pouzit jinde *)
+(* TODO try using also elsewhere *)
 lemma Lyndon_pref_suf_less:  assumes "Lyndon w" "p \<le>p w" "s \<le>ns w" "s \<noteq> w"
   shows "p <lex s"
 proof(cases "p = w", simp add: Lyndon_suf_less[OF assms(1) assms(3) assms(4)])
   assume "p \<noteq> w"
   show "p <lex s"
   proof(rule rlex.less_trans)
     show "p <lex w"
-      using \<open>p \<noteq> w\<close> assms(2) lexordp_append_rightI by fastforce 
+      using \<open>p \<noteq> w\<close> assms(2) lexordp_append_rightI
+      by (fastforce simp add: prefix_def) 
     show "w <lex s"
       using Lyndon_suf_less assms(1) assms(3) assms(4) by blast
   qed
 qed
 
 lemma suf_less_Lyndon: assumes "w \<noteq> \<epsilon>" and "\<forall>s. (s \<le>ns w \<longrightarrow> s \<noteq> w \<longrightarrow> w <lex s)"
   shows "Lyndon w"
 proof (cases "primitive w") 
   assume "\<not> primitive w"
   obtain q k where "q \<noteq> \<epsilon>" "1 < k" "q\<^sup>@k=w" "w\<noteq>q" \<comment> \<open>the exact match of @{thm non_prim} fastens the proof considerably\<close>
     using non_prim[OF \<open>\<not> primitive w\<close> \<open>w \<noteq> \<epsilon>\<close>] by blast
   hence "q \<le>ns w"
-    unfolding nonempty_suffix_def pow_eq_if_list[of q k] pow_commutes_list[symmetric]
+    unfolding nonempty_suffix_def pow_eq_if_list[of q k] pow_comm[symmetric]
     using sufI[of "q \<^sup>@ (k - 1)" q w]
     by presburger
 
   have "q <p w"
     using \<open>1 < k\<close>  \<open>q \<^sup>@ k = w\<close> 
     unfolding pow_eq_if_list[of q k] pow_eq_if_list[of q "k-1"]
     using \<open>w \<noteq> \<epsilon>\<close>  by auto
   from lexordp_append_rightI[of "q\<inverse>\<^sup>>w" q, 
       unfolded lq_pref[OF sprefD1[OF this]], OF lq_spref[OF this]]
   have "q <lex w".
   thus  "Lyndon w"
     unfolding Lyndon.simps using \<open>q \<le>ns w\<close> \<open>w \<noteq> \<epsilon>\<close> assms(2) rlex.order.strict_trans by blast
 next 
   assume "primitive w"
   have "w <lex rotate l w" if assms_l: "0 < l" "l < \<^bold>|w\<^bold>|" for l  
   proof-
     have "take l w \<le>np w" and "\<^bold>|take l w\<^bold>| = l"
       using assms_l take_is_prefix  \<open>l < \<^bold>|w\<^bold>|\<close> by auto
     have "drop l w \<le>ns w" 
       using \<open>l < \<^bold>|w\<^bold>|\<close> suffix_drop by auto
     have "drop l w \<noteq> w"
       using append_take_drop_id[of l w] npD'[OF \<open>take l w \<le>np w\<close>] by force
     have "drop l w \<cdot> take l w = rotate l w"
       using rotate_append[of "take l w" "drop l w", symmetric, unfolded \<open>\<^bold>|take l w\<^bold>| = l\<close>, 
           unfolded append_take_drop_id].
 
     have "w <lex drop l w"
       using \<open>drop l w \<le>ns w\<close> \<open>drop l w \<noteq> w\<close> assms(2) by blast
     from lexord_app_right_linorder[OF this suffix_length_le[OF conjunct2[OF \<open>drop l w \<le>ns w\<close>[unfolded nonempty_suffix_def]]], of \<epsilon> "take l w", unfolded  append.right_neutral]
     have "w <lex drop l w \<cdot> take l w".
     thus "w <lex rotate l w"
       by (simp add: \<open>drop l w \<cdot> take l w = rotate l w\<close>)
   qed
   thus "Lyndon w"
     by (simp add: \<open>w \<noteq> \<epsilon>\<close> local.LyndonI)
 qed
 
 corollary Lyndon_suf_char: "w \<noteq> \<epsilon> \<Longrightarrow> Lyndon w \<longleftrightarrow> (\<forall>s. s \<le>ns w \<longrightarrow> s \<noteq> w \<longrightarrow> w <lex s)"
   using Lyndon_suf_less suf_less_Lyndon by blast
 
 lemma Lyndon_suf_le: "Lyndon w \<Longrightarrow> s \<le>ns w \<Longrightarrow> w \<le>lex s"
   using Lyndon_suf_less rlex.not_less rlex.order.asym by blast
 
 section "Unbordered prefix of a Lyndon word is Lyndon"
 
 lemma unbordered_pref_Lyndon: "Lyndon (u\<cdot>v) \<Longrightarrow> u \<noteq> \<epsilon> \<Longrightarrow> \<not> bordered u \<Longrightarrow> Lyndon u"
   unfolding Lyndon_suf_char
 proof(standard+)
   fix s
   assume "Lyndon (u \<cdot> v)" and  "u \<noteq> \<epsilon>" and "\<not> bordered u" and "s \<le>ns u" and "s \<noteq> u"
     hence "u \<cdot> v <lex s \<cdot> v"
       using  Lyndon_suf_less[OF \<open>Lyndon (u \<cdot> v)\<close>, of "s \<cdot> v"] by auto
     have "\<not> s \<le>p u"
       using \<open>\<not> bordered u\<close> \<open>s \<le>ns u\<close> \<open>s \<noteq> u\<close> by auto 
     moreover have "\<not> u \<le>p s"
       using suf_pref_eq[OF nsD[OF\<open>s \<le>ns u\<close>]] \<open>s \<noteq> u\<close> by blast
     ultimately show "u <lex s"
       using lexord_cancel_right_linorder[OF \<open>u \<cdot> v <lex s \<cdot> v\<close>] by blast
 qed
 
 section "Concatenation of Lyndon words"
 
 theorem Lyndon_concat: assumes  "Lyndon u" and "Lyndon v" and "u <lex v"
   shows "Lyndon (u\<cdot>v)"
 proof-
   have "u\<cdot>v <lex v"
   proof(cases "u \<le>p v")
     assume "u \<le>p v"
-    then obtain z where "u\<cdot>z = v" and "z \<le>ns v"
-      using assms(3) dual_rlex.less_imp_neq by auto
+    obtain z where "u\<cdot>z = v" and "z \<le>ns v"
+      using  lq_pref[OF \<open>u \<le>p v\<close>] nsI' rlex.less_imp_neq[OF \<open>u <lex v\<close>] self_append_conv by metis
     from Lyndon_suf_less[OF \<open>Lyndon v\<close> this(2), THEN lexord_append_leftI_linorder, of u]
       LyndonD_nemp[OF \<open>Lyndon u\<close>] this(1)
     show ?thesis
       by blast
   next
     assume "\<not> u \<le>p v"
     then show ?thesis
       using local.lexordp_linear[of v "u\<cdot>v"] 
         local.lexordp_mid_pref[OF \<open>u <lex v\<close>,of v]
         prefixI[of v u v]
       by argo
   qed
 
   { fix z
     assume "z \<le>ns (u\<cdot>v)" "z \<noteq> u\<cdot>v"
     have "u\<cdot>v <lex z"
     proof(cases "z \<le>ns v")
       assume "z \<le>ns v"
       from Lyndon_suf_less[OF \<open>Lyndon v\<close> this]
       have "z \<noteq> v \<Longrightarrow> v <lex z"
         by blast
       thus "u\<cdot>v <lex z"
         using \<open>u \<cdot> v <lex v\<close> rlex.less_trans
         by fast
     next
       assume "\<not> z \<le>ns v"
       then obtain z' where "z' \<le>ns u" "z' \<noteq> u" "z'\<cdot>v = z"
         using \<open>z \<le>ns u \<cdot> v\<close> \<open>z \<noteq> u \<cdot> v\<close> suffix_append[of z u v]
         unfolding nonempty_suffix_def
         by force
       from Lyndon_suf_less[OF \<open>Lyndon u\<close> this(1) this(2)]
       have "u <lex z'".
       thus "u\<cdot>v <lex z"
         using  \<open>z' \<le>ns u\<close> lexord_app_right_linorder[of u z' v v] suffix_length_le[of z' u]
         unfolding nonempty_suffix_def \<open>z' \<cdot> v = z\<close>
         by blast
     qed
   }
   thus ?thesis
     using suf_nemp[OF LyndonD_nemp[OF \<open>Lyndon v\<close>], of u, THEN suf_less_Lyndon]
     by blast
 qed
 
 section "Longest Lyndon suffix"
 
 fun longest_Lyndon_suffix:: "'a list \<Rightarrow> 'a list" ("LynSuf") where
   "longest_Lyndon_suffix \<epsilon> = \<epsilon>" |
   "longest_Lyndon_suffix (a#w) = (if Lyndon (a#w) then a#w else longest_Lyndon_suffix w)"
 
 lemma longest_Lyndon_suf_ext: "\<not> Lyndon (a # w) \<Longrightarrow> LynSuf w = LynSuf (a # w)"
   using longest_Lyndon_suffix.simps(2) by presburger
 
 lemma longest_Lyndon_suf_suf: "w \<noteq> \<epsilon> \<Longrightarrow> LynSuf w \<le>s w"
 proof(induction w rule: longest_Lyndon_suffix.induct)
   case 1
   then show ?case by simp 
 next
   case (2 a w)
   show ?case
   proof(cases "Lyndon (a#w)")
     case True
     then show ?thesis by auto
   next
     case False
     from "2.IH"[OF this, unfolded longest_Lyndon_suf_ext[OF this], THEN suffix_ConsI, of a]
       Lyndon_sing False
     show ?thesis by blast
   qed
 qed
 
 lemma longest_Lyndon_suf_max: 
   "v \<le>s w  \<Longrightarrow> Lyndon v \<Longrightarrow> v \<le>s (LynSuf w)"
 proof(induction w arbitrary: v rule: longest_Lyndon_suffix.induct)
   case 1
   then show ?case
     using longest_Lyndon_suffix.simps(1) by presburger 
 next
   case (2 a w)
   show ?case
   proof(cases "Lyndon (a#w)")
     case True
     then show ?thesis
       using "2.prems"(1) longest_Lyndon_suffix.simps(2) by presburger
   next
     case False
     have "v \<noteq> a # w"
       using "2.prems"(2) False by blast
     from "2.IH"[OF False _ "2.prems"(2), unfolded longest_Lyndon_suf_ext[OF False]]
        "2.prems"(1)[unfolded suffix_Cons] this
     show ?thesis by fast
   qed  
 qed
 
 lemma longest_Lyndon_suf_Lyndon_id: assumes "Lyndon w" 
   shows "LynSuf w = w"
 proof(cases "w = \<epsilon>", simp)
   case False
   from longest_Lyndon_suf_suf[OF this]
     suffix_order.order_refl[THEN longest_Lyndon_suf_max[OF _ assms]]
-    suffix_order.antisym_conv 
+    suffix_order.antisym 
   show ?thesis by blast
 qed
 
 lemma longest_Lyndon_suf_longest: "w \<noteq> \<epsilon> \<Longrightarrow> v' \<le>s w \<Longrightarrow> Lyndon v' \<Longrightarrow> \<^bold>|v'\<^bold>| \<le> \<^bold>|(LynSuf w)\<^bold>|"
   using longest_Lyndon_suf_max suffix_length_le by blast
 
 lemma longest_Lyndon_suf_sing: "LynSuf [a] = [a]"
   using Lyndon_sing longest_Lyndon_suf_Lyndon_id by blast
 
 lemma longest_Lyndon_suf_Lyndon: "w \<noteq> \<epsilon> \<Longrightarrow> Lyndon (LynSuf w)"
 proof(induction w rule: longest_Lyndon_suffix.induct, blast)
   case (2 a w)
   show ?case
   proof(cases "Lyndon (a#w)")
     case True
     then show ?thesis
       using longest_Lyndon_suf_Lyndon_id by presburger
   next
     case False
     from "2.IH"[OF this, unfolded longest_Lyndon_suf_ext[OF this]] Lyndon_sing
     show ?thesis by fastforce
   qed
 qed  
 
 lemma longest_Lyndon_suf_nemp: "w \<noteq> \<epsilon> \<Longrightarrow> LynSuf w \<noteq> \<epsilon>"
   using longest_Lyndon_suf_Lyndon[THEN LyndonD_nemp].
 
 lemma longest_Lyndon_sufI:
   assumes "q \<le>s w" and "Lyndon q" and all_s: "(\<forall> s. (s \<le>s w \<and> Lyndon s) \<longrightarrow> s \<le>s q)" 
   shows "LynSuf w = q"
 proof(cases "w = \<epsilon>")
   case True
   then show ?thesis
-    using assms(1) by fastforce
+    using assms(1) longest_Lyndon_suffix.simps(1) suffix_bot.extremum_uniqueI by blast 
 next
   case False
   from all_s longest_Lyndon_suf_Lyndon[OF this] longest_Lyndon_suf_max[OF assms(1) assms(2)]
     longest_Lyndon_suf_suf[OF this] suffix_order.eq_iff
   show ?thesis by blast
 qed
 
 corollary longest_Lyndon_sufI': 
   assumes "q \<le>s w" and "Lyndon q" and all_s: "\<forall> s. (s \<le>s w \<and> Lyndon s) \<longrightarrow> \<^bold>|s\<^bold>| \<le> \<^bold>|q\<^bold>|" 
   shows "LynSuf w = q"
   using longest_Lyndon_sufI[OF \<open>q \<le>s w\<close> \<open>Lyndon q\<close>] suf_ruler_le all_s \<open>q \<le>s w\<close> by blast
 
 text\<open>The next lemma is fabricated to suit the upcoming definition of longest Lyndon factorization.\<close>
 
 lemma longest_Lyndon_suf_shorter: assumes "w \<noteq> \<epsilon>" 
   shows "\<^bold>|w\<^sup><\<inverse>(LynSuf w)\<^bold>| < \<^bold>|w\<^bold>|"
   using nemp_len[OF longest_Lyndon_suf_nemp[OF \<open>w \<noteq> \<epsilon>\<close>]] arg_cong[OF rq_suf[OF longest_Lyndon_suf_suf[OF \<open>w \<noteq> \<epsilon>\<close>]], of length] 
-  unfolding length_append by linarith  
+  unfolding lenmorph by linarith  
 
 section "Lyndon factorizations"
 
 function Lyndon_fac::"'a list  \<Rightarrow> 'a list list" ("LynFac")
   where "Lyndon_fac w  = (if w \<noteq> \<epsilon> then ((Lyndon_fac (w \<^sup><\<inverse>(LynSuf w) )) \<cdot> [LynSuf w]) else \<epsilon>)"
   using longest_Lyndon_suffix.cases by blast+
 termination
 proof(relation "measure length", simp)
   show "\<And>w. w \<noteq> \<epsilon> \<Longrightarrow> (w\<^sup><\<inverse>LynSuf w, w) \<in> measure length"
     unfolding measure_def inv_image_def using longest_Lyndon_suf_shorter by blast
 qed
 
 text\<open>The factorization @{term "Lyndon_fac w"} obtained by taking always the longest Lyndon suffix is well defined, 
 and called ``Lyndon factorization (of $w$)''.\<close>
 
 
 lemma Lyndon_fac_simp: "w \<noteq> \<epsilon> \<Longrightarrow> Lyndon_fac w =  Lyndon_fac (w\<^sup><\<inverse>LynSuf w) \<cdot> (LynSuf w # \<epsilon>)"
   using Lyndon_fac.simps[of w] by meson
 
 lemma Lyndon_fac_emp: "Lyndon_fac \<epsilon> = \<epsilon>"
   by simp
 
 text\<open>Note that the Lyndon factorization of a Lyndon word is trivial.\<close>
 
 lemma Lyndon_fac_longest_Lyndon_id: "Lyndon w \<Longrightarrow> Lyndon_fac w = [w]"
   by (simp add: longest_Lyndon_suf_Lyndon_id) 
 
 text\<open>Lyndon factorization is composed of Lyndon words ...\<close>
 
 lemma Lyndon_fac_set: "z \<in> set (Lyndon_fac w) \<Longrightarrow> Lyndon z"
 proof(induction w rule:  Lyndon_fac.induct)
   case (1 w)
   then show "Lyndon z"
   proof (cases "w = \<epsilon>")
     assume "w \<noteq> \<epsilon>"
     have "Lyndon_fac w  = (Lyndon_fac (w \<^sup><\<inverse>(LynSuf w) )) \<cdot> [LynSuf w]"
       using Lyndon_fac_simp[OF \<open>w \<noteq> \<epsilon>\<close>].
     from set_ConsD[OF "1.prems"(1)[unfolded rotate1.simps(2)[of "LynSuf w" "Lyndon_fac (w \<^sup><\<inverse>(LynSuf w) )", folded this, symmetric], unfolded set_rotate1]]
     have "z = LynSuf w \<or> z \<in> set (Lyndon_fac (w \<^sup><\<inverse>(LynSuf w) ))".
     thus "Lyndon z"
       using "1.IH"[OF \<open>w \<noteq> \<epsilon>\<close>] longest_Lyndon_suf_Lyndon[OF \<open>w \<noteq> \<epsilon>\<close>]
       by blast
   next
     assume "w = \<epsilon>"
     thus "Lyndon z"
       using "1.prems"
       unfolding Lyndon_fac_emp[folded \<open>w = \<epsilon>\<close>] list.set(1) empty_iff
       by blast
   qed
 qed
 
 text\<open>...and it indeed is a factorization of the argument.\<close>
 
 lemma Lyndon_fac_longest_dec: "concat (Lyndon_fac w) = w"
 proof(induction w rule: Lyndon_fac.induct)
   case (1 w)
   thus "concat (LynFac w) = w"
   proof (cases "w = \<epsilon>", simp)
   assume "w \<noteq> \<epsilon>"
     have eq: "concat (Lyndon_fac w) = concat ( (Lyndon_fac (w \<^sup><\<inverse>(LynSuf w) )) ) \<cdot> concat ([LynSuf w])"
       unfolding Lyndon_fac_simp[OF \<open>w \<noteq> \<epsilon>\<close>] concat_morph..
     from this[unfolded "1.IH"[OF \<open>w \<noteq> \<epsilon>\<close>] concat_sing' rq_suf[OF longest_Lyndon_suf_suf[OF \<open>w \<noteq> \<epsilon>\<close>]]]
     show ?case.
   qed
 qed
 
 text\<open>The following lemma makes explicit the inductive character of the definition of @{term Lyndon_fac}.\<close>
 
 lemma Lyndon_fac_longest_pref: "us \<le>p Lyndon_fac w \<Longrightarrow> Lyndon_fac (concat us) = us"
 proof(induction w arbitrary: us rule:  Lyndon_fac.induct)
   case (1 w)
   thus "LynFac (concat us) = us"
   proof (cases "w = \<epsilon>", simp)
     assume "w \<noteq> \<epsilon>"
     have step: "Lyndon_fac w = (Lyndon_fac (w \<^sup><\<inverse>(LynSuf w))) \<cdot> [LynSuf w]"
       using Lyndon_fac_simp[OF \<open>w \<noteq> \<epsilon>\<close>].
 
     consider (neq) "us \<noteq> Lyndon_fac w" | (eq) "us = Lyndon_fac w"
       using "1.prems" le_neq_implies_less by blast
     then show "LynFac (concat us) = us"
     proof(cases)
       case neq
       hence "us \<le>p Lyndon_fac (w\<^sup><\<inverse>LynSuf w)"
         using "1.prems" last_no_split[of us "Lyndon_fac (w\<^sup><\<inverse>LynSuf w)" "LynSuf w"] 
         unfolding step[symmetric] by blast
       thus "LynFac (concat us) = us"
         using "1.IH" \<open>w \<noteq> \<epsilon>\<close> by blast 
     next
       case eq
       show "LynFac (concat us) = us"
         using Lyndon_fac_longest_dec[of w, folded eq] eq by simp
     qed
   qed
 qed
 
 text\<open>We give name to an important predicate: monotone (nonincreasing) list of Lyndon words.\<close>
 
 definition Lyndon_mono :: "'a list list \<Rightarrow>  bool" where
   "Lyndon_mono ws \<longleftrightarrow> (\<forall> u \<in> set ws. Lyndon u) \<and> (rlex.sorted (rev ws))"
 
 lemma Lyndon_mono_set: "Lyndon_mono ws \<Longrightarrow> u \<in> set ws \<Longrightarrow> Lyndon u"
   unfolding Lyndon_mono_def by blast
 
 lemma Lyndon_mono_sorted: "Lyndon_mono ws \<Longrightarrow> rlex.sorted (rev ws)"
   unfolding Lyndon_mono_def by blast
 
 lemma Lyndon_mono_nth: "Lyndon_mono ws \<Longrightarrow> i \<le> j \<Longrightarrow> j < \<^bold>|ws\<^bold>| \<Longrightarrow> ws!j \<le>lex ws!i"
   unfolding Lyndon_mono_def using  rlex.sorted_rev_nth_mono by blast
 
 lemma Lyndon_mono_empty[simp]: "Lyndon_mono \<epsilon>"
   unfolding Lyndon_mono_def by auto
 
 lemma Lyndon_mono_sing: "Lyndon u \<Longrightarrow> Lyndon_mono [u]"
   unfolding Lyndon_mono_def by auto
 
 lemma Lyndon_mono_fac_Lyndon_mono: 
   assumes "ps \<le>f ws" and "Lyndon_mono ws" shows "Lyndon_mono ps"  
 unfolding Lyndon_mono_def
 proof
   show "\<forall>x \<in> (set ps). Lyndon x" 
     using \<open>Lyndon_mono ws\<close>[unfolded Lyndon_mono_def] set_mono_sublist[OF \<open>ps \<le>f ws\<close>] by blast
   show "linorder.sorted (\<le>lex) (rev ps)"
     using rlex.sorted_append \<open>Lyndon_mono ws\<close>[unfolded Lyndon_mono_def] \<open>ps \<le>f ws\<close>[unfolded sublist_def] by fastforce
 qed
 
 text\<open>Lyndon factorization is monotone! 
 Altogether, we have shown that the Lyndon factorization is a monotone factorization 
 into Lyndon words.\<close>
 
 theorem fac_Lyndon_mono: "Lyndon_mono (Lyndon_fac w)"
 proof (induct "Lyndon_fac w" arbitrary: w rule: rev_induct, simp)
   case (snoc x xs)
   have "Lyndon x"
     using Lyndon_fac_set[of x, unfolded in_set_conv_decomp, of w, folded snoc.hyps(2)] by fast
   have "concat (xs \<cdot> [x]) = w"
     using Lyndon_fac_longest_dec[of w, folded snoc.hyps(2)] by auto
   then show "Lyndon_mono (LynFac w)"
   proof (cases "xs = \<epsilon>")
     assume "xs = \<epsilon>"
     show "Lyndon_mono (LynFac w)"
       unfolding Lyndon_mono_def \<open>xs \<cdot> [x] = LynFac w\<close>[symmetric] \<open>xs = \<epsilon>\<close> append.left_neutral 
                 rlex.sorted1[of x]  
       using \<open>Lyndon x\<close> by force
   next
     assume "xs \<noteq> \<epsilon>"
     have "concat (xs \<cdot> [x]) \<noteq> \<epsilon>" and "w \<noteq> \<epsilon>"
       using Lyndon_fac_longest_dec snoc.hyps(2) by auto
     have "x = LynSuf w" and "xs = LynFac (w\<^sup><\<inverse>LynSuf w )"           
       using Lyndon_fac.simps[of w, folded snoc.hyps(2)] \<open>w \<noteq> \<epsilon>\<close>
         Lyndon_fac_longest_dec append1_eq_conv[of xs x "LynFac (w\<^sup><\<inverse>LynSuf w )" "LynSuf w"] by presburger+       
     from Lyndon_mono_sorted[OF snoc.hyps(1)[OF \<open>xs = LynFac (w\<^sup><\<inverse>LynSuf w )\<close>], folded this]
     have "dual_rlex.sorted  xs"
       unfolding sorted_dual_rev_iff.
     have "Lyndon (last xs)"
       using Lyndon_fac_set[of "last xs" "w\<^sup><\<inverse>LynSuf w", folded \<open>xs = LynFac (w\<^sup><\<inverse>LynSuf w)\<close>, OF last_in_set[OF \<open>xs \<noteq> \<epsilon>\<close>]].
     have "x \<le>lex last xs"
     proof(rule ccontr)
       assume "\<not> x \<le>lex last xs" hence "last xs <lex x" by auto
       from Lyndon_concat[OF  \<open>Lyndon (last xs)\<close> \<open>Lyndon x\<close> this]
       have "Lyndon ((last xs) \<cdot> x)".
       have "(last xs) \<cdot> x \<le>s concat (xs \<cdot> [x])"
         using \<open>xs \<noteq> \<epsilon>\<close> concat_last_suf by auto
       from longest_Lyndon_suf_longest[OF \<open>concat (xs \<cdot> [x]) \<noteq> \<epsilon>\<close>  this \<open>Lyndon ((last xs) \<cdot> x)\<close>, 
           unfolded \<open>concat (xs \<cdot> [x]) = w\<close>, folded \<open>x = LynSuf w\<close>]
       show False
         using \<open>Lyndon (last xs)\<close> by simp 
     qed 
     have "dual_rlex.sorted (butlast xs \<cdot> [last xs])"
       by (simp add: \<open>linorder.sorted (\<lambda>x y. y \<le>lex x) xs\<close> \<open>xs \<noteq> \<epsilon>\<close>)
     from this \<open>x \<le>lex last xs\<close>
     have "dual_rlex.sorted (butlast xs \<cdot> [last xs,x])"
       using dual_rlex.sorted_append by auto   
     from this[unfolded hd_word[of "last xs" "[x]"] lassoc append_butlast_last_id[OF \<open>xs \<noteq> \<epsilon>\<close>]]
     have "rlex.sorted (rev (LynFac w))"
       unfolding  \<open>xs \<cdot> [x] = LynFac w\<close>[symmetric] sorted_dual_rev_iff[symmetric].
     thus "Lyndon_mono (LynFac w)"
       unfolding Lyndon_mono_def using Lyndon_fac_set by blast
   qed
 qed
 
 text\<open>Now we want to show the converse: any monotone factorization into Lyndon words is the Lyndon factorization\<close>
 
 text\<open>The last element in the Lyndon factorization is the smallest suffix.\<close>
 
 lemma Lyndon_mono_last_smallest: "Lyndon_mono ws \<Longrightarrow>s \<le>ns (concat ws) \<Longrightarrow> last ws \<le>lex s"
 proof(induct ws arbitrary: s rule: rev_induct, fastforce)
   case (snoc a ws)
   have "ws\<cdot>[a] \<noteq> \<epsilon>"
     by blast
   have "last (ws\<cdot>[a]) = a"
     by simp
   from last_in_set[OF \<open>ws\<cdot>[a] \<noteq> \<epsilon>\<close>, unfolded this] \<open>Lyndon_mono (ws \<cdot> [a])\<close>[unfolded Lyndon_mono_def]
   have "Lyndon a"
     by blast
   show ?case
   proof(cases "s \<le>ns a")
     case True
     from Lyndon_suf_le[OF \<open>Lyndon a\<close>] this
     show ?thesis
       by simp
   next
     case False
     hence "ws \<noteq> \<epsilon>"
       using snoc.prems(2) by force
     obtain s' where "s = s'\<cdot>a"
       using False snoc.prems(2)[unfolded concat_append[of ws "[a]", unfolded concat_sing']] suffix_append[of s "concat ws" a]
       unfolding nonempty_suffix_def
       by blast
     hence "s' \<le>ns concat ws"
       using False snoc.prems(2) by fastforce
     have "Lyndon_mono ws"
       using \<open>Lyndon_mono (ws\<cdot>[a])\<close> Lyndon_mono_fac_Lyndon_mono
       by blast
     from snoc.hyps[OF this \<open>s' \<le>ns concat ws\<close>]
     have "last ws \<le>lex s'" 
       by auto
     hence "last ws \<le>lex s'\<cdot>a"
       using local.lexordp_eq_trans ord.lexordp_eq_pref by blast
     have "a \<le>lex last ws"
       using \<open>Lyndon_mono (ws\<cdot>[a])\<close>
       unfolding Lyndon_mono_def
       by (simp add: \<open>ws \<noteq> \<epsilon>\<close> last_ConsL)
     from dual_rlex.order_trans[OF \<open>last ws \<le>lex s' \<cdot> a\<close> this, folded \<open>s = s' \<cdot> a\<close>]
     show ?thesis
       unfolding \<open>last (ws\<cdot>[a]) = a\<close>
       by blast
   qed
 qed
 
 
 text\<open>A monotone list, if seen as a factorization,
 must end with the longest suffix\<close>
 
 lemma Lyndon_mono_last_longest: assumes "ws \<noteq> \<epsilon>" and "Lyndon_mono ws" 
   shows "LynSuf (concat ws) = last ws"
 proof-
   have "Lyndon (last ws)"
     using Lyndon_mono_set assms(1) assms(2) last_in_set by blast
   hence "last ws \<noteq> \<epsilon>"
     using LyndonD_nemp by blast
   hence "last ws \<le>ns LynSuf (concat ws)"
     using longest_Lyndon_suf_max[OF  concat_last_suf[OF assms(1)] \<open>Lyndon (last ws)\<close>]
     unfolding nonempty_suffix_def
     by blast
 
   have "concat ws \<noteq> \<epsilon>"
     using Lyndon.simps assms(2)[unfolded Lyndon_mono_def] set_nemp_concat_nemp[OF assms(1)]
     by blast
   from longest_Lyndon_suf_nemp[OF this] longest_Lyndon_suf_suf[OF this]
   have "LynSuf (concat ws) \<le>ns concat ws"
     unfolding nonempty_suffix_def
     by simp
  
   show ?thesis
     using Lyndon_mono_last_smallest[OF \<open>Lyndon_mono ws\<close> \<open>LynSuf (concat ws) \<le>ns concat ws\<close>]
       Lyndon_suf_le[OF longest_Lyndon_suf_Lyndon[OF \<open>concat ws \<noteq> \<epsilon>\<close>], OF \<open>last ws \<le>ns LynSuf (concat ws)\<close>]
+      eq_iff
     by simp
 qed
 
 text\<open>Therefore, by construction, 
 any monotone list is the Lyndon factorization of its concatenation\<close>
 
 lemma Lyndon_mono_fac:
   "Lyndon_mono ws \<Longrightarrow> ws = Lyndon_fac (concat ws)"
 proof (induct ws rule: rev_induct, simp)
   case (snoc x xs)
   have "Lyndon_mono xs"
     using \<open>Lyndon_mono (xs \<cdot> [x])\<close>  
     unfolding Lyndon_mono_def
     by simp 
   from snoc.hyps[OF this]
   have "xs = LynFac (concat xs)".
   have "x = LynSuf (concat (xs \<cdot> [x]))"
     using Lyndon_mono_last_longest[OF _ \<open>Lyndon_mono (xs \<cdot> [x])\<close>, unfolded last_snoc] by simp
   have "concat (xs \<cdot> [x])\<^sup><\<inverse>x = concat xs"
     by simp
   have "concat (xs \<cdot> [x]) \<noteq> \<epsilon>"
     using Lyndon_mono_set snoc.prems by auto
   from this
   show ?case
     using Lyndon_fac.simps[of "concat (xs \<cdot> [x])", folded \<open>x = LynSuf (concat (xs \<cdot> [x]))\<close>,
         unfolded \<open>concat (xs \<cdot> [x])\<^sup><\<inverse>x = concat xs\<close>, folded \<open>xs = LynFac (concat xs)\<close>] 
     by presburger
 qed
 
 
 text\<open>This implies that the Lyndon factorization can be characterized
 in two equivalent ways: as the (unique) monotone factorization (into Lyndon words) or as
 the "suffix greedy" factorization (into Lyndon words).
 \<close>
 
 corollary Lyndon_mono_fac_iff: "Lyndon_mono ws \<longleftrightarrow> ws = LynFac (concat ws)"
   using Lyndon_mono_fac fac_Lyndon_mono[of "concat ws"] by fastforce
 
 corollary Lyndon_mono_unique: assumes "Lyndon_mono ws" and "Lyndon_mono zs" and "concat ws = concat zs" 
   shows "ws = zs"
   using Lyndon_mono_fac[OF \<open>Lyndon_mono ws\<close>] Lyndon_mono_fac[OF \<open>Lyndon_mono zs\<close>] 
   unfolding \<open>concat ws = concat zs\<close>  by simp
 
 
 subsection "Standard factorization"
 
 lemma Lyndon_std: assumes "Lyndon w" "1 < \<^bold>|w\<^bold>|"
   obtains l m where "w = l\<cdot>m" and "Lyndon l" and "Lyndon m" and "l <lex m"
 proof-
   have "w \<noteq> \<epsilon>" "tl w \<noteq> \<epsilon>"
     using \<open>1 < \<^bold>|w\<^bold>|\<close> long_list_tl by auto
   define m where  "m = LynSuf (tl w)"
   hence "Lyndon m"
     using \<open>tl w \<noteq> \<epsilon>\<close> local.longest_Lyndon_suf_Lyndon by blast
   have "m \<le>s w"
     unfolding m_def 
     using suffix_order.trans[OF longest_Lyndon_suf_suf[OF \<open>tl w \<noteq> \<epsilon>\<close>] suffix_tl[of w]]. 
   moreover have "m \<noteq> w"
-    unfolding m_def using  hd_word'[OF \<open>w \<noteq> \<epsilon>\<close>] list.simps(3) longest_Lyndon_suf_suf[OF \<open>tl w \<noteq> \<epsilon>\<close>] same_suffix_nil
-    by fastforce
+    unfolding m_def using  hd_tl[OF \<open>w \<noteq> \<epsilon>\<close>] longest_Lyndon_suf_suf[OF \<open>tl w \<noteq> \<epsilon>\<close>] same_suffix_nil
+    not_Cons_self2 by metis
   ultimately obtain l where "w = l\<cdot>m" and "l \<noteq> \<epsilon>"
-    by force
+   by (auto simp add: suf_def)
 
   have "Lyndon l"
   proof (rule unbordered_pref_Lyndon[OF \<open>Lyndon w\<close>[unfolded \<open>w = l\<cdot>m\<close>] \<open>l \<noteq> \<epsilon>\<close>], rule)
     assume "bordered l"
     from unbordered_border[OF this, unfolded border_def]
     obtain s where "s \<noteq> \<epsilon>" and "s \<noteq> l" and "s \<le>p l" and "s \<le>s l" and "\<not> bordered s"
       by blast 
     have "Lyndon s"       
       using unbordered_pref_Lyndon[OF _ \<open>s \<noteq> \<epsilon>\<close> \<open>\<not> bordered s\<close>, of "s\<inverse>\<^sup>>l\<cdot>m", unfolded lassoc lq_pref[OF \<open>s \<le>p l\<close>]]
       \<open>Lyndon w\<close>[unfolded \<open>w = l \<cdot> m\<close>] by blast
     have "s <lex m"
       using Lyndon_pref_suf_less[OF \<open>Lyndon w\<close> _ nsI[OF LyndonD_nemp[OF \<open>Lyndon m\<close>] \<open>m \<le>s w\<close>] 
          \<open>m \<noteq> w\<close>, of s] Lyndon.elims(2)[OF \<open>Lyndon m\<close>]  
          \<open>s \<le>p l\<close> prefix_append[of s l m, folded \<open>w = l \<cdot> m\<close>]
       by presburger
     from Lyndon_concat[OF \<open>Lyndon s\<close> \<open>Lyndon m\<close> this]
     have "Lyndon (s\<cdot>m)".
     moreover have "s\<cdot>m \<le>s tl w" 
-      unfolding \<open>w = l \<cdot> m\<close> using \<open>s \<noteq> l\<close> \<open>s \<le>s l\<close> list.collapse[OF \<open>w \<noteq> \<epsilon>\<close>, unfolded \<open>w = l \<cdot> m\<close>] by force
+      unfolding \<open>w = l \<cdot> m\<close> using \<open>s \<noteq> l\<close> \<open>s \<le>s l\<close> list.collapse[OF \<open>w \<noteq> \<epsilon>\<close>, unfolded \<open>w = l \<cdot> m\<close>]
+      by (auto simp add: suf_def)
     ultimately show False
       using m_def \<open>s \<noteq> \<epsilon>\<close> longest_Lyndon_suf_max same_suffix_nil by blast
   qed
 
   have "l <lex m"
     using Lyndon_pref_suf_less[OF \<open>Lyndon w\<close> prefI[OF \<open>w = l \<cdot> m\<close>[symmetric]] 
         nsI[OF longest_Lyndon_suf_nemp[OF \<open>tl w \<noteq> \<epsilon>\<close>, folded  m_def] \<open>m \<le>s w\<close>] \<open>m \<noteq> w\<close>].
   from that[OF \<open>w = l \<cdot> m\<close> \<open>Lyndon l\<close>  \<open>Lyndon m\<close> this]
   show thesis.
 qed
 
 corollary Lyndon_std_iff: 
   "Lyndon w \<longleftrightarrow> (\<^bold>|w\<^bold>| = 1 \<or> (\<exists> l m. w = l\<cdot>m \<and> Lyndon l \<and> Lyndon m \<and> l <lex m))" 
   (is "?L \<longleftrightarrow> ?R")
 proof
   assume ?L
   show ?R
     using Lyndon_std[OF \<open>Lyndon w\<close>] 
-      nemp_pos_len[OF LyndonD_nemp[OF \<open>Lyndon w\<close>], unfolded le_eq_less_or_eq]
+      nemp_le_len[OF LyndonD_nemp[OF \<open>Lyndon w\<close>], unfolded le_eq_less_or_eq]
     by metis
 next
   assume ?R
   thus ?L
   proof(rule disjE, fastforce)
     show \<open>\<exists>l m. w = l \<cdot> m \<and> Lyndon l \<and> Lyndon m \<and> l <lex m \<Longrightarrow> Lyndon w\<close> 
       using Lyndon_concat by blast
   qed
 qed
 
 end  \<comment> \<open>end context linorder\<close>
 
-end
\ No newline at end of file
+end
diff --git a/thys/Combinatorics_Words_Lyndon/Lyndon_Addition.thy b/thys/Combinatorics_Words_Lyndon/Lyndon_Addition.thy
--- a/thys/Combinatorics_Words_Lyndon/Lyndon_Addition.thy
+++ b/thys/Combinatorics_Words_Lyndon/Lyndon_Addition.thy
@@ -1,107 +1,108 @@
 (*  Title:      CoW_Lyndon.Lyndon_Addition
     Author:     Štěpán Holub, Charles University
     Author:     Štěpán Starosta, CTU in Prague
+
+Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/
 *)
 
 theory Lyndon_Addition
   imports Lyndon Szpilrajn.Szpilrajn
 
 begin
 
 subsection "The minimal relation"
 
 text \<open>We define the minimal relation which guarantees the lexicographic minimality of w compared to its 
 nontrivial conjugates.\<close>
 
 inductive_set rotate_rel :: "'a list \<Rightarrow> 'a rel" for w
   where  "0 < n \<Longrightarrow> n < \<^bold>|w\<^bold>| \<Longrightarrow> (mismatch_pair w (rotate n w)) \<in> rotate_rel w"
 
 text\<open>A word is Lyndon iff the corresponding order of letters is compatible with  @{term "rotate_rel w"}.\<close>
 
 lemma (in linorder) rotate_rel_iff: assumes "w \<noteq> \<epsilon>"
   shows  "Lyndon w \<longleftrightarrow> rotate_rel w \<subseteq> {(x,y). x < y}" (is "?L \<longleftrightarrow> ?R")
 proof
   assume "Lyndon w" show "rotate_rel w \<subseteq> {(x,y). x < y}"
   proof
     fix  x assume "x \<in> rotate_rel w"
     then obtain n where "x = mismatch_pair w (rotate n w)" and "0 < n" and "n < \<^bold>|w\<^bold>|"
       using rotate_rel.cases by blast
     have "w <lex rotate n w" 
       using LyndonD[OF \<open>Lyndon w\<close> \<open>0 < n\<close> \<open>n < \<^bold>|w\<^bold>|\<close>]. 
     from this[unfolded lexordp_conv_lexord] 
       prim_no_rotate[OF Lyndon_prim[OF \<open>Lyndon w\<close>] \<open>0 < n\<close>  \<open>n < \<^bold>|w\<^bold>|\<close>]
     show "x \<in> {(a, b). a < b}" 
       using lexord_mismatch[of w "rotate n w" "{(a,b). a < b}", folded \<open>x = mismatch_pair w (rotate n w)\<close>]
         \<open>rotate n w \<noteq> w\<close> rotate_comp_eq[of w n] 
       unfolding irrefl_def by blast
   qed
 next
   assume "?R" 
   show "?L"
     unfolding Lyndon.simps
   proof(simp add: assms)
     have "w <lex rotate n w" if "0 < n"  "n < \<^bold>|w\<^bold>|" for n 
     proof-
       have "\<not> w \<bowtie> rotate n w" 
         using rotate_comp_eq[of w n] subsetD[OF \<open>?R\<close>, OF rotate_rel.intros[OF \<open>0 < n\<close> \<open>n < \<^bold>|w\<^bold>|\<close>]]
           mismatch_pair_lcp[of w "rotate n w"] by fastforce
       from mismatch_lexord_linorder[OF this subsetD[OF \<open>?R\<close>, OF rotate_rel.intros[OF \<open>0 < n\<close> \<open>n < \<^bold>|w\<^bold>|\<close>]]]
       show "w <lex rotate n w".
     qed 
     thus "\<forall>n. 0 < n \<and> n < \<^bold>|w\<^bold>| \<longrightarrow> w <lex rotate n w"  by blast 
   qed
 qed
 
 text\<open>It is well known that an acyclic order can be extended to a total strict linear order. This means that
 a word is Lyndon with respect to some order iff its @{term "rotate_rel w"} is acyclic.
 \<close>
 lemma Lyndon_rotate_rel_iff:
   "acyclic (rotate_rel w) \<longleftrightarrow> (\<exists> r. strict_linear_order r \<and> rotate_rel w \<subseteq> r)" (is "?L \<longleftrightarrow> ?R")
 proof
   assume "?R" thus "?L"
     unfolding strict_linear_order_on_def acyclic_def irrefl_def
     using trancl_id trancl_mono by metis
 next
   assume "?L" thus "?R"
     using acyclic_order_extension by auto
 qed
 
-
 lemma slo_linorder: "strict_linear_order r \<Longrightarrow> class.linorder (\<lambda> a b. (a,b) \<in> r\<^sup>=) (\<lambda> a b. (a,b) \<in> r)"
     unfolding strict_linear_order_on_def strict_partial_order_def irrefl_def trans_def total_on_def
     by unfold_locales blast+
 
 text\<open>Application examples\<close>
 
 lemma assumes "w \<noteq> \<epsilon>" and "acyclic (rotate_rel w)" shows "primitive w"
 proof-
   obtain r where "strict_linear_order r" and "rotate_rel w \<subseteq> r"
     using Lyndon_rotate_rel_iff assms by auto
 
   interpret r: linorder "\<lambda> a b. (a,b) \<in> r\<^sup>=" "\<lambda> a b. (a,b) \<in> r" 
     using slo_linorder[OF \<open>strict_linear_order r\<close>]. 
 
   have "r.Lyndon w"
     using r.rotate_rel_iff[OF \<open>w \<noteq> \<epsilon>\<close>] \<open>rotate_rel w \<subseteq> r\<close> by blast
 
   from r.Lyndon_prim[OF this]
   show "primitive w".
 
 qed
 
 lemma assumes "w \<noteq> \<epsilon>" and "acyclic (rotate_rel w)" shows "\<not> bordered w"
 proof-
   obtain r where "strict_linear_order r" and "rotate_rel w \<subseteq> r"
     using Lyndon_rotate_rel_iff assms by auto
 
   interpret r: linorder "\<lambda> a b. (a,b) \<in> r\<^sup>=" "\<lambda> a b. (a,b) \<in> r" 
     using slo_linorder[OF \<open>strict_linear_order r\<close>]. 
 
   have "r.Lyndon w"
     using r.rotate_rel_iff[OF \<open>w \<noteq> \<epsilon>\<close>] \<open>rotate_rel w \<subseteq> r\<close> by blast
 
   from r.Lyndon_unbordered[OF this]
   show "\<not> bordered w".
 qed
 
 end
\ No newline at end of file