diff --git a/metadata/entries/Binary_Code_Imprimitive.toml b/metadata/entries/Binary_Code_Imprimitive.toml --- a/metadata/entries/Binary_Code_Imprimitive.toml +++ b/metadata/entries/Binary_Code_Imprimitive.toml @@ -1,38 +1,42 @@ title = "Binary codes that do not preserve primitivity" date = 2023-01-03 topics = [ "Computer science/Automata and formal languages", ] abstract = """ A code $X$ is not primitivity preserving if there is a primitive list $\\mathtt{ws} \\in \\mathtt{lists} \\ X$ whose concatenation is imprimitive. We formalize a full characterization of such codes in the binary case in the proof assistant Isabelle/HOL. Part of the formalization, interesting on its own, is a description of $\\{x,y\\}$-interpretations of the square $xx$ if $\\mathtt{length}\\ y \\leq \\mathtt{length} \\ x$. We also provide a formalized parametric solution of the related equation $x^jy^k = z^\\ell$. The core of the theory is an investigation of imprimitive words which are concatenations of copies of two noncommuting words (such a pair of words is called a binary code). We follow the article [Barbin-Le Rest, Le Rest, 85] (mainly Théorème 2.1 and Lemme 3.1), while substantially optimizing the proof. See also [J.-C. Spehner. Quelques problèmes d’extension, de conjugaison et de présentation des sous-monoïdes d’un monoïde libre. PhD thesis, Université Paris VII, 1976] for an earlier result on this question, and [Maňuch, 01] for another proof.""" license = "bsd" note = "" [authors] [authors.holub] email = "holub_email" [authors.raska] [contributors] [notify] holub = "holub_email" starosta = "starosta_email" [history] +2023-08-17 = """ +Updated to version v1.10.1. +""" [extra] [related] dois = [ + "10.1007/s10817-023-09674-2", "10.1016/0304-3975(85)90060-X", "10.46298/dmtcs.279", ] pubs = [ "J.-C. Spehner. Quelques problèmes d’extension, de conjugaison et de présentation des sous-monoïdes d’un monoïde libre. PhD thesis, Université Paris VII, 1976", "Development repository", ] 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,46 +1,49 @@ 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, 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] +2023-08-17 = """ +Updated to version v1.10.1. +""" 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 = ["Producing symmetrical facts for lists induced by the list reversal mapping in Isabelle/HOL", "Development repository"] 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,37 +1,42 @@ 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.raska] + [authors.starosta] homepage = "starosta_homepage" [contributors] [notify] holub = "holub_email" starosta = "starosta_email" [history] +2023-08-17 = """ +Updated to version v1.10.1. +""" 2022-08-24 = """ Reworked version. Added theory Glued_Codes. """ [extra] [related] pubs = ["Development repository"] 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,36 +1,39 @@ 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] +2023-08-17 = """ +Updated to version v1.10.1. +""" [extra] [related] dois = ["10.1007/978-3-030-81508-0_18"] pubs = ["Development repository"] diff --git a/metadata/entries/Two_Generated_Word_Monoids_Intersection.toml b/metadata/entries/Two_Generated_Word_Monoids_Intersection.toml --- a/metadata/entries/Two_Generated_Word_Monoids_Intersection.toml +++ b/metadata/entries/Two_Generated_Word_Monoids_Intersection.toml @@ -1,41 +1,44 @@ title = "Intersection of two monoids generated by two element codes" date = 2023-01-03 topics = [ "Computer science/Automata and formal languages", ] abstract = """ This article provides a formalization of the classification of intersection \\( \\{x,y\\}^* \\cap \\{u,v\\}^*\\) of two monoids generated by two element codes. Namely, the intersection has one of the following forms \\( \\{\\beta,\\gamma\\}^* \\quad \\text{ or } \\quad \\left(\\beta_0 + \\beta(\\gamma(1+\\delta+ \\cdots + \\delta^t))^*\\epsilon\\right)^*.\\) Note that it can be infinitely generated. The result is due to [Karhumäki, 84]. Our proof uses the terminology of morphisms which allows us to formulate the result in a shorter and more transparent way.""" license = "bsd" note = "" [authors] [authors.holub] email = "holub_email" [authors.starosta] email = "starosta_email" [contributors] [notify] holub = "holub_email" starosta = "starosta_email" [history] +2023-08-17 = """ +Updated to version v1.10.1. +""" [extra] [related] dois = [ "10.1007/BFb0036924", ] pubs = [ "Development repository", ] diff --git a/thys/Binary_Code_Imprimitive/Binary_Code_Imprimitive.thy b/thys/Binary_Code_Imprimitive/Binary_Code_Imprimitive.thy --- a/thys/Binary_Code_Imprimitive/Binary_Code_Imprimitive.thy +++ b/thys/Binary_Code_Imprimitive/Binary_Code_Imprimitive.thy @@ -1,1168 +1,1156 @@ (* Title: Binary Code Imprimitive - File: Combinatorics_Words_Interpretations.Binary_Code_Imprimitive + File: Binary_Code_Imprimitive.Binary_Code_Imprimitive 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/ *) -chapter "Binary codes that do not preserve primitivity" - theory Binary_Code_Imprimitive - imports - Combinatorics_Words_Graph_Lemma.Glued_Codes + imports + Combinatorics_Words_Graph_Lemma.Glued_Codes Binary_Square_Interpretation begin text \This theory focuses on the characterization of imprimitive words which are concatenations -of copies of two words (forming a binary code). +of copies of two words (forming a binary code). We follow the article @{cite lerest} (mainly Th\'eor\`eme 2.1 and Lemme 3.1), while substantially optimizing the proof. See also @{cite spehner} for an earlier result on this question, and @{cite Manuch} for another proof.\ section \General primitivity not preserving codes\ context code begin text \ Two nontrivially conjugate elements generated by a code induce a disjoint interpretation.\ lemma shift_disjoint: - assumes "ws \ lists \" and "ws' \ lists \" and "z \ \\\" and "z \ concat ws = concat ws' \ z" - "us \p ws\<^sup>@n" and "vs \p ws'\<^sup>@n" + assumes "ws \ lists \" and "ws' \ lists \" and "z \ \\\" and "z \ concat ws = concat ws' \ z" + "us \p ws\<^sup>@n" and "vs \p ws'\<^sup>@n" shows "z \ concat us \ concat vs" using \z \ \\\\ proof (elim contrapos_nn) - assume "z \ concat us = concat vs" + assume "z \ concat us = concat vs" have "z \ \" - using \z \ \\\\ by blast + using \z \ \\\\ by blast obtain us' where "ws\<^sup>@n = us \ us'" - using prefixE[OF \us \p ws\<^sup>@n\]. + using prefixE[OF \us \p ws\<^sup>@n\]. obtain vs' where "ws'\<^sup>@n = vs \ vs'" - using prefixE[OF \vs \p ws'\<^sup>@n\]. + using prefixE[OF \vs \p ws'\<^sup>@n\]. from conjug_pow[OF \z \ concat ws = concat ws' \ z\[symmetric], symmetric] have "z \ concat (ws\<^sup>@n) = concat (ws'\<^sup>@n) \ z" unfolding concat_pow. from this[ unfolded \ws\<^sup>@n = us \ us'\ \ws'\<^sup>@n = vs \ vs'\ concat_morph rassoc \z \ concat us = concat vs\[symmetric] cancel] have "concat vs' \ z = concat us'".. show "z \ \\\" proof (rule stability) have "us \ lists \" and "us' \ lists \" and "vs \ lists \" and "vs' \ lists \" using \ws \ lists \\ \ws' \ lists \\ \ws'\<^sup>@n = vs \ vs'\ \ws\<^sup>@n = us \ us'\ by inlists thus "z \ concat us \ \\\" and "concat vs' \ \\\" and "concat us \ \\\" and "concat vs' \ z \ \\\" unfolding \concat vs' \ z = concat us'\ \z \ concat us = concat vs\ - by (simp_all add: concat_in_hull') + by (simp_all add: concat_in_hull') qed qed text\This in particular yields a disjoint extendable interpretation of any prefix\ -lemma shift_interpret: +lemma shift_interp: assumes "ws \ lists \" and "ws' \ lists \" and "z \ \\\" and - conjug: "z \ concat ws = concat ws' \ z" and "\<^bold>|z\<^bold>| < \<^bold>|concat ws'\<^bold>|" + conjug: "z \ concat ws = concat ws' \ z" and "\<^bold>|z\<^bold>| \ \<^bold>|concat ws'\<^bold>|" and "us \p ws" and "us \ \" - obtains p s vs ps ss where "p (concat us) s \\<^sub>\ vs" and "ps \ vs \p ws' \ ws'" - and "us \ ss = ws \ ws" and - "concat ps \ p = z" and "s \p concat ss" and "p \s concat ws" and "vs \ lists \" - "\ us' vs'. us' \p us \ vs' \p vs \ p \ concat us' \ concat vs'" and "p \ \" and "s \ \" + obtains p s vs ps where + "p us s \\<^sub>\ vs" and "vs \ lists \" + and "s \p concat (us\\<^sup>>(ws \ ws))" and "p \s concat ws" \ \extendable\ + and "ps \ vs \p ws' \ ws'" and "concat ps \ p = z" proof- have "ws' \ ws' \ lists \" using \ws' \ lists \\ by inlists have "concat us \ \" using \us \ \\ unfolding code_concat_eq_emp_iff[OF pref_in_lists[OF \us \p ws\ \ws \ lists \\]]. have "\<^bold>|concat ws'\<^bold>| = \<^bold>|concat ws\<^bold>|" using lenarg[OF conjug, unfolded lenmorph] by linarith have "z \ concat(ws \ ws) = concat (ws' \ ws') \ z" - unfolding rassoc concat_morph conjug[symmetric] unfolding lassoc cancel_right + unfolding rassoc concat_morph conjug[symmetric] unfolding lassoc cancel_right using conjug. - hence "concat (ws' \ ws') \p z \ concat (ws \ ws)" + hence "concat (ws' \ ws') \p z \ concat (ws \ ws)" by blast have "z \ concat ws \p concat (ws' \ ws')" - unfolding concat_morph conjug pref_cancel_conv using eq_le_pref[OF conjug less_imp_le[OF \\<^bold>|z\<^bold>| < \<^bold>|concat ws'\<^bold>|\]]. + unfolding concat_morph conjug pref_cancel_conv using eq_le_pref[OF conjug \\<^bold>|z\<^bold>| \ \<^bold>|concat ws'\<^bold>|\]. from prefixE[OF pref_shorten[OF pref_concat_pref[OF \us \p ws\] this], unfolded rassoc] - obtain su where fac_u[symmetric]: "concat (ws' \ ws') = z \ concat us \ su". + obtain su where fac_u[symmetric]: "concat (ws' \ ws') = z \ concat us \ su". - from obtain_fac_interpret[OF fac_u \concat us \ \\] + from obtain_fac_interp[OF fac_u \concat us \ \\] obtain ps ss' p s vs where "p (concat us) s \\<^sub>\ vs" and "ps \ vs \ ss' = ws' \ ws'" and "concat ps \ p = z" and "s \ concat ss' = su". - note fac_interpretE[OF \p (concat us) s \\<^sub>\ vs\] + note fac_interpD[OF \p (concat us) s \\<^sub>\ vs\] - from prefixE[OF pref_ext[OF \us \p ws\]] - obtain ss where [symmetric]:"ws \ ws = us \ ss". + let ?ss = "us\\<^sup>>(ws \ ws)" + have "us \ ?ss = ws \ ws" + using \us \p ws\ by auto have "ps \ vs \p ws' \ ws'" unfolding \ps \ vs \ ss' = ws' \ ws'\[symmetric] lassoc using triv_pref. hence "vs \ lists \" using \ws'\ lists \\ by inlists - from \concat (ws' \ ws') \p z \ concat (ws \ ws)\[folded arg_cong[OF \ps \ vs \ ss' = ws' \ ws'\, of concat] \us \ ss = ws \ ws\, - unfolded concat_morph, folded \p \ concat us \ s = concat vs\ \concat ps \ p = z\, - unfolded rassoc pref_cancel_conv] - have "s \p concat ss" - using append_prefixD by blast + have "s \p concat ?ss" + using \concat (ws' \ ws') \p z \ concat (ws \ ws)\ + unfolding arg_cong[OF \ps \ vs \ ss' = ws' \ ws'\, of concat, symmetric] \concat ps \ p = z\[symmetric] + arg_cong[OF \us \ ?ss = ws \ ws\, of concat, symmetric] + unfolding concat_morph rassoc pref_cancel_conv + \p \ concat us \ s = concat vs\[symmetric] + using append_prefixD by auto have "\<^bold>|p\<^bold>| \ \<^bold>|concat ws\<^bold>|" - using \\<^bold>|z\<^bold>| < \<^bold>|concat ws'\<^bold>|\[folded lenarg[OF \concat ps \ p = z\], unfolded \\<^bold>|concat ws'\<^bold>| = \<^bold>|concat ws\<^bold>|\] + using \\<^bold>|z\<^bold>| \ \<^bold>|concat ws'\<^bold>|\[folded lenarg[OF \concat ps \ p = z\], unfolded \\<^bold>|concat ws'\<^bold>| = \<^bold>|concat ws\<^bold>|\] by simp with eqd[reversed, OF conjug[folded \concat ps \ p = z\, unfolded lassoc, symmetric] this] have "p \s concat ws" by blast have disjoint: "p \ concat us' \ concat vs'" if "us' \p us" "vs' \p vs" for us' vs' proof have "us' \p ws \ ws" using \us \p ws\ \us' \p us\ by auto - have "ps \ vs' \p ws' \ ws'" - using \vs' \p vs\ \ps \ vs \p ws' \ ws'\ pref_trans same_prefix_prefix by metis + have "ps \ vs' \p ws' \ ws'" + using \vs' \p vs\ \ps \ vs \p ws' \ ws'\ pref_trans same_prefix_prefix by metis assume "p \ concat us' = concat vs'" hence "z \ concat us' = concat (ps \ vs')" unfolding concat_morph \concat ps \ p = z\[symmetric] rassoc cancel. thus False using shift_disjoint[OF \ws \ lists \\ \ws' \ lists \\ \z \ \\\\ \z \ concat ws = concat ws' \ z\ \us' \p ws \ ws\[folded pow_two] \ps \ vs' \p ws' \ ws'\[folded pow_two]] by fast qed - from disjoint[of \ \] + from disjoint[of \ \] have "p \ \" by blast have "s \ \" using \p \ concat us \ s = concat vs\ disjoint by auto - - from that[OF \p (concat us) s \\<^sub>\ vs\ \ps \ vs \p ws' \ ws'\ \us \ ss = ws \ ws\ \concat ps \ p = z\ \s \p concat ss\ \p \s concat ws\ \vs \ lists \\ - disjoint \p \ \\ \ s \ \\] + + from disjoint_interpI[OF \p (concat us) s \\<^sub>\ vs\] disjoint + have "p us s \\<^sub>\ vs" + by blast + + from that[OF this \vs \ lists \\ + \s \p concat ?ss\ \p \s concat ws\ \ps \ vs \p ws' \ ws'\ \concat ps \ p = z\ ] show thesis. qed text\The conditions are in particular met by imprimitivity witnesses\ lemma imprim_witness_shift: assumes "ws \ lists \" and "primitive ws" and "\ primitive (concat ws)" - obtains z n where "concat ws = z\<^sup>@Suc(Suc n)" "z \ \\\" and "z \ concat ws = concat ws \ z" and "\<^bold>|z\<^bold>| < \<^bold>|concat ws\<^bold>|" + obtains z n where "concat ws = z\<^sup>@n" "z \ \\\" and + "z \ concat ws = concat ws \ z" and "\<^bold>|z\<^bold>| < \<^bold>|concat ws\<^bold>|" and "2 \ n" proof- - have "concat ws \ \" - using \primitive ws\ emp_concat_emp'[OF \ws \ lists \\] emp_not_prim by blast - obtain z n where [symmetric]: "z\<^sup>@Suc(Suc n) = concat ws" - using not_prim_primroot_expE[OF \\ primitive (concat ws)\ \concat ws \ \\, of thesis] by force - - hence "z \ \" - using \concat ws \ \\ by force + have "concat ws \ \" + using \primitive ws\ emp_concat_emp'[OF \ws \ lists \\] emp_not_prim by blast + obtain z n where [symmetric]: "z\<^sup>@n = concat ws" and "2 \ n" + using not_prim_primroot_expE[OF \\ primitive (concat ws)\] by metis - have "z \ \\\" + hence "z \ \" + using \concat ws \ \\ by force + + have "z \ \\\" proof - assume "z \ \\\" + assume "z \ \\\" then obtain zs where "zs \ lists \" and "concat zs = z" - using hull_concat_lists0 by blast + using hull_concat_lists0 by blast from is_code[OF \ws \ lists \\ pow_in_lists[OF \zs \ lists \\], - unfolded concat_pow \concat ws = z\<^sup>@Suc(Suc n)\ \concat zs = z\] + unfolded concat_pow \concat ws = z\<^sup>@n\ \concat zs = z\, of n] show False - using \primitive ws\ pow_not_prim by blast - qed + using \primitive ws\ \2 \ n\ pow_nemp_imprim by blast + qed have "\<^bold>|z\<^bold>| < \<^bold>|concat ws\<^bold>|" - unfolding lenarg[OF \concat ws = z\<^sup>@Suc(Suc n)\, unfolded lenmorph pow_len] - using nemp_len[OF \z \ \\] by simp + unfolding lenarg[OF \concat ws = z\<^sup>@n\, unfolded lenmorph pow_len] + using nemp_len[OF \z \ \\] \2 \ n\ by simp - from that[OF \concat ws = z\<^sup>@Suc(Suc n)\ \z \ \\\\ _ this] + from that[OF \concat ws = z\<^sup>@n\ \z \ \\\\ _ this \2 \ n\] show thesis - unfolding \concat ws = z\<^sup>@Suc(Suc n)\ pow_comm by blast + unfolding \concat ws = z\<^sup>@n\ pow_comm by blast qed end section \Covered uniform square\ \ \Showing that two noncommuting words of the same length do not admit a non-trivial interpretation\ lemma cover_xy_xxx: assumes "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|" and "p \ x \ y \ s = x \ x \ x" shows "x = y" - using append_assoc assms(1) assms(2) eq_le_pref le_refl long_pref lq_triv prefI pref_comm_eq' by metis + using append_assoc assms(1) assms(2) eq_le_pref le_refl long_pref lq_triv prefI pref_comm_eq' by metis lemma cover_xy_yyy: assumes "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|" and eq: "p \ x \ y \ s = y \ y \ y" shows "x = y" - using cover_xy_xxx[reversed, unfolded rassoc, OF \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\[symmetric] eq, symmetric]. + using cover_xy_xxx[reversed, unfolded rassoc, OF \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\[symmetric] eq, symmetric]. lemma cover_xy_xxy: assumes "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|" and "s \ \" and eq: "p \ x \ y \ s = x \ x \ y" shows "x = y" proof- have "\<^bold>|p\<^bold>| < \<^bold>|x\<^bold>|" using lenarg[OF eq] nemp_pos_len[OF \s \ \\] unfolding lenmorph by linarith then obtain t where x: "x = p \ t" and "t \ \" - using eqd[OF eq] by force + using eqd[OF eq] by force from eq[unfolded this rassoc cancel] - have "p \ t = t \ p" + have "p \ t = t \ p" by mismatch hence "x \p t \ x" - unfolding x by auto - from eq[unfolded x] - have "y \p t \ y" - using \p \ t = t \ p\ \p \ t \ y \ s = t \ p \ t \ y\ pref_cancel' suf_marker_per_root triv_pref by metis + unfolding x by auto + from eq[unfolded x] + have "y \p t \ y" + using \p \ t = t \ p\ \p \ t \ y \ s = t \ p \ t \ y\ pref_cancel' suf_marker_per_root triv_pref by metis show "x = y" - using same_len_nemp_root_eq[OF \x \p t \ x\ \y \p t \ y\ \t \ \\ \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\]. + using same_len_nemp_root_eq[OF per_rootI[OF \x \p t \ x\ \t \ \\] + per_rootI[OF \y \p t \ y\ \t \ \\] \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\]. qed lemma cover_xy_xyy: assumes "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|" and "p \ \" and eq: "p \ x \ y \ s = x \ y \ y" shows "x = y" using cover_xy_xxy[reversed, unfolded rassoc, OF assms(1)[symmetric] assms(2) eq].. lemma cover_xy_yyx: assumes "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|" and eq: "p \ x \ y \ s = y \ y \ x" shows "x = y" proof- have "\<^bold>|p\<^bold>| \ \<^bold>|y\<^bold>|" using lenarg[OF eq] unfolding lenmorph by linarith then obtain t where y: "y = p \ t" - using eqd[OF eq] by force - from eqd_eq[OF _ \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\[unfolded y swap_len[of p]], unfolded rassoc, - OF eq[unfolded this rassoc cancel]] + using eqd[OF eq] by force + from eqd_eq[OF _ \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\[unfolded y swap_len[of p]], unfolded rassoc] eq[unfolded this rassoc cancel] have x: "x = t \ p" by blast from eq[unfolded x y rassoc cancel] have "p \ t = t \ p" by mismatch thus "x = y" - unfolding x y.. + unfolding x y.. qed lemma cover_xy_yxx: assumes "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|" and eq: "p \ x \ y \ s = y \ x \ x" shows "x = y" using cover_xy_yyx[reversed, unfolded rassoc, OF assms(1)[symmetric] eq].. lemma cover_xy_xyx: assumes "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|" and "p \ \" and "s \ \" and eq: "p \ x \ y \ s = x \ y \ x" shows "\ primitive (x \ y)" -proof +proof assume "primitive (x \ y)" have "p \ (x \ y) \ (s \ y) = (x \ y) \ (x \ y)" - unfolding lassoc eq[unfolded lassoc].. + unfolding lassoc eq[unfolded lassoc].. from prim_overlap_sqE[OF \primitive (x \ y)\ this] show False using \p \ \\ \s \ \\ by blast -qed +qed lemma cover_xy_yxy: assumes "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|" and "p \ \" and \s \ \\ and eq: "p \ x \ y \ s = y \ x \ y" shows "\ primitive (x \ y)" - using cover_xy_xyx[reversed, unfolded rassoc, OF assms(1)[symmetric] assms(3) assms(2) eq]. - -lemma eq_append_not_prim: "x = y \ \ primitive (x \ y)" - by (metis append_Nil2 comm_not_prim prim_nemp) + using cover_xy_xyx[reversed, unfolded rassoc, OF assms(1)[symmetric] assms(3) assms(2) eq]. theorem uniform_square_interp: assumes "x\y \ y\x" and "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|" and "vs \ lists {x,y}" and "p (x \ y) s \\<^sub>\ vs" and "p \ \" shows "\ primitive (x\y)" and "vs = [x,y,x] \ vs = [y,x,y]" proof- - note fac_interpretE[OF \p (x \ y) s \\<^sub>\ vs\] + note fac_interpD[OF \p (x \ y) s \\<^sub>\ vs\] have "vs \ \" using \p \ (x \ y) \ s = concat vs\ assms(5) by force have "\<^bold>|p\<^bold>| < \<^bold>|x\<^bold>|" - using prefix_length_less[OF \p

] lists_hd_in_set[OF \vs \ \\ \vs \ lists {x,y}\] + using prefix_length_less[OF \p

] lists_hd_in_set[OF \vs \ \\ \vs \ lists {x,y}\] \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\ - by fastforce + by fastforce have "\<^bold>|s\<^bold>| < \<^bold>|x\<^bold>|" using suffix_length_less[OF \s ] \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\ lists_hd_in_set[reversed, OF \vs \ \\ \vs \ lists {x,y}\] by fastforce have "\<^bold>|concat vs\<^bold>| = \<^bold>|x\<^bold>| * \<^bold>|vs\<^bold>|" using assms(2-3) - proof (induction vs, force) + proof (induction vs) case (Cons a vs) have "\<^bold>|a\<^bold>| = \<^bold>|x\<^bold>|" and "\<^bold>|a # vs\<^bold>| = Suc \<^bold>|vs\<^bold>|" and "\<^bold>|concat (a # vs)\<^bold>| = \<^bold>|a\<^bold>| + \<^bold>|concat vs\<^bold>|" and "\<^bold>|concat vs\<^bold>| = \<^bold>|x\<^bold>| * \<^bold>|vs\<^bold>|" - using \a#vs \ lists {x,y}\ \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\ Cons.IH Cons.prems by auto + using \a#vs \ lists {x,y}\ \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\ Cons.IH Cons.prems by auto then show ?case by force - qed + qed simp note leneq = lenarg[OF \p \ (x \ y) \ s = concat vs\, unfolded this lenmorph \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\[symmetric]] - hence "\<^bold>|x\<^bold>| * \<^bold>|vs\<^bold>| < \<^bold>|x\<^bold>| * 4" and "2 * \<^bold>|x\<^bold>| < \<^bold>|x\<^bold>| * \<^bold>|vs\<^bold>| " + hence "\<^bold>|x\<^bold>| * \<^bold>|vs\<^bold>| < \<^bold>|x\<^bold>| * 4" and "2 * \<^bold>|x\<^bold>| < \<^bold>|x\<^bold>| * \<^bold>|vs\<^bold>| " using \\<^bold>|p\<^bold>| < \<^bold>|x\<^bold>|\ \\<^bold>|s\<^bold>| < \<^bold>|x\<^bold>|\ nemp_pos_len[OF \p \ \\] by linarith+ hence "\<^bold>|vs\<^bold>| = 3" by force - hence "s \ \" + hence "s \ \" using leneq \\<^bold>|p\<^bold>| < \<^bold>|x\<^bold>|\ by force - + have "x \ y" using assms(1) by blast with \\<^bold>|vs\<^bold>| = 3\ \vs \ lists {x,y}\ \p \ (x \ y) \ s = concat vs\ have "(\ primitive (x\y)) \ (vs = [x,y,x] \ vs = [y,x,y])" proof(list_inspection, simp_all) - assume "p \ x \ y \ s = x \ x \ x" + assume "p \ x \ y \ s = x \ x \ x" from cover_xy_xxx[OF \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\ this] show False using \x \ y\ by blast next - assume "p \ x \ y \ s = x \ x \ y" + assume "p \ x \ y \ s = x \ x \ y" from cover_xy_xxy[OF \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\ \s \ \\ this] show False using \x \ y\ by blast next - assume "p \ x \ y \ s = x \ y \ x" + assume "p \ x \ y \ s = x \ y \ x" from cover_xy_xyx[OF \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\ \p \ \\ \s \ \\ this] show "\ primitive (x \ y)" - by blast + by blast next - assume "p \ x \ y \ s = x \ y \ y" + assume "p \ x \ y \ s = x \ y \ y" from cover_xy_xyy[OF \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\ \p \ \\ this] show False - using \x \ y\ by blast + using \x \ y\ by blast next - assume "p \ x \ y \ s = y \ x \ x" + assume "p \ x \ y \ s = y \ x \ x" from cover_xy_yxx[OF \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\ this] show False - using \x \ y\ by blast + using \x \ y\ by blast next - assume "p \ x \ y \ s = y \ x \ y" + assume "p \ x \ y \ s = y \ x \ y" from cover_xy_yxy[OF \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\ \p \ \\ \s \ \\ this] show "\ primitive (x \ y)" - by blast + by blast next - assume "p \ x \ y \ s = y \ y \ x" + assume "p \ x \ y \ s = y \ y \ x" from cover_xy_yyx[OF \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\ this] show False - using \x \ y\ by blast + using \x \ y\ by blast next - assume "p \ x \ y \ s = y \ y \ y" + assume "p \ x \ y \ s = y \ y \ y" from cover_xy_yyy[OF \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\ this] show False - using \x \ y\ by blast + using \x \ y\ by blast qed thus "\ primitive (x\y)" "vs = [x,y,x] \ vs = [y,x,y]" by blast+ qed subsection \Primitivity (non)preserving uniform binary codes\ \ \This in particular implies the following characterization of uniform binary primitive codes. Cf. V. Mitrana, Primitive morphisms, Information Processing Letters 64 (1997), 277--281\ theorem bin_uniform_prim_morph: assumes "x \ y \ y \ x" and "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|" and "primitive (x \ y)" and "ws \ lists {x,y}" and "2 \ \<^bold>|ws\<^bold>|" shows "primitive ws \ primitive (concat ws)" proof (standard, rule ccontr) assume \primitive ws\ and \\ primitive (concat ws)\ from bin_prim_long_pref[OF \ws \ lists {x,y}\ \primitive ws\ \2 \ \<^bold>|ws\<^bold>|\] obtain ws' where "ws \ ws'" "[x, y] \p ws'". have "ws' \ lists {x,y}" using conjug_in_lists'[OF \ws \ ws'\ \ws \ lists {x,y}\]. have "primitive ws'" - using prim_conjug[OF \primitive ws\ \ws \ ws'\]. + using prim_conjug[OF \primitive ws\ \ws \ ws'\]. have "\ primitive (concat ws')" - using conjug_concat_prim_iff \\ primitive (concat ws)\ \ws \ ws'\ by auto + using conjug_concat_prim_iff \\ primitive (concat ws)\ \ws \ ws'\ by auto interpret code "{x,y}" using bin_code_code[OF \x \ y \ y \ x\]. - + have "[x,y] \ \" by blast from imprim_witness_shift[OF \ws' \ lists {x,y}\ \primitive ws'\ \\ primitive (concat ws')\] - obtain z n where "concat ws' = z \<^sup>@ Suc (Suc n)" "z \ \{x, y}\" "z \ concat ws' = concat ws' \ z" "\<^bold>|z\<^bold>| < \<^bold>|concat ws'\<^bold>|". - from shift_interpret[OF \ws' \ lists {x,y}\ \ws' \ lists {x,y}\ this(2-4) \[x,y] \p ws'\ \[x,y] \ \\] - obtain vs p s where "vs \ lists {x,y}" "p (concat [x, y]) s \\<^sub>\ vs" "p \ \" by metis - from uniform_square_interp(1)[OF \x \ y \ y \ x\ \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\ \vs \ lists {x,y}\ _ \p \ \\] - \primitive (x \ y)\ \p (concat [x, y]) s \\<^sub>\ vs\ + obtain z n where "concat ws' = z \<^sup>@ n" "z \ \{x, y}\" "z \ concat ws' = concat ws' \ z" "\<^bold>|z\<^bold>| < \<^bold>|concat ws'\<^bold>|". + from shift_interp[OF \ws' \ lists {x,y}\ \ws' \ lists {x,y}\ this(2-3) less_imp_le[OF this(4)] \[x,y] \p ws'\ \[x,y] \ \\] + obtain p s vs ps where "p [x, y] s \\<^sub>\ vs" "vs \ lists {x, y}" "s \p concat ([x, y]\\<^sup>>(ws' \ ws'))" + "p \s concat ws'" "ps \ vs \p ws' \ ws'" "concat ps \ p = z". + from uniform_square_interp(1)[OF \x \ y \ y \ x\ \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\ \vs \ lists {x,y}\ _ _] + \primitive (x \ y)\ disj_interpD[OF this(1), simplified] disj_interp_nemp(1)[OF this(1)] show False by force qed (simp add: prim_concat_prim) \ \A stronger version is implied by the following lemma.\ -lemma bin_uniform_imprim: assumes "x \ y \ y \ x" and "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|" and "\ primitive x" - shows "primitive (x \ y)" -proof (rule ccontr) - obtain s n where "s\<^sup>@n = x" and "2 \ n" - using not_prim_pow[OF \\ primitive x\]. - assume "\ primitive (x \ y)" - have "x \ y \ \" - using \x \ y \ y \ x\ by blast - from not_prim_expE[OF \\ primitive (x \ y)\ this] +lemma bin_uniform_imprim: assumes "x \ y \ y \ x" and "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|" and "\ primitive (x \ y)" + shows "primitive x" +proof- + have "x \ y \ \" and "x \ \" and "y \ \" + using \x \ y \ y \ x\ by blast+ + from not_prim_expE[OF \\ primitive (x \ y)\ \x \ y \ \\] obtain z k where "primitive z" and "2 \ k" and "z\<^sup>@k = x \ y". - from split_pow[OF \x \ y \ y \ x\ \z\<^sup>@k = x \ y\[symmetric]] - obtain l m u v where "z \<^sup>@ l \ u = x" "v \ z \<^sup>@ m = y" "u \ v = z" "u \ v \ v \ u" "k = Suc (l + m)". - have "u \ \" and "v \ \" + hence "0 < k" + by simp + from split_pow[OF \z\<^sup>@k = x \ y\[symmetric] \0 < k\ \y \ \\] + obtain u v l m where [symmetric]: "z = u \ v" and "v \ \" "x = (u\v) \<^sup>@ l \ u" "y = (v \ u) \<^sup>@ m \ v" "k = l + m + 1". + have "u \ v \ v \ u" + using \x \ y \ y \ x\ unfolding \x = (u\v) \<^sup>@ l \ u\ \y = (v \ u) \<^sup>@ m \ v\ + shifts unfolding add_exps[symmetric] add.commute[of m] by force + have "u \ \" and "v \ \" and "u \ v" using \u \ v \ v \ u\ by blast+ - have "m = l" and "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|" - using almost_equal_equal[OF nemp_len[OF \u \ \\] nemp_len[OF \v \ \\], of l m] lenarg[OF \z\<^sup>@l \ u = x\[symmetric], unfolded \\<^bold>|x\<^bold>| =\<^bold>|y\<^bold>|\, folded lenarg[OF \v \ z\<^sup>@m = y\]] unfolding lenmorph pow_len - lenarg[OF \u \ v = z\, symmetric] by presburger+ - have "x \p z \ x" - using pref_prod_root[OF pref_ext[of x, OF self_pref, of y, folded \z\<^sup>@k = x \ y\]]. - have "x \p s \ x" - unfolding \s\<^sup>@n = x\[symmetric] using pref_prod_root by blast - have "z \ s \ s \ z" - using \x \ y \ y \ x\ comm_add_exps[of s z n k, unfolded \s \<^sup>@ n = x\ \z \<^sup>@ k = x \ y\ rassoc cancel] - by force - with two_pers[OF \x \p z \ x\ \x \p s \ x\] - have "\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|s\<^bold>|" by linarith - have "l = 1" - proof (rule ccontr) - assume "l \ 1" hence "2 \ l" - using \k = Suc (l + m)\ \2 \ k\ unfolding \m = l\ by force - from trans_le_add1[OF mult_le_mono1[OF this]] - have "2*\<^bold>|z\<^bold>| \ \<^bold>|x\<^bold>|" - unfolding lenarg[OF \z\<^sup>@l \ u = x\, unfolded pow_len lenmorph, symmetric]. - from mult_le_mono1[OF \2 \ n\] - have "2*\<^bold>|s\<^bold>| \ \<^bold>|x\<^bold>|" - unfolding lenarg[OF \s\<^sup>@n = x\, unfolded pow_len lenmorph, symmetric]. - hence "2*\<^bold>|z\<^bold>| + 2*\<^bold>|s\<^bold>| \ 2*\<^bold>|x\<^bold>|" - using \2*\<^bold>|z\<^bold>| \ \<^bold>|x\<^bold>|\ by force - thus False - using mult_less_mono1[OF \\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|s\<^bold>|\, of 2] by force - qed - hence "x = u \ v \ u" - using \u \ v = z\ \z \<^sup>@ l \ u = x\ by fastforce - have "u \ v" - using \u \ v \ v \ u\ by blast - hence "primitive [u,v,u]" - by primitivity_inspection - hence "primitive [u,v,u] \ primitive (concat [u, v, u])" - using \x = u \ v \ u\ \\ primitive x\ by auto - with bin_uniform_prim_morph[OF \u \ v \ v \ u\ \\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|\ \primitive z\[folded \u \ v = z\], of "[u,v,u]"] - show False by simp + have "m = l" and "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|" + using almost_equal_equal[OF nemp_len[OF \u \ \\] nemp_len[OF \v \ \\], of l m] lenarg[OF \x = (u\v)\<^sup>@l \ u\, unfolded \\<^bold>|x\<^bold>| =\<^bold>|y\<^bold>|\, unfolded lenarg[OF \y = (v \ u) \<^sup>@ m \ v\]] + unfolding lenmorph pow_len lenarg[OF \u \ v = z\, symmetric] by algebra+ + from \k = l + m + 1\[folded Suc_eq_plus1, symmetric] + have "l \ 0" + using \2 \ k\[folded \Suc(l+m) = k\, unfolded \m = l\] by force + let ?w = "[u,v]\<^sup>@l \ [u]" + have "?w \ lists {u,v}" + by (induct l, simp_all) + have "2 \ \<^bold>|?w\<^bold>|" + using \l \ 0\ unfolding lenmorph pow_len by fastforce + have "concat ?w = x" + using \x = (u \ v) \<^sup>@ l \ u\ by simp + from bin_uniform_prim_morph[OF \u \ v \ v \ u\ \\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|\ \primitive z\[folded \u \ v = z\] \?w \ lists {u,v}\ \2 \ \<^bold>|?w\<^bold>|\] + show "primitive x" + unfolding \concat ?w = x\ using alternate_prim[OF \u \ v\] by blast qed + theorem bin_uniform_prim_morph': - assumes "x \ y \ y \ x" and "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|" and "primitive (x \ y) \ \ primitive x" + assumes "x \ y \ y \ x" and "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|" and "primitive (x \ y) \ \ primitive x \ \ primitive y" and "ws \ lists {x,y}" and "2 \ \<^bold>|ws\<^bold>|" shows "primitive ws \ primitive (concat ws)" - using bin_uniform_prim_morph[OF assms(1-2) _ assms(4-5)] bin_uniform_imprim[OF assms(1-2)] assms(3) by fast + using bin_uniform_prim_morph[OF assms(1-2) _ assms(4-5)] bin_uniform_imprim[OF assms(1-2)] + bin_uniform_imprim[OF assms(1-2)[symmetric], unfolded conjug_prim_iff'[of y]] + assms(3) by blast section \The main theorem\ subsection \Imprimitive words with single y\ text \If the shorter word occurs only once, the result is straightforward from the parametric solution of the Lyndon-Schutzenberger equation.\ -lemma bin_imprim_single_y: +lemma bin_imprim_single_y: assumes non_comm: "x \ y \ y \ x" and "ws \ lists {x,y}" and "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" and "2 \ count_list ws x" and "count_list ws y < 2" and - "primitive ws" and + "primitive ws" and "\ primitive (concat ws)" shows "ws \ [x,x,y]" and "primitive x" and "primitive y" proof- - have "x \ y" + have "x \ y" using non_comm by blast have "count_list ws y \ 0" proof assume "count_list ws y = 0" from bin_lists_count_zero'[OF \ws \ lists {x,y}\ this] have "ws \ lists {x}". from prim_exp_one[OF \primitive ws\ sing_lists_exp_count[OF this]] show False using \2 \ count_list ws x\ by simp qed hence "count_list ws y = 1" using \count_list ws y < 2\ by linarith from this bin_count_one_conjug[OF \ws \ lists {x,y}\ _ this] have "ws \ [x]\<^sup>@count_list ws x \ [y]" - using non_comm (1) by metis + using non_comm (1) by metis from conjug_concat_prim_iff[OF this] have "\ primitive (x\<^sup>@(count_list ws x) \ y)" - using \\ primitive (concat ws)\ by (auto simp add: concat_pow) + using \\ primitive (concat ws)\ by simp - from not_prim_pow[OF this] + from not_prim_primroot_expE[OF this] obtain z l where [symmetric]: "z\<^sup>@l = x\<^sup>@(count_list ws x) \ y\<^sup>@1" and "2 \ l" - unfolding pow_one'. + unfolding pow_1. interpret LS_len_le x y "count_list ws x" 1 l z - apply (unfold_locales; fact?) - using \2 \ count_list ws x\ by auto + by (unfold_locales) + (use \2 \ count_list ws x\ \x \ y \ y \ x\ \ \<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|\ + \x \<^sup>@ count_list ws x \ y \<^sup>@ 1 = z \<^sup>@ l\ \2 \ l\ in force)+ from case_j2k1[OF \2 \ count_list ws x\ refl] have "primitive x" and "primitive y" and "count_list ws x = 2" by blast+ with \ws \ [x]\<^sup>@count_list ws x \ [y]\[unfolded this(3) pow_two append_Cons append_Nil] show "primitive x" and "primitive y" and "ws \ [x,x,y]" - by simp_all - + by simp_all + qed subsection \Conjugate words\ - -lemma bin_imprim_not_conjug: +lemma bin_imprim_not_conjug: assumes "ws \ lists {x,y}" and "x \ y \ y \ x" and "2 \ \<^bold>|ws\<^bold>|" and - "primitive ws" and + "primitive ws" and "\ primitive (concat ws)" shows "\ x \ y" proof assume "x \ y" hence "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|" by force - from bin_uniform_prim_morph[OF \x \ y \ y \ x\ this _ \ws \ lists {x,y}\ \2 \ \<^bold>|ws\<^bold>|\] + from bin_uniform_prim_morph[OF \x \ y \ y \ x\ this _ \ws \ lists {x,y}\ \2 \ \<^bold>|ws\<^bold>|\] have "\ primitive (x\y)" using \primitive ws\ \\ primitive (concat ws)\ by blast - (* have "[x,y] \ \" and "\<^bold>|[x,y]\<^bold>| \ \<^bold>|ws\<^bold>|" and "concat[x,y] = x \ y" *) - (* using \2 \ \<^bold>|ws\<^bold>|\ by auto *) - - (* interpret binary_code x y *) - (* using \x \ y \ y \ x\ by unfold_locales *) - (* from switch_fac[OF bin_code_neq bin_prim_long_set[OF \ws \ lists {x,y}\ \primitive ws\ \2 \ \<^bold>|ws\<^bold>|\]] *) - (* have "[x,y] \f ws \ ws". *) - (* from rotate_into_pref_sq[OF this] *) - (* obtain ws' where "ws \ ws'" and "[x,y] \p ws'" *) - (* using \2 \ \<^bold>|ws\<^bold>|\ by auto *) - (* have "ws' \ lists {x,y}" and "primitive ws'" and "\ primitive (concat ws')" *) - (* using \ws \ lists {x,y}\[unfolded conjug_in_lists_iff [OF \ws \ ws'\]] *) - (* prim_conjug[OF \primitive ws\ \ws \ ws'\] *) - (* \\ primitive (concat ws)\[unfolded conjug_concat_prim_iff[OF \ws \ ws'\]]. *) - - (* from imprim_witness_shift[OF \ws' \ lists {x,y}\ \primitive ws'\ \\ primitive (concat ws')\] *) - (* obtain z where "z \ \{x, y}\" and "z \ concat ws' = concat ws' \ z" and "\<^bold>|z\<^bold>| < \<^bold>|concat ws'\<^bold>|". *) - (* from shift_interpret[OF \ws' \ lists {x,y}\ \ws' \ lists {x,y}\ this \[x,y] \p ws'\ \[x,y] \ \\] *) - (* obtain p s vs where "p (x \ y) s \\<^sub>\ vs" and \vs \ lists {x, y}\ and *) - (* disjoint: "(\us' vs'. us' \p [x, y] \ vs' \p vs \ p \ concat us' \ concat vs')" *) - (* unfolding \concat [x,y] = x \ y\ by metis *) - (* from disjoint[of \ \] have "p \ \" by simp *) - (* from uniform_square_interp(1)[OF \x\y \ y\x\ conjug_len[OF \x \ y\] \vs \ lists {x, y}\ *) - (* \p (x \ y) s \\<^sub>\ vs\ \p \ \\] *) - (* have "\ primitive (x \ y)". *) - from Lyndon_Schutzenberger_conjug[OF \x \ y\ this] - show False + + + from Lyndon_Schutzenberger_conjug[OF \x \ y\ this] + show False using \x \ y \ y \ x\ by blast qed -subsection \Square prefix of the longer word and both words primitive (was all\_assms\ +subsection \Square factor of the longer word and both words primitive (was all\_assms)\ text\The main idea of the proof is as follows: Imprimitivity of the concatenation yields -(at least) two overlapping factorizations into @{term "{x,y}"}. -Due to the presence of the square @{term "x \ x"}, these two can be synchronized, which yields that the +(at least) two overlapping factorizations into @{term "{x,y}"}. +Due to the presence of the square @{term "x \ x"}, these two can be synchronized, which yields that the situation coincides with the canonical form. \ lemma bin_imprim_primitive: assumes "x \ y \ y \ x" and "primitive x" and "primitive y" and "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" and "ws \ lists {x, y}" and "primitive ws" and "\ primitive (concat ws)" and "[x, x] \f ws \ ws" shows "ws \ [x, x, y]" proof- + \ \Preliminaries\ have "x \ y" using assms(1) by blast - hence "2 \ \<^bold>|ws\<^bold>|" - by (metis Cons_in_lists_iff Suc_1 Suc_leI assms(2) assms(3) assms(5) assms(6) assms(7) nemp_le_len order_le_less prim_nemp sing_word_concat two_elem_cases) - have "\<^bold>|[x, x]\<^bold>| \ \<^bold>|ws\<^bold>|" - using \2 \ \<^bold>|ws\<^bold>|\ by force - obtain ws' where "ws \ ws'" "[x,x] \p ws'" - using rotate_into_pos_sq[of \ "[x,x]", unfolded clean_emp, OF \[x, x] \f ws \ ws\ - _ \\<^bold>|[x, x]\<^bold>| \ \<^bold>|ws\<^bold>|\] + have "\<^bold>|ws\<^bold>| \ 1" + using len_one_concat_in[OF \ws \ lists {x, y}\] \\ primitive (concat ws)\ \primitive x\ \primitive y\ + by blast + with prim_nemp[OF \primitive ws\, THEN nemp_le_len] + have "2 \ \<^bold>|ws\<^bold>|" by auto + hence "\<^bold>|[x, x]\<^bold>| \ \<^bold>|ws\<^bold>|" + by force + have "\ x \ y" + by (rule bin_imprim_not_conjug) fact+ + have "primitive [x,x,y]" + using \x \ y\ by primitivity_inspection + have "concat [x,x] = x \ x" + by simp + interpret xy: binary_code x y + using \x \ y \ y \ x\ by (unfold_locales) - have "ws' \ lists {x,y}" - by (meson \ws \ ws'\ assms(5) conjug_in_lists') - have "primitive ws'" - by (meson \ws \ ws'\ assms(6) prim_conjug) - have "\ primitive (concat ws')" - using \ws \ ws'\ assms(7) conjug_concat_prim_iff by blast + \ \Rotate @{term ws} in order to obtain a list with a prefix @{term "[x\x]"}\ + obtain ws' where "ws \ ws'" "[x,x] \p ws'" + using rotate_into_pos_sq[of \ "[x,x]" _ thesis, unfolded emp_simps, OF \[x, x] \f ws \ ws\ + le0 \\<^bold>|[x, x]\<^bold>| \ \<^bold>|ws\<^bold>|\] by blast + have "ws' \ lists {x,y}" and "primitive ws'" and "\ primitive (concat ws')" + using conjug_in_lists'[OF \ws \ ws'\ \ws \ lists {x, y}\] + prim_conjug[OF \primitive ws\ \ws \ ws'\] + \\ primitive (concat ws)\[unfolded conjug_concat_prim_iff[OF \ws \ ws'\]]. + have "2 \ \<^bold>|ws'\<^bold>|" and "[x,x] \ \" and "ws' \ \" + using \[x,x] \p ws'\ unfolding prefix_def by auto + have "concat ws' \ \" + using \primitive x\ \[x,x] \p ws'\ by (fastforce simp add: prefix_def) + have "ws' \ ws' \ ws' \ lists {x, y}" and "ws' \ ws' \ lists {x, y}" + using \ws' \ lists {x,y}\ by inlists + + \ \The core of the proof\ have "ws' = [x,x,y]" proof(rule ccontr) assume "ws' \ [x,x,y]" - have "2 \ \<^bold>|ws'\<^bold>|" and "[x,x] \ \" - using \[x,x] \p ws'\ unfolding prefix_def by auto - have "x \ y" - using prim_exp_eq[OF \primitive ws'\ sing_lists_exp_len] \ws' \ lists {x,y}\ \[x,x] \p ws'\ by force - hence "x \ y \ y \ x" - using comm_prim[OF \primitive x\ \primitive y\] by blast - from bin_imprim_not_conjug[OF \ws' \ lists {x,y}\ this \2 \ \<^bold>|ws'\<^bold>|\ \primitive ws'\ \\ primitive (concat ws')\] - have "\ x \ y". - have "[x,x] \np ws'" - using npI[OF _ \[x,x] \p ws'\] by blast - have "concat ws' \ \" - using \primitive x\ \[x,x] \p ws'\ by (fastforce simp add: prefix_def) - have "ws' \ \" - using \concat ws' \ \\ by auto - have "ws' \ ws' \ ws' \ lists {x, y}" and "ws' \ ws' \ lists {x, y}" - using \ws' \ lists {x,y}\ by inlists - have "concat [x,x] = x \ x" by simp + from xy.imprim_witness_shift[OF \ws' \ lists {x,y}\ \primitive ws'\ \\ primitive (concat ws')\] + obtain z n where con_ws: "concat ws' = z \<^sup>@ n" and "z \ \{x, y}\" and "z \ concat ws' = concat ws' \ z" + and "\<^bold>|z\<^bold>| < \<^bold>|concat ws'\<^bold>|" and "2 \ n". + have "0 < n" + using \2 \ n\ by simp + from xy.shift_interp[OF \ws' \ lists {x,y}\ \ws' \ lists {x,y}\ \z \ \{x, y}\\ \z \ concat ws' = concat ws' \ z\ + less_imp_le[OF \\<^bold>|z\<^bold>| < \<^bold>|concat ws'\<^bold>|\] \[x,x] \p ws'\ \[x,x] \ \\] + obtain p s vs ps where dis: "p [x,x] s \\<^sub>\ vs" and \vs \ lists {x, y}\ and + "s \p concat ([x,x]\\<^sup>>(ws'\ws'))" and "p \s concat ws'" and "ps \ vs \p ws' \ ws'" and "concat ps \ p = z". - have "primitive [x,x,y]" - using \x \ y\ by primitivity_inspection - - interpret xy: binary_code x y - using \x \ y \ y \ x\ by (unfold_locales) - - from xy.imprim_witness_shift[OF \ws' \ lists {x,y}\ \primitive ws'\ \\ primitive (concat ws')\] - obtain z n where con_ws: "concat ws' = z \<^sup>@ Suc (Suc n)" and "z \ \{x, y}\" and "z \ concat ws' = concat ws' \ z" and "\<^bold>|z\<^bold>| < \<^bold>|concat ws'\<^bold>|". + from disj_interp_nemp(1)[OF this(1)] + have "p \ \" by simp - obtain vs p s ps ss where "p (x \ x) s \\<^sub>\ vs" and "ps \ vs \p ws' \ ws'" and - "[x, x] \ ss = ws' \ ws'" and \concat ps \ p = z\ and "s \p concat ss" and "p \s concat ws'" and \vs \ lists {x, y}\ and - disjoint: "(\us' vs'. us' \p [x, x] \ vs' \p vs \ p \ concat us' \ concat vs')" and "p \ \" and "s \ \" - using xy.shift_interpret[OF \ws' \ lists {x,y}\ \ws' \ lists {x,y}\ \z \ \{x, y}\\ \z \ concat ws' = concat ws' \ z\ - \\<^bold>|z\<^bold>| < \<^bold>|concat ws'\<^bold>|\ \[x,x] \p ws'\ \[x,x] \ \\, of thesis] - unfolding \concat [x,x] = x \ x\ by fast - from disjoint[of \ \] have "p \ \" by simp - - have triv: "2 \ Suc(Suc n)" "Suc 0 < Suc (Suc n)" by simp_all + have "p \ concat p1 \ concat p2" if "p1 \p [x, x]" and "p2 \p vs" for p1 p2 + using \p [x,x] s \\<^sub>\ vs\ disj_interpD1 that by blast have "ps \ lists {x,y}" - using \ps \ vs \p ws' \ ws'\ \ws' \ lists {x,y}\ \ws' \ ws' \ lists {x, y}\ append_prefixD pref_in_lists by metis - have "vs \ lists {x,y}" + using \ps \ vs \p ws' \ ws'\ \ws' \ lists {x,y}\ \ws' \ ws' \ lists {x, y}\ append_prefixD pref_in_lists by metis + have "vs \ lists {x,y}" using \ws' \ lists {x,y}\ pref_in_lists[OF \ps \ vs \p ws' \ ws'\] by inlists - have "ss \ lists {x,y}" - using \ws' \ lists {x,y}\ \[x,x] \ ss = ws' \ ws'\ append_in_lists_conv by metis + have "[x,x]\\<^sup>>(ws'\ws') \ lists {x,y}" + using \ws' \ lists {x,y}\ by inlists + have "p x \ x s \\<^sub>\ vs" + using disj_interpD[OF \p [x,x] s \\<^sub>\ vs\] by simp interpret square_interp_ext x y p s vs - by (rule square_interp_ext.intro[OF square_interp.intro, unfolded square_interp_ext_axioms_def, - OF \primitive x\ \primitive y\ \\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|\ \vs \ lists {x,y}\ \\ x \ y\ disjoint], simp_all only: \p x \ x s \\<^sub>\ vs\) - (meson \p \s concat ws'\ \s \p concat ss\ \ss \ lists {x, y}\ \ws' \ lists {x, y}\ concat_in_hull') + proof (rule square_interp_ext.intro[OF square_interp.intro, unfolded square_interp_ext_axioms_def]) + show "(\pe. pe \ \{x, y}\ \ p \s pe) \ (\se. se \ \{x, y}\ \ s \p se)" + using \s \p concat ([x,x]\\<^sup>>(ws'\ws'))\ \p \s concat ws'\ + \[x, x]\\<^sup>>(ws' \ ws') \ lists {x, y}\ \ws' \ lists {x, y}\ concat_in_hull' by meson + qed fact+ \ \Establishing the connection between ws' = [x,x,y] and z = xp.\ define xp where "xp = x \ p" have "concat [x,x,y] = xp \ xp" - by (simp add: xxy_root xp_def) + by (simp add: xxy_root xp_def) hence "ws' \ [x,x,y] \ [x,x,y] \ ws'" using comm_prim[OF \primitive ws'\ \primitive [x,x,y]\] \ws' \ [x,x,y] \by force have "z \ xp \ xp \ z" proof assume "z \ xp = xp \ z" - from power_commuting_commutes[symmetric, OF this[symmetric], of 2, - THEN power_commuting_commutes, of "Suc (Suc n)", unfolded pow_two] - have "z\<^sup>@Suc(Suc n) \ xp \ xp = xp \ xp \ z\<^sup>@Suc(Suc n)" + from comm_add_exp[symmetric, OF this[symmetric], of 2, + THEN comm_add_exp, of n, unfolded pow_two] + have "z\<^sup>@n \ xp \ xp = xp \ xp \ z\<^sup>@n" unfolding rassoc. hence "concat ws' \ concat [x,x,y] = concat [x,x,y] \ concat ws'" unfolding con_ws \concat [x,x,y] = xp \ xp\ rassoc by simp from xy.is_code[OF _ _ this[folded concat_morph]] have "ws' \ [x, x, y] = [x,x,y] \ ws'" using append_in_lists \ws' \ lists {x,y}\ by simp thus False using \ws' \ [x, x, y] \ [x,x,y] \ ws'\ by fastforce - qed + qed - then interpret binary_code z xp + then interpret binary_code z xp by (unfold_locales) have "\ concat (ws' \ [x, x, y]) \ concat ([x, x, y] \ ws')" proof (rule notI) assume "concat (ws' \ [x, x, y]) \ concat ([x, x, y] \ ws')" from comm_comp_eq[OF this[unfolded concat_morph], unfolded \concat [x,x,y] = xp \ xp\ con_ws] - have "z \<^sup>@ Suc (Suc n) \ xp\<^sup>@Suc(Suc 0) = xp\<^sup>@Suc(Suc 0) \ z \<^sup>@ Suc (Suc n)" - unfolding pow_Suc pow_zero clean_emp rassoc. - from comm_drop_exps[OF this] + have "z \<^sup>@ n \ xp\<^sup>@Suc(Suc 0) = xp\<^sup>@Suc(Suc 0) \ z \<^sup>@ n" + unfolding pow_Suc pow_zero emp_simps rassoc. + from comm_drop_exps[OF this] show False - using \z \ xp \ xp \ z\ by blast + using \z \ xp \ xp \ z\ \2 \ n\ by force qed \ \How the xp/z mismatch is reflected by mismatch in lists {x,y}?\ \ \Looking at the first occurrence of z:\ define lcp_ws where "lcp_ws = ws' \ [x,x,y] \\<^sub>p [x,x,y] \ ws'" have "lcp_ws \ lists {x,y}" unfolding lcp_ws_def by inlists have lcp_xp_z: "concat (ws' \ [x,x,y]) \\<^sub>p concat ([x,x,y] \ ws') = bin_lcp z (x \ p)" - unfolding concat_morph con_ws \concat [x,x,y] = xp \ xp\ add_exps[symmetric] - using bin_lcp_pows[of "Suc n" "(x\p)\<^sup>@Suc 0" "Suc 0" "z\<^sup>@(Suc n)"] - unfolding xp_def pow_Suc pow_zero clean_emp rassoc. + unfolding concat_morph con_ws \concat [x,x,y] = xp \ xp\ add_exps[symmetric] + using bin_lcp_pows[OF \0 < n\, of 2] + unfolding pow_two pow_pos[OF \0 < n\] rassoc xp_def by force have "(concat lcp_ws) \ bin_lcp x y = bin_lcp z (x \ p)" proof (rule xy.bin_code_lcp_concat'[OF _ _ \\ concat (ws' \ [x, x, y]) \ concat ([x, x, y] \ ws')\, folded lcp_ws_def, unfolded lcp_xp_z, symmetric]) show "ws' \ [x, x, y] \ lists {x, y}" and "[x, x, y] \ ws' \ lists {x, y}" by inlists qed \ \Looking at the second occurrence of z:\ define ws'' where "ws'' = ps \ [x,y]" define lcp_ws' where "lcp_ws' = ws' \ ws'' \\<^sub>p ws'' \ ws'" have "lcp_ws' \ lists {x,y}" unfolding lcp_ws'_def using \ps \ lists {x, y}\ \ws' \ lists {x, y}\ ws''_def by inlists have "concat ws'' = z \ xp" - unfolding ws''_def xp_def using \concat ps \ p = z\ xxy_root by fastforce + unfolding ws''_def xp_def using \concat ps \ p = z\ xxy_root by fastforce have "ws' \ ws'' \ ws'' \ ws'" - proof + proof assume "ws' \ ws'' = ws'' \ ws'" from arg_cong[OF this, of concat, unfolded concat_morph con_ws \concat ws'' = z \ xp\, unfolded lassoc pow_comm, unfolded rassoc cancel] - show False - using \z \ xp \ xp \ z\ comm_drop_exp' by blast + show False + using \z \ xp \ xp \ z\ comm_drop_exp'[OF _ \0 < n\] by blast qed - have - lcp_xp_z': "concat (ws' \ ws'') \\<^sub>p concat (ws'' \ ws') = z \ bin_lcp z (x \ p)" - unfolding concat_morph con_ws \concat ws'' = z \ xp\ pow_Suc - unfolding lassoc cancel - unfolding rassoc lcp_ext_left cancel - using bin_lcp_pows[of "(Suc n)" \ 0 "z \ z\<^sup>@n", unfolded pow_one rassoc clean_emp] - unfolding lassoc pow_Suc[symmetric] pow_Suc2[symmetric] - using xp_def by auto + have + lcp_xp_z': "concat (ws' \ ws'') \\<^sub>p concat (ws'' \ ws') = z \ bin_lcp z (x \ p)" + unfolding concat_morph con_ws \concat ws'' = z \ xp\ pow_Suc + unfolding lcp_ext_left[symmetric] bin_lcp_def shifts + unfolding rassoc lcp_ext_left cancel + using bin_lcp_pows[OF \0 < n\, of 1 \ "z\<^sup>@(n-1)", unfolded pow_1, folded pow_pos[OF \0 < n\]] + unfolding bin_lcp_def xp_def rassoc emp_simps by linarith - have "z \ bin_lcp z (x \ p) = concat (lcp_ws') \ bin_lcp x y" + have "z \ bin_lcp z (x \ p) = concat (lcp_ws') \ bin_lcp x y" unfolding lcp_xp_z'[symmetric] lcp_ws'_def proof (rule xy.bin_code_lcp_concat') show "ws' \ ws'' \ lists {x, y}" unfolding ws''_def using \ws' \ ws' \ ws' \ lists {x, y}\ \ps \ lists {x,y}\ by inlists thus "ws'' \ ws' \ lists {x, y}" by inlists show "\ concat (ws' \ ws'') \ concat (ws'' \ ws')" - unfolding concat_morph con_ws \concat ws'' = z \ xp\ pow_Suc rassoc comp_cancel - unfolding lassoc pow_Suc[symmetric] pow_Suc2[symmetric] comm_comp_eq_conv - comm_drop_exps_conv[of _ _ _ 0, unfolded pow_one] - using non_comm. + unfolding concat_morph con_ws \concat ws'' = z \ xp\ pow_pos[OF \0 < n\] + unfolding rassoc comp_cancel + unfolding lassoc pow_pos[OF \0 < n\, symmetric] pow_pos'[OF \0 < n\, symmetric] + comm_comp_eq_conv + using comm_drop_exp'[OF _ \0 < n\, of z n xp] non_comm by argo qed have "concat lcp_ws' = z \ concat lcp_ws" unfolding cancel_right[of "concat lcp_ws'" "bin_lcp x y" "z \ concat lcp_ws", symmetric] unfolding rassoc[of z] \concat (lcp_ws) \ bin_lcp x y = bin_lcp z (x \ p)\ \z \ bin_lcp z (x \ p) = concat (lcp_ws') \ bin_lcp x y\.. have "lcp_ws \p ws' \ [x,x,y]" unfolding lcp_ws_def using longest_common_prefix_prefix1. have "lcp_ws \ ws' \ [x,x,y]" unfolding lcp_ws_def lcp_pref_conv - using \ws' \ [x, x, y] \ [x, x, y] \ ws'\ pref_comm_eq by blast + using \ws' \ [x, x, y] \ [x, x, y] \ ws'\ pref_comm_eq by blast have "lcp_ws \p ws' \ [x,x]" - using spref_butlast_pref[OF \lcp_ws \p ws' \ [x,x,y]\ \lcp_ws \ ws' \ [x,x,y]\] - unfolding butlast_append by simp + using spref_butlast_pref[OF \lcp_ws \p ws' \ [x,x,y]\ \lcp_ws \ ws' \ [x,x,y]\] + unfolding butlast_append by simp from prefixE[OF pref_prolong[OF this \[x,x] \p ws'\]] - obtain ws''\<^sub>1 where "ws' \ ws' \ ws' = lcp_ws \ ws''\<^sub>1" using rassoc by metis + obtain ws''\<^sub>1 where "ws' \ ws' \ ws' = lcp_ws \ ws''\<^sub>1" using rassoc by metis have "ws' \ ps \ [x,y] \p ws' \ ps \ [x,y,x]" by simp - from pref_trans[OF pref_trans[OF longest_common_prefix_prefix1 this]] + from pref_trans[OF pref_trans[OF longest_common_prefix_prefix1 this]] have "lcp_ws' \p ws' \ ws' \ ws'" unfolding lcp_ws'_def ws''_def using \ps \ vs \p ws' \ ws'\[unfolded cover_xyx, unfolded pref_cancel_conv] - unfolding pref_cancel_conv[symmetric, of "ps \ [x,y,x]" "ws' \ ws'" ws'] by blast + unfolding pref_cancel_conv[symmetric, of "ps \ [x,y,x]" "ws' \ ws'" ws'] by blast from prefixE[OF this] - obtain ws''\<^sub>2 where "ws' \ ws' \ ws' = lcp_ws' \ ws''\<^sub>2". + obtain ws''\<^sub>2 where "ws' \ ws' \ ws' = lcp_ws' \ ws''\<^sub>2". have "concat lcp_ws'\ concat ws''\<^sub>1 = z \ concat(lcp_ws) \ concat ws''\<^sub>1" unfolding lassoc \concat lcp_ws' = z \ concat lcp_ws\.. also have "... = z \ concat (ws' \ ws' \ ws')" unfolding rassoc \ws' \ ws' \ ws' = lcp_ws \ ws''\<^sub>1\ concat_morph.. also have "... = concat (ws' \ ws' \ ws') \ z" unfolding concat_morph con_ws add_exps[symmetric] - pow_Suc[symmetric] pow_Suc2[symmetric].. + pow_Suc[symmetric] pow_Suc'[symmetric].. also have "... = concat lcp_ws'\ concat ws''\<^sub>2 \ z" unfolding \ws' \ ws' \ ws' = lcp_ws' \ ws''\<^sub>2\ concat_morph rassoc.. finally have "concat ws''\<^sub>1 = concat ws''\<^sub>2 \ z" - unfolding cancel. + unfolding cancel. from xy.stability[of "concat ws''\<^sub>2" "concat lcp_ws" z, folded \concat ws''\<^sub>1 = concat ws''\<^sub>2 \ z\ \concat lcp_ws' = z \ concat lcp_ws\] - have "z \ \{x, y}\" + have "z \ \{x, y}\" using \ws' \ ws' \ ws' = lcp_ws \ ws''\<^sub>1\ \ws' \ ws' \ ws' = lcp_ws' \ ws''\<^sub>2\ \ws' \ ws' \ ws' \ lists {x, y}\ append_in_lists_dest append_in_lists_dest' concat_in_hull' by metis thus False using \z \ \{x,y}\\ by blast qed - thus ?thesis + thus "ws \ [x, x, y]" using \ws \ ws'\ by blast qed subsection \Obtaining primitivity with two squares (refining)\ lemma bin_imprim_both_squares_prim: assumes "x \ y \ y \ x" and "ws \ lists {x, y}" and "primitive ws" and "\ primitive (concat ws)" and "[x, x] \f ws \ ws" and "[y, y] \f ws \ ws" and "primitive x" and "primitive y" shows False proof- have "x \ y" using \x \ y \ y \ x\ by blast from bin_imprim_primitive[OF \x \ y \ y \ x\ \primitive x\ \primitive y\ _ \ws \ lists {x,y}\ \primitive ws\ \\ primitive (concat ws)\ \[x, x] \f ws \ ws\] bin_imprim_primitive[OF \x \ y \ y \ x\[symmetric] \primitive y\ \primitive x\ _ \ws \ lists {x,y}\[unfolded insert_commute[of x]] \primitive ws\ \\ primitive (concat ws)\ \[y, y] \f ws \ ws\] have "ws \ [x, x, y] \ ws \ [y, y, x]" using \x \ y \ y \ x\ by force - hence "\<^bold>|ws\<^bold>| = 3" + hence "\<^bold>|ws\<^bold>| = 3" using conjug_len by force note[simp] = sublist_code(3) from \\<^bold>|ws\<^bold>| = 3\ \ws \ lists {x,y}\ \x \ y\ \[x, x] \f ws \ ws\ \[y, y] \f ws \ ws\ show False by list_inspection simp_all qed lemma bin_imprim_both_squares: assumes "x \ y \ y \ x" and "ws \ lists {x, y}" and "primitive ws" and "\ primitive (concat ws)" and "[x, x] \f ws \ ws" and "[y, y] \f ws \ ws" shows False -proof (rule bin_imprim_both_squares_prim) +proof (rule bin_imprim_both_squares_prim) have "x \ \" and "y \ \" and "x \ y" using \x \ y \ y \ x\ by blast+ let ?R = "\ x. [\ x]\<^sup>@(e\<^sub>\ x)" define ws' where "ws' = concat (map ?R ws)" show "\ x \ \ y \ \ y \ \ x" - using \x \ y \ y \ x\[unfolded comp_primroot_conv'[OF \x \ \\ \y \ \\]]. + using \x \ y \ y \ x\[unfolded comp_primroot_conv'[of x y]]. have [simp]: "a = x \ a = y \ [\ a] \<^sup>@ e\<^sub>\ a \ lists {\ x, \ y}" for a - using insert_iff sing_pow_lists[of _ "{\ x, \ y}"] by metis + using insert_iff sing_pow_lists[of _ "{\ x, \ y}"] by metis show "ws' \ lists {\ x, \ y}" - unfolding ws'_def using \ws \ lists {x,y}\ + unfolding ws'_def using \ws \ lists {x,y}\ by (induction ws, simp_all) \ \The primitivity of ws' is obtained from the fact that the decompositions into roots is a primitive morphism\ - interpret binary_code x y + interpret binary_code x y using \x \ y \ y \ x\ by unfold_locales note[simp] = sublist_code(3) have "\<^bold>|ws\<^bold>| \ 3 \ ws \ lists {x,y} \ x \ y \ [x, x] \f ws \ ws \ [y, y] \f ws \ ws \ False" by list_inspection simp_all from this[OF _ \ ws \ lists {x,y}\ \x \ y\ \[x, x] \f ws \ ws\ \[y, y] \f ws \ ws\] roots_prim_morph[OF \ws \ lists {x,y}\ _ \primitive ws\] show "primitive ws'" unfolding ws'_def by fastforce - + show "\ primitive (concat ws')" unfolding ws'_def concat_root_dec_eq_concat[OF \ws \ lists{x,y}\] by fact - have "concat(map ?R [x,x]) \f ws' \ ws'" and "concat(map ?R [y,y]) \f ws' \ ws'" + have "concat(map ?R [x,x]) \f ws' \ ws'" and "concat(map ?R [y,y]) \f ws' \ ws'" unfolding ws'_def using concat_mono_fac[OF map_mono_sublist[OF \[x,x] \f ws \ ws\]] concat_mono_fac[OF map_mono_sublist[OF \[y,y] \f ws \ ws\]] - unfolding concat_morph map_append. + unfolding concat_morph map_append. have "Suc (Suc (e\<^sub>\ x + e\<^sub>\ x - 2)) = e\<^sub>\ x + e\<^sub>\ x" using Suc_minus2 primroot_exp_nemp[OF \x \ \\] by simp have "concat (map ?R [x,x]) = [\ x] \<^sup>@ (Suc (e\<^sub>\ x -1) + Suc (e\<^sub>\ x - 1))" - unfolding Suc_minus[OF primroot_exp_nemp[OF \x \ \\]] by (simp add: add_exps) + unfolding Suc_minus_pos[OF primroot_exp_nemp[OF \x \ \\]] by (simp add: add_exps) hence "[\ x, \ x] \f concat (map ?R [x,x])" - by auto - thus "[\ x, \ x] \f ws' \ ws'" - using fac_trans[OF _ \concat(map ?R [x,x]) \f ws' \ ws'\] by blast + by auto + thus "[\ x, \ x] \f ws' \ ws'" + using fac_trans[OF _ \concat(map ?R [x,x]) \f ws' \ ws'\] by blast have "Suc (Suc (e\<^sub>\ y + e\<^sub>\ y - 2)) = e\<^sub>\ y + e\<^sub>\ y" using Suc_minus2 primroot_exp_nemp[OF \y \ \\] by simp have "concat (map ?R [y,y]) = [\ y] \<^sup>@ (Suc (e\<^sub>\ y -1) + Suc (e\<^sub>\ y - 1))" - unfolding Suc_minus[OF primroot_exp_nemp[OF \y \ \\]] by (simp add: add_exps) + unfolding Suc_minus_pos[OF primroot_exp_nemp[OF \y \ \\]] by (simp add: add_exps) hence "[\ y, \ y] \f concat (map ?R [y,y])" - by auto - thus "[\ y, \ y] \f ws' \ ws'" - using fac_trans[OF _ \concat(map ?R [y,y]) \f ws' \ ws'\] by blast + by auto + thus "[\ y, \ y] \f ws' \ ws'" + using fac_trans[OF _ \concat(map ?R [y,y]) \f ws' \ ws'\] by blast show "primitive (\ x)" and "primitive (\ y)" using primroot_prim \x \ \\ \y \ \\ by blast+ qed subsection \Obtaining the square of the longer word (gluing)\ lemma bin_imprim_longer_twice: \ \ 1. If there are both squares, then contradiction; 2. If a square is missing: a) if y appears once: the positive conclusion b) if y appears twice, then gluing preserves presence of the longer word at least twice (because both appear twice) and induction yields [x',x',y'] where y' is a suffix of x', a contradiction with primitivity of words of the form xyxyy; \ assumes "x \ y \ y \ x" and "ws \ lists {x, y}" and "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" and "count_list ws x \ 2" and "primitive ws" and "\ primitive (concat ws)" shows "ws \ [x,x,y] \ primitive x \ primitive y" using assms proof (induction "\<^bold>|ws\<^bold>|" arbitrary: x y ws rule: less_induct) case less then show ?case proof (cases) assume "[x, x] \f ws \ ws \ [y, y] \f ws \ ws" - with bin_imprim_both_squares[OF \x \ y \ y \ x\ \ws \ lists {x,y}\ \primitive ws\ \ \ primitive (concat ws)\] + with bin_imprim_both_squares[OF \x \ y \ y \ x\ \ws \ lists {x,y}\ \primitive ws\ \ \ primitive (concat ws)\] have False by blast - thus ?case by blast + thus ?case by blast next assume missing_sq: "\ ([x, x] \f ws \ ws \ [y, y] \f ws \ ws)" then show ?case proof (cases) assume "count_list ws y < 2" - with bin_imprim_single_y[OF less.prems(1-4) this less.prems(5-6)] + with bin_imprim_single_y[OF less.prems(1-4) this less.prems(5-6)] show "ws \ [x,x,y] \ primitive x \ primitive y" by blast next - assume "\ count_list ws y < 2" hence "2 \ count_list ws y" by simp + assume "\ count_list ws y < 2" hence "2 \ count_list ws y" by simp \ \Missing square and two y's allow gluing\ define x' where "x' = (if \ [x, x] \f ws \ ws then x else y)" define y' where "y' = (if \ [x, x] \f ws \ ws then y else x)" have "{x', y'} = {x, y}" - by (simp add: doubleton_eq_iff x'_def y'_def) + by (simp add: doubleton_eq_iff x'_def y'_def) note cases = disjE[OF this[unfolded doubleton_eq_iff]] have "\ [x', x'] \f ws \ ws" using missing_sq x'_def by presburger - have "count_list ws x' \ 2" and "count_list ws y' \ 2" - unfolding x'_def y'_def using \2 \ count_list ws x\ \2 \ count_list ws y\ by presburger+ + have "count_list ws x' \ 2" and "count_list ws y' \ 2" + unfolding x'_def y'_def using \2 \ count_list ws x\ \2 \ count_list ws y\ by presburger+ have "x' \ y' \ y' \ x'" - by (rule cases, simp_all add: \x \ y \ y \ x\ \x \ y \ y \ x\[symmetric]) + by (rule cases, simp_all add: \x \ y \ y \ x\ \x \ y \ y \ x\[symmetric]) have "x' \ \" and "x' \ y'" and "x' \ y' \ y'" - using \x' \ y' \ y' \ x'\ by auto + using \x' \ y' \ y' \ x'\ by auto \ \rotating last if necessary for successful gluing\ note prim_nemp[OF \primitive ws\] hence rot: "last ws = x' \ hd ws = x' \ butlast ws \ [x',x'] \ tl ws = ws \ ws" - using append_butlast_last_id hd_tl hd_word mult_assoc by metis + using append_butlast_last_id hd_tl hd_word rassoc by metis from this[THEN facI'] have "last ws = x' \ hd ws \ x'" - using \\ [x', x'] \f ws \ ws\ by blast - define ws' where "ws' = (if last ws \ x' then ws else tl ws \ [hd ws])" + using \\ [x', x'] \f ws \ ws\ by blast + define ws' where "ws' = (if last ws \ x' then ws else tl ws \ [hd ws])" have cond: "ws' = \ \ last ws' \ x'" \ \gluing condition\ - unfolding ws'_def using \last ws = x' \ hd ws \ x'\ by simp - have "ws' \ ws" - unfolding ws'_def using \ws \ \\ by fastforce - hence counts': "count_list ws' x' \ 2" "count_list ws' y' \ 2" + unfolding ws'_def using \last ws = x' \ hd ws \ x'\ by simp + have "ws' \ ws" + unfolding ws'_def using \ws \ \\ by fastforce + hence counts': "count_list ws' x' \ 2" "count_list ws' y' \ 2" by (simp_all add: \2 \ count_list ws x'\ \2 \ count_list ws y'\ count_list_conjug) \ \verify induction assumptions of the glued word\ let ?ws = "glue x' ws'" have c1: "\<^bold>|?ws\<^bold>| < \<^bold>|ws\<^bold>|" - using len_glue[OF cond] conjug_len[OF \ws' \ ws\] \count_list ws' x' \ 2\ by linarith + using len_glue[OF cond] conjug_len[OF \ws' \ ws\] \count_list ws' x' \ 2\ by linarith hence c2: "(x' \ y') \ y' \ y' \ x' \ y'" using \x' \ y' \ y' \ x'\ by force have "ws' \f ws \ ws" - using conjugE[OF \ws' \ ws\] rassoc sublist_appendI by metis - hence "\ [x', x'] \f ws'" + using conjugE[OF \ws' \ ws\] rassoc sublist_appendI by metis + hence "\ [x', x'] \f ws'" using \\ [x',x'] \f ws \ ws\ by blast - have "ws' \ lists {x',y'}" + have "ws' \ lists {x',y'}" using conjug_in_lists[OF \ws' \ ws\ \ws \ lists {x,y}\[folded \{x',y'} = {x,y}\]]. - have c3: "?ws \ lists {x' \ y', y'}" + have c3: "?ws \ lists {x' \ y', y'}" using single_bin_glue_in_lists[OF cond \\ [x', x'] \f ws'\ \ws' \ lists {x',y'}\]. have c4: "2 \ count_list (glue x' ws') (x' \ y')" - using \2 \ count_list ws' x'\ + using \2 \ count_list ws' x'\ unfolding count_list_single_bin_glue(1)[OF \x' \ \\ \x' \ y'\ cond \ws' \ lists {x',y'}\ \\ [x',x'] \f ws'\]. from \primitive ws\[folded conjug_prim_iff[OF \ws' \ ws\]] have c5: "primitive (glue x' ws')" - using prim_bin_glue [OF \ws' \ lists {x',y'}\ \x' \ \\ cond] by blast + using prim_bin_glue [OF \ws' \ lists {x',y'}\ \x' \ \\ cond] by blast - have "count_list ws' x' \ 2" + have "count_list ws' x' \ 2" using \count_list ws x \ 2\ \count_list ws y \ 2\ \{x', y'} = {x, y}\ - count_list_conjug[OF \ws' \ ws\] x'_def by metis + count_list_conjug[OF \ws' \ ws\] x'_def by metis have "concat (glue x' ws') = concat ws'" - by (simp add: cond) + by (simp add: cond) have c6: "\ primitive (concat (glue x' ws'))" unfolding \concat (glue x' ws') = concat ws'\ using \\ primitive (concat ws)\ \ws' \ ws\ conjug_concat_conjug prim_conjug by metis \ \The claim holds by induction\ - from less.hyps[OF c1 c2 c3 _ c4 c5 c6] + from less.hyps[OF c1 c2 c3 _ c4 c5 c6] have "glue x' ws' \ [x' \ y', x' \ y', y']" by simp \ \Which is impossible after gluing\ from prim_xyxyy[OF \x' \ y' \ y' \ x'\] conjug_prim_iff[OF conjug_concat_conjug[OF this]] have False using \\ primitive (concat (glue x' ws'))\ by simp thus ?case by blast qed qed qed lemma bin_imprim_both_twice: assumes "x \ y \ y \ x" and "ws \ lists {x, y}" and "count_list ws x \ 2" and "count_list ws y \ 2" and "primitive ws" and "\ primitive (concat ws)" shows False proof- have "x \ y" using \x \ y \ y \ x\ by blast from bin_imprim_longer_twice[OF assms(1-2) _ assms(3) assms(5-6)] bin_imprim_longer_twice[OF assms(1)[symmetric] assms(2)[unfolded insert_commute[of x]] _ assms(4) assms(5-6)] - have or: "ws \ [x, x, y] \ ws \ [y, y, x]" by linarith + have or: "ws \ [x, x, y] \ ws \ [y, y, x]" by linarith thus False proof (rule disjE) assume "ws \ [x, x, y]" from \count_list ws y \ 2\[unfolded count_list_conjug[OF this]] - show False - using \x \ y\ by force + show False + using \x \ y\ by force next assume "ws \ [y, y, x]" from \count_list ws x \ 2\[unfolded count_list_conjug[OF this]] - show False - using \x \ y\ by force + show False + using \x \ y\ by force qed qed section \Examples\ lemma "x \ \ \ \ (x\x) \ \\<^sub>\ [x,x]" unfolding factor_interpretation_def by simp -lemma assumes "x = [(0::nat),1,0,1,0]" and "y = [1,0,0,1]" +lemma assumes "x = [(0::nat),1,0,1,0]" and "y = [1,0,0,1]" shows "[0,1] (x\x) [1,0] \\<^sub>\ [x,y,x]" - unfolding factor_interpretation_def assms by (simp add: suf_def) + unfolding factor_interpretation_def assms by (simp add: suffix_def) section "Primitivity non-preserving binary code" text\In this section, we give the final form of imprimitive words over a given binary code @{term "{x,y}"}. We start with a lemma, then we show that the only possibility is that such word is conjugate with @{term "x\<^sup>@j \ y\<^sup>@k"}.\ lemma bin_imprim_expsE_y: assumes "x \ y \ y \ x" and - "ws \ lists {x,y}" and + "ws \ lists {x,y}" and "2 \ \<^bold>|ws\<^bold>|" and "primitive ws" and "\ primitive (concat ws)" and "count_list ws y = 1" obtains j k where "1 \ j" "1 \ k" "j = 1 \ k = 1" "ws \ [x]\<^sup>@j \ [y]\<^sup>@k" proof- have "x \ y" using \x \ y \ y \ x\ by blast obtain j1 j2 where "[x]\<^sup>@j1\[y]\[x]\<^sup>@j2 = ws" using bin_count_one_decompose[OF \ws \ lists {x,y}\ \x \ y\ \count_list ws y = 1\]. have "1 \ j2 + j1" using \[x] \<^sup>@ j1 \ [y] \ [x] \<^sup>@ j2 = ws\ \2 \ \<^bold>|ws\<^bold>|\ not_less_eq_eq by fastforce have "ws \ [x]\<^sup>@(j2+j1)\[y]\<^sup>@1" using conjugI'[of "[x] \<^sup>@ j1 \ [y]" "[x] \<^sup>@ j2"] - unfolding \[x] \<^sup>@ j1 \ [y] \ [x] \<^sup>@ j2 = ws\[symmetric] power_add rassoc pow_one'. + unfolding \[x] \<^sup>@ j1 \ [y] \ [x] \<^sup>@ j2 = ws\[symmetric] add_exps rassoc pow_1. from that[OF \1 \ j2 + j1\ _ _ this] - show ?thesis + show ?thesis by blast qed lemma bin_imprim_expsE: assumes "x \ y \ y \ x" and - "ws \ lists {x,y}" and + "ws \ lists {x,y}" and "2 \ \<^bold>|ws\<^bold>|" and "primitive ws" and "\ primitive (concat ws)" obtains j k where "1 \ j" "1 \ k" "j = 1 \ k = 1" "ws \ [x]\<^sup>@j \ [y]\<^sup>@k" proof- note \ws \ lists {x,y}\[unfolded insert_commute[of x]] from bin_lists_count_zero[OF \ws \ lists {x,y}\] sing_lists_exp_len[of ws y] prim_exp_one[OF \primitive ws\, of "[y]" "\<^bold>|ws\<^bold>|"] have "count_list ws x \ 0" using \2 \ \<^bold>|ws\<^bold>|\ by fastforce from bin_lists_count_zero[OF \ws \ lists {y,x}\] sing_lists_exp_len[of ws x] prim_exp_one[OF \primitive ws\, of "[x]" "\<^bold>|ws\<^bold>|"] have "count_list ws y \ 0" using \2 \ \<^bold>|ws\<^bold>|\ by fastforce - consider "count_list ws x = 1" | "count_list ws y = 1" + consider "count_list ws x = 1" | "count_list ws y = 1" using bin_imprim_both_twice[OF \x \ y \ y \ x\ \ws \ lists {x,y}\ _ _ \primitive ws\ \\ primitive (concat ws)\] \count_list ws x \ 0\ \count_list ws y \ 0\ unfolding One_less_Two_le_iff[symmetric] less_one[symmetric] by fastforce thus thesis proof(cases) assume \count_list ws x = 1\ from bin_imprim_expsE_y[reversed, OF \x \ y \ y \ x\ \ws \ lists {y, x}\ \2 \ \<^bold>|ws\<^bold>|\ \primitive ws\ \\ primitive (concat ws)\ \count_list ws x = 1\] - show thesis + show thesis using that by metis next assume \count_list ws y = 1\ from bin_imprim_expsE_y[OF \x \ y \ y \ x\ \ws \ lists {x, y}\ \2 \ \<^bold>|ws\<^bold>|\ \primitive ws\ \\ primitive (concat ws)\ \count_list ws y = 1\] show ?thesis using that. qed qed subsection \The target theorem\ text\Given a binary code @{term "{x,y}"} such that there is a primitive factorisation @{term ws} over it whose concatenation is imprimitive, we finally show that there are integers @{term j} and @{term k} (depending only on @{term "{x,y}"}) such that any other such factorisation @{term ws'} is conjugate to @{term "[x]\<^sup>@j \ [y]\<^sup>@k"}.\ -theorem bin_imprim_code: assumes "x \ y \ y \ x" and "ws \ lists {x,y}" and +theorem bin_imprim_code: assumes "x \ y \ y \ x" and "ws \ lists {x,y}" and "2 \ \<^bold>|ws\<^bold>|" and "primitive ws" and "\ primitive (concat ws)" obtains j k where "1 \ j" and "1 \ k" and "j = 1 \ k = 1" - "\ws. ws \ lists {x,y} \ 2 \ \<^bold>|ws\<^bold>| \ + "\ws. ws \ lists {x,y} \ 2 \ \<^bold>|ws\<^bold>| \ (primitive ws \ \ primitive (concat ws) \ ws \ [x]\<^sup>@j \ [y]\<^sup>@k)" and "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>| \ 2 \ j \ j = 2 \ primitive x \ primitive y" and "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>| \ 2 \ k \ j = 1 \ primitive x" proof- obtain j k where "1 \ j" "1 \ k" "j = 1 \ k = 1" "ws \ [x]\<^sup>@j \ [y]\<^sup>@k" using bin_imprim_expsE[OF \x \ y \ y \ x\] using assms by metis have "\ primitive (x\<^sup>@j \ y\<^sup>@k)" - using \\ primitive (concat ws)\ + using \\ primitive (concat ws)\ unfolding concat_morph concat_sing_pow conjug_prim_iff[OF conjug_concat_conjug[OF \ws \ [x] \<^sup>@ j \ [y] \<^sup>@ k\]]. - from not_prim_pow[OF this] - obtain z l where [symmetric]: "z\<^sup>@l = x\<^sup>@j \ y\<^sup>@k" and "2 \ l". + from not_prim_primroot_expE[OF this] + obtain z l where [symmetric]: "z\<^sup>@l = x\<^sup>@j \ y\<^sup>@k" and "2 \ l". show thesis proof (rule that[of j k ]) show "1 \ j" "1 \ k" "j = 1 \ k = 1" by fact+ - + fix ws' assume hyps: "ws' \ lists {x,y}" "2 \ \<^bold>|ws'\<^bold>|" show "primitive ws' \ \ primitive (concat ws') \ ws' \ [x]\<^sup>@j \ [y]\<^sup>@k" proof assume " primitive ws' \ \ primitive (concat ws')" - hence prems: "primitive ws'" "\ primitive (concat ws')" by blast+ + hence prems: "primitive ws'" "\ primitive (concat ws')" by blast+ obtain j' k' where "1 \ j'" "1 \ k'" "j' = 1 \ k' = 1" "ws' \ [x]\<^sup>@j' \ [y]\<^sup>@k'" - using bin_imprim_expsE[OF \x \ y \ y \ x\ hyps prems]. + using bin_imprim_expsE[OF \x \ y \ y \ x\ hyps prems]. have "\ primitive (x \<^sup>@ j'\ y \<^sup>@ k')" using \\ primitive (concat ws')\ unfolding concat_morph concat_sing_pow conjug_prim_iff[OF conjug_concat_conjug[OF \ws' \ [x] \<^sup>@ j' \ [y] \<^sup>@ k'\]]. have "j = j'" "k = k'" - using LS_unique[OF \x \ y \ y \ x\ + using LS_unique[OF \x \ y \ y \ x\ \1 \ j\ \1 \ k\ \\ primitive (x \<^sup>@ j \ y \<^sup>@ k)\ \1 \ j'\ \1 \ k'\ \\ primitive (x \<^sup>@ j'\ y \<^sup>@ k')\]. show "ws' \ [x] \<^sup>@ j \ [y] \<^sup>@ k" unfolding \j = j'\ \k = k'\ by fact next assume "ws' \ [x]\<^sup>@j \ [y]\<^sup>@k" note conjug_trans[OF \ws \ [x]\<^sup>@j \ [y]\<^sup>@k\ conjug_sym[OF this]] - from prim_conjug[OF \primitive ws\ this] + from prim_conjug[OF \primitive ws\ this] \\ primitive (concat ws)\[unfolded conjug_concat_prim_iff[OF \ws \ ws'\]] show "primitive ws' \ \ primitive (concat ws')" by blast qed - next + next assume "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" interpret LS_len_le x y j k l z by unfold_locales fact+ assume "2 \ j" - with jk_small + with jk_small have "k = 1" by fastforce - from case_j2k1[OF \2 \ j\ this] + from case_j2k1[OF \2 \ j\ this] show "j = 2 \ primitive x \ primitive y" by blast next assume "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" interpret LS_len_le x y j k l z by unfold_locales fact+ assume "2 \ k" show "j = 1 \ primitive x" - using \2 \ k\ \j = 1 \ k = 1\ case_j1k2_primitive by auto + using \2 \ k\ \j = 1 \ k = 1\ case_j1k2_primitive by auto qed qed -end \ No newline at end of file +\ \Formulation in terms of (binary) primitive morphism\ + +definition bin_imprim_code where "bin_imprim_code x y \ x \ y \ y \ x \ (\ bin_prim x y)" + +theorem bin_imprim_code': assumes "bin_imprim_code x y" +obtains j k where "1 \ j" and "1 \ k" and "j = 1 \ k = 1" + "\ws. ws \ lists {x,y} \ 2 \ \<^bold>|ws\<^bold>| \ + (primitive ws \ \ primitive (concat ws) \ ws \ [x]\<^sup>@j \ [y]\<^sup>@k)" and + "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>| \ 2 \ j \ j = 2 \ primitive x \ primitive y" and + "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>| \ 2 \ k \ j = 1 \ primitive x" +proof- + thm bin_imprim_code + obtain ws where "x \ y \ y \ x" + and "ws \ lists {x,y}" and "2 \ \<^bold>|ws\<^bold>|" and "primitive ws" and "\ primitive (concat ws)" + using assms unfolding bin_imprim_code_def bin_prim_altdef2 by blast + from bin_imprim_code[OF this] that + show thesis + by blast +qed + + +end diff --git a/thys/Binary_Code_Imprimitive/Binary_Imprimitive_Decision.thy b/thys/Binary_Code_Imprimitive/Binary_Imprimitive_Decision.thy new file mode 100644 --- /dev/null +++ b/thys/Binary_Code_Imprimitive/Binary_Imprimitive_Decision.thy @@ -0,0 +1,392 @@ +(* Title: Binary_Imprimitive_Decision + File: Binary_Code_Imprimitive.Binary_Imprimitive_Decision + Author: Martin Raška, Charles University + +Part of Combinatorics on Words Formalized. See https://gitlab.com/formalcow/combinatorics-on-words-formalized/ +*) + +theory Binary_Imprimitive_Decision + imports + "Binary_Code_Imprimitive.Binary_Code_Imprimitive" + +begin + +section \Upper bound of the power exponent in the canonical imprimitivity witness\ + +lemma LS_power_len_ge: + assumes "y \<^sup>@ k \ x = z \<^sup>@ l" + and "k * \<^bold>|y\<^bold>| \ \<^bold>|z\<^bold>| + \<^bold>|y\<^bold>| - 1" + shows "x \ y = y \ x" +proof (rule nemp_comm) + assume "y \ \" + have "y \<^sup>@ k \p z \ y \<^sup>@ k" + using \y \<^sup>@ k \ x = z \<^sup>@ l\ + by (blast intro!: pref_prod_root) + moreover have "y \<^sup>@ k \p y \ y \<^sup>@ k" + by (blast intro!: pref_pow_ext') + moreover have "1 \ gcd \<^bold>|z\<^bold>| \<^bold>|y\<^bold>|" + using \y \ \\ + by (simp flip: less_eq_Suc_le) + from this \k * \<^bold>|y\<^bold>| \ \<^bold>|z\<^bold>| + \<^bold>|y\<^bold>| - 1\ + have "\<^bold>|z\<^bold>| + \<^bold>|y\<^bold>| - (gcd \<^bold>|z\<^bold>| \<^bold>|y\<^bold>|) \ k * \<^bold>|y\<^bold>|" + by (rule le_trans[OF diff_le_mono2]) + ultimately have "z \ y = y \ z" + unfolding pow_len[symmetric] by (fact per_lemma_comm) + with \y \<^sup>@ k \ x = z \<^sup>@ l\ + show "x \ y = y \ x" + by (fact LS_comm) +qed + +lemma LS_root_len_ge: + assumes "y \<^sup>@ k \ x = z \<^sup>@ l" + and "1 \ k" and "2 \ l" + and "x \ y \ y \ x" + shows "(k - 1) * \<^bold>|y\<^bold>| + 2 \ \<^bold>|z\<^bold>|" +proof (intro leI notI) + assume "\<^bold>|z\<^bold>| < (k - 1) * \<^bold>|y\<^bold>| + 2" + then have "\<^bold>|z\<^bold>| + \<^bold>|y\<^bold>| \ Suc (k - 1) * \<^bold>|y\<^bold>| + 1" + by simp + also have "\ = k * \<^bold>|y\<^bold>| + 1" + using \1 \ k\ by simp + finally have "k * \<^bold>|y\<^bold>| \ \<^bold>|z\<^bold>| + \<^bold>|y\<^bold>| - 1" + unfolding le_diff_conv. + from \x \ y \ y \ x\ LS_power_len_ge[OF \y \<^sup>@ k \ x = z \<^sup>@ l\ this] + show False.. +qed + +lemma LS_root_len_le: + assumes "y \<^sup>@ k \ x = z \<^sup>@ l" + and "1 \ k" and "2 \ l" + and "x \ y \ y \ x" + shows "\<^bold>|z\<^bold>| \ \<^bold>|x\<^bold>| + \<^bold>|y\<^bold>| - 2" +proof - + have "\<^bold>|x\<^bold>| + k * \<^bold>|y\<^bold>| = l * \<^bold>|z\<^bold>|" + using lenarg[OF \y \<^sup>@ k \ x = z \<^sup>@ l\] + by (simp only: pow_len lenmorph add.commute[of "\<^bold>|x\<^bold>|"]) + have "\<^bold>|z\<^bold>| \ (l - 1) * \<^bold>|z\<^bold>|" + using diff_le_mono[OF \2 \ l\, of 1] by simp + also have "\ = \<^bold>|x\<^bold>| + k * \<^bold>|y\<^bold>| - \<^bold>|z\<^bold>|" + unfolding diff_mult_distrib \\<^bold>|x\<^bold>| + k * \<^bold>|y\<^bold>| = l * \<^bold>|z\<^bold>|\[symmetric] by simp + also have "\ \ \<^bold>|x\<^bold>| + k * \<^bold>|y\<^bold>| - ((k - 1) * \<^bold>|y\<^bold>| + 2)" + using LS_root_len_ge[OF assms] + by (rule diff_le_mono2) + also have "\ \ \<^bold>|x\<^bold>| + \<^bold>|y\<^bold>| - 2" + using \1 \ k\ unfolding diff_diff_eq[symmetric] + by (intro diff_le_mono) (simp add: le_diff_conv add.assoc diff_mult_distrib) + finally show "\<^bold>|z\<^bold>| \ \<^bold>|x\<^bold>| + \<^bold>|y\<^bold>| - 2". +qed + +lemma LS_exp_le': + assumes "y \<^sup>@ k \ x = z \<^sup>@ l" + and "2 \ l" + and "x \ y \ y \ x" + shows "k \ (\<^bold>|x\<^bold>| - 4) div \<^bold>|y\<^bold>| + 2" +proof (cases "1 \ k") + assume "1 \ k" + have "\<^bold>|y\<^bold>| > 0" + using \x \ y \ y \ x\ by blast + have "(k - 1) * \<^bold>|y\<^bold>| + 2 \ \<^bold>|z\<^bold>|" + using LS_root_len_ge \y \<^sup>@ k \ x = z \<^sup>@ l\ \1 \ k\ \2 \ l\ \x \ y \ y \ x\. + also have "\<^bold>|z\<^bold>| \ \<^bold>|x\<^bold>| + \<^bold>|y\<^bold>| - 2" + using LS_root_len_le \y \<^sup>@ k \ x = z \<^sup>@ l\ \1 \ k\ \2 \ l\ \x \ y \ y \ x\. + finally have "(k - 1) * \<^bold>|y\<^bold>| + 2 \ \<^bold>|x\<^bold>| + \<^bold>|y\<^bold>| - 2". + then have "(k - 1) * \<^bold>|y\<^bold>| + 2 - \<^bold>|y\<^bold>| - 2 \ \<^bold>|x\<^bold>| + \<^bold>|y\<^bold>| - 2 - \<^bold>|y\<^bold>| - 2" + by (intro diff_le_mono) + then have "(k - 1) * \<^bold>|y\<^bold>| + 2 - 2 - \<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>| - (2 + 2)" + unfolding diff_commute[of _ 2 "\<^bold>|y\<^bold>|"] unfolding diff_add_inverse2 diff_diff_eq. + then have "(k - (1 + 1)) * \<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>| - 4" + unfolding diff_add_inverse2 nat_distrib diff_diff_eq mult_1 + by presburger + then show "k \ (\<^bold>|x\<^bold>| - 4) div \<^bold>|y\<^bold>| + 2" + using \\<^bold>|y\<^bold>| > 0\ + by (simp only: less_eq_div_iff_mult_less_eq one_add_one flip: le_diff_conv) +qed (simp add: trans_le_add2) + +lemma LS_exp_le: + assumes "x \ y \<^sup>@ k = z \<^sup>@ l" + and "2 \ l" + and "x \ y \ y \ x" + shows "k \ (\<^bold>|x\<^bold>| - 4) div \<^bold>|y\<^bold>| + 2" + using LS_exp_le'[reversed, OF \x \ y \<^sup>@ k = z \<^sup>@ l\ \2 \ l\ \x \ y \ y \ x\[symmetric]]. + +thm bin_imprim_expsE +lemma bin_imprim_code_witnessE: + assumes "x \ y \ y \ x" and "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" + and "ws \ lists {x,y}" and "2 \ \<^bold>|ws\<^bold>|" + and "primitive ws" and "\ primitive (concat ws)" + obtains "ws \ [x, x, y]" + | k where "1 \ k" and "k \ (\<^bold>|x\<^bold>| - 4) div \<^bold>|y\<^bold>| + 2" + and "ws \ [x] \ [y] \<^sup>@ k" +proof - + obtain j k + where "1 \ j" and "1 \ k" and "j = 1 \ k = 1" + and witness_iff: "\ws. ws \ lists {x,y} \ 2 \ \<^bold>|ws\<^bold>| \ + (primitive ws \ \ primitive (concat ws) \ ws \ [x] \<^sup>@ j \ [y] \<^sup>@ k)" + and + j_ge: "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>| \ 2 \ j \ j = 2 \ primitive x \ primitive y" and + k_ge: "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>| \ 2 \ k \ j = 1 \ primitive x" + by (fact bin_imprim_code[OF assms(1, 3 - 6)]) + have "ws \ [x] \<^sup>@ j \ [y] \<^sup>@ k" + using witness_iff[OF \ws \ lists {x, y}\ \2 \ \<^bold>|ws\<^bold>|\] \primitive ws\ \\ primitive (concat ws)\ + by simp + show thesis + proof (cases) + assume "2 \ j" + from j_ge[OF \\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|\ this] \j = 1 \ k = 1\ + have "j = 2" and "k = 1" + by simp_all + then have "ws \ [x, x, y]" + using \ws \ [x] \<^sup>@ j \ [y] \<^sup>@ k\ by simp + then show thesis.. + next + assume "\ 2 \ j" + with \1 \ j\ have "j = 1" + by simp + then have "ws \ [x] \ [y] \<^sup>@ k" + using \ws \ [x] \<^sup>@ j \ [y] \<^sup>@ k\ by simp + then have "\ primitive (x \ y \<^sup>@ k)" + using \\ primitive (concat ws)\ unfolding conjug_concat_prim_iff[OF \ws \ [x] \ [y] \<^sup>@ k\] + by simp + moreover have "x \ y \<^sup>@ k \ \" + using \x \ y \ y \ x\ by (intro notI) simp + ultimately obtain z l + where "2 \ l" and "z \<^sup>@ l = x \ y \<^sup>@ k" + by (elim not_prim_expE) + have "k \ (\<^bold>|x\<^bold>| - 4) div \<^bold>|y\<^bold>| + 2" + using LS_exp_le[OF \z \<^sup>@ l = x \ y \<^sup>@ k\[symmetric] \2 \ l\ \x \ y \ y \ x\]. + from \1 \ k\ this \ws \ [x] \ [y] \<^sup>@ k\ + show thesis.. + qed +qed + +subsection \Optimality of the exponent upper bound\ + +lemma examples_bound_optimality: + fixes m k and x y z :: "binA list" + assumes "1 \ m" and "k' = 0 \ m = 1" + defines "x \ \ \ \ \ (\ \ (\ \ \) \<^sup>@ m) \<^sup>@ k' \ \ \ \" + and "y \ \ \ (\ \ \) \<^sup>@ m" + and "z \ \ \ \ \ (\ \ (\ \ \) \<^sup>@ m) \<^sup>@ (k' + 1)" + and "k \ k' + 2" + shows "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" and "x \ y \<^sup>@ k = z \ z" and "k = (\<^bold>|x\<^bold>| - 4) div \<^bold>|y\<^bold>| + 2" +proof - + obtain m' where m: "m = m' + 1" + using \1 \ m\ using add.commute le_Suc_ex by blast + have x_len: "\<^bold>|x\<^bold>| = k' * (2 * m + 1) + 4" + unfolding x_def by (simp add: pow_len) + have y_len: "\<^bold>|y\<^bold>| = 2 * m + 1" + unfolding y_def by (simp add: pow_len) + have z_len: "\<^bold>|z\<^bold>| = (k' + 1) * (2 * m + 1) + 2" + unfolding z_def by (simp add: pow_len) + show "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" + using \k' = 0 \ m = 1\ unfolding x_len y_len + by (cases k') (simp_all add: pow_len) + show "x \ y \<^sup>@ k = z \ z" + unfolding x_def y_def z_def k_def + by comparison + show "k = (\<^bold>|x\<^bold>| - 4) div \<^bold>|y\<^bold>| + 2" + proof - + have "\<^bold>|x\<^bold>| - 4 = k' * \<^bold>|y\<^bold>|" + unfolding x_len y_len by simp + have "\<^bold>|y\<^bold>| \ 0" + unfolding y_def by blast + have "k' = (\<^bold>|x\<^bold>| - 4) div \<^bold>|y\<^bold>|" + unfolding \\<^bold>|x\<^bold>| - 4 = k' * \<^bold>|y\<^bold>|\ nonzero_mult_div_cancel_right[OF \\<^bold>|y\<^bold>| \ 0\].. + then show "k = (\<^bold>|x\<^bold>| - 4) div \<^bold>|y\<^bold>| + 2" + unfolding k_def by blast + qed +qed + +section \Characterization of binary primitivity preserving morphisms given by a pair of words\ + +lemma len_le_not_bin_primE: + assumes "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" + and "\ bin_prim x y" + obtains "\ primitive (x \ x \ y)" + | k where "1 \ k" and "k \ (\<^bold>|x\<^bold>| - 4) div \<^bold>|y\<^bold>| + 2" + and "\ primitive (x \ y \<^sup>@ k)" +proof (cases) + assume "x \ y = y \ x" + have "\ primitive (x \ x \ y)" + using \x \ y = y \ x\ \\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|\ + by (cases "x \ \") (intro comm_not_prim, simp_all) + then show thesis.. +next + assume "x \ y \ y \ x" + then have "x \ y" + by blast + obtain ws where + "ws \ lists {x, y}" and "2 \ \<^bold>|ws\<^bold>|" and "primitive ws" and "\ primitive (concat ws)" + using \\ bin_prim x y\ unfolding bin_prim_concat_prim_pres_conv[OF \x \ y\] + by blast + then consider "ws \ [x, x, y]" + | k where "1 \ k" and "k \ (\<^bold>|x\<^bold>| - 4) div \<^bold>|y\<^bold>| + 2" + and "ws \ [x] \ [y] \<^sup>@ k" + by (rule bin_imprim_code_witnessE[OF \x \ y \ y \ x\ \\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|\]) + then show thesis + proof (cases) + assume "ws \ [x, x, y]" + then have "\ primitive (x \ x \ y)" + using \\ primitive (concat ws)\ + by (simp add: conjug_concat_prim_iff) + then show thesis.. + next + fix k + assume "1 \ k" and "k \ (\<^bold>|x\<^bold>| - 4) div \<^bold>|y\<^bold>| + 2" and "ws \ [x] \ [y] \<^sup>@ k" + have "\ primitive (x \ y \<^sup>@ k)" + using \ws \ [x] \ [y] \<^sup>@ k\ \\ primitive (concat ws)\ + by (simp add: conjug_concat_prim_iff) + from \1 \ k\ \k \ (\<^bold>|x\<^bold>| - 4) div \<^bold>|y\<^bold>| + 2\ this + show thesis.. + qed +qed + +lemma bin_prim_xyk: + assumes "bin_prim x y" and "0 < k" + shows "primitive (x \ y \<^sup>@ k)" +proof - + have "primitive ([x] \ [y] \<^sup>@ k)" + using bin_prim_code[OF \bin_prim x y\] + by (intro prim_abk) blast + from bin_prim_concat_prim_pres[OF \bin_prim x y\ _ _ this] \0 < k\ + show "primitive (x \ y \<^sup>@ k)" + by (simp add: pow_in_lists) +qed + +lemma len_le_bin_prim_iff: + assumes "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" + shows + "bin_prim x y \ primitive (x \ x \ y) \ (\k. 1 \ k \ k \ (\<^bold>|x\<^bold>| - 4) div \<^bold>|y\<^bold>| + 2 \ primitive (x \ y \<^sup>@ k))" + (is "bin_prim x y \ (?xxy \ ?xyk)") +proof (intro iffI[OF _ contrapos_pp]) + assume "bin_prim x y" + show "?xxy \ ?xyk" + proof (intro conjI allI impI) + show "primitive (x \ x \ y)" + using bin_prim_xyk[OF \bin_prim x y\[symmetric], of 2] conjug_prim_iff' + by (simp add: conjug_prim_iff'[of y]) + show "primitive (x \ y \<^sup>@ k)" if "1 \ k \ k \ (\<^bold>|x\<^bold>| - 4) div \<^bold>|y\<^bold>| + 2" for k + using bin_prim_xyk[OF \bin_prim x y\, of k] conjunct1[OF that] + by fastforce + qed +next + assume "\ bin_prim x y" + then consider "\ primitive (x \ x \ y)" + | k where "1 \ k" and "k \ (\<^bold>|x\<^bold>| - 4) div \<^bold>|y\<^bold>| + 2" + and "\ primitive (x \ y \<^sup>@ k)" + by (elim len_le_not_bin_primE[OF \\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|\]) + then show "\ (?xxy \ ?xyk)" + by (cases) blast+ +qed + +lemma len_eq_bin_prim_iff: + assumes "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|" + shows "bin_prim x y \ primitive (x \ y)" +proof + show "bin_prim x y \ primitive (x \ y)" + using bin_prim_xyk[of _ _ 1] + by simp + assume "primitive (x \ y)" + then have "x \ y \ y \ x" + using assms eq_append_not_prim by auto + from this bin_uniform_prim_morph[OF this \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\ \primitive (x \ y)\] + show "bin_prim x y" + unfolding bin_prim_altdef2 + by simp +qed + +theorem bin_prim_iff: + "bin_prim x y \ + (if \<^bold>|y\<^bold>| < \<^bold>|x\<^bold>| + then primitive (x \ x \ y) \ (\k. 1 \ k \ k \ (\<^bold>|x\<^bold>| - 4) div \<^bold>|y\<^bold>| + 2 \ primitive (x \ y \<^sup>@ k)) + else if \<^bold>|x\<^bold>| < \<^bold>|y\<^bold>| + then primitive (y \ y \ x) \ (\k. 1 \ k \ k \ (\<^bold>|y\<^bold>| - 4) div \<^bold>|x\<^bold>| + 2 \ primitive (y \ x \<^sup>@ k)) + else primitive (x \ y) + )" +proof (cases rule: linorder_cases) + assume "\<^bold>|x\<^bold>| < \<^bold>|y\<^bold>|" + then show ?thesis + unfolding bin_prim_commutes[of x y] + unfolding len_le_bin_prim_iff[OF less_imp_le[OF \\<^bold>|x\<^bold>| < \<^bold>|y\<^bold>|\]] + by (simp only: if_not_P[OF less_not_sym] if_P) +next + assume "\<^bold>|y\<^bold>| < \<^bold>|x\<^bold>|" + then show ?thesis + unfolding len_le_bin_prim_iff[OF less_imp_le[OF \\<^bold>|y\<^bold>| < \<^bold>|x\<^bold>|\]] + by (simp only: if_P) +next + assume "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|" + then show ?thesis + unfolding len_eq_bin_prim_iff[OF \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\] + by simp +qed + +subsection \Code equation for @{term bin_prim} predicate\ + +context +begin + +private lemma all_less_Suc_conv: "(\k < n. P (Suc k)) \ (\k \ n. k \ 1 \ P k)" +proof (intro iffI allI impI) + fix k + assume "\k n" and "1 \ k" + then show "P k" + by (elim allE[of _ "k - 1"]) (simp only: Suc_diff_1) +qed simp + +lemma bin_prim_iff' [code]: + "bin_prim x y \ + (if \<^bold>|y\<^bold>| < \<^bold>|x\<^bold>| + then primitive (x \ x \ y) \ (\k < (\<^bold>|x\<^bold>| - 4) div \<^bold>|y\<^bold>| + 2. primitive (x \ y \<^sup>@ (Suc k))) + else if \<^bold>|x\<^bold>| < \<^bold>|y\<^bold>| + then bin_prim y x + else primitive (x \ y) + )" +proof (cases rule: linorder_cases) + show "\<^bold>|x\<^bold>| < \<^bold>|y\<^bold>| \ ?thesis" + unfolding bin_prim_commutes[of x y] + by simp +next + assume "\<^bold>|y\<^bold>| < \<^bold>|x\<^bold>|" + then show ?thesis + using len_le_bin_prim_iff[OF less_imp_le[OF \\<^bold>|y\<^bold>| < \<^bold>|x\<^bold>|\]] + unfolding all_less_Suc_conv[where P = "\k. primitive (_ \ _ \<^sup>@ k)"] + unfolding conj_comms[of "1 \ _"] imp_conjL + by (simp only: if_P) +next + assume "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|" + then show ?thesis + unfolding len_eq_bin_prim_iff[OF \\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|\] + by simp +qed + +end +value "bin_prim (\\\\\\\\\) \" \ \True\ +value "bin_prim (\\\\\\\) \" \ \False\ +value "bin_prim (\\\\\\\) (\\\\\\\\\)" \ \False\ +value "bin_prim (\\\) (\\\)" \ \False\ +value "bin_prim (\\\) (\\\\\\\)" \ \False\ +value "bin_prim (\\\\\\\\\) (\\\\\\\\\\\)" \ \True\ + +section \Characterization of binary imprimitivity codes\ + +theorem bin_imprim_code_iff: + "bin_imprim_code x y \ x \ y \ y \ x \ + (if \<^bold>|y\<^bold>| < \<^bold>|x\<^bold>| + then \ primitive (x \ x \ y) \ (\k. 1 \ k \ k \ (\<^bold>|x\<^bold>| - 4) div \<^bold>|y\<^bold>| + 2 \ \ primitive (x \ y \<^sup>@ k)) + else if \<^bold>|x\<^bold>| < \<^bold>|y\<^bold>| + then \ primitive (y \ y \ x) \ (\k. 1 \ k \ k \ (\<^bold>|y\<^bold>| - 4) div \<^bold>|x\<^bold>| + 2 \ \ primitive (y \ x \<^sup>@ k)) + else \ primitive (x \ y) + )" + unfolding bin_imprim_code_def bin_prim_iff + by (simp only: de_Morgan_conj not_all not_imp conj_assoc flip: if_image[of _ Not]) + +value "bin_imprim_code (\\\\\\\\\) \" \ \False\ +value "bin_imprim_code (\\\\\\\) \" \ \True\ +value "bin_imprim_code (\\\\\\\) (\\\\\\\\\)" \ \True\ +value "bin_imprim_code (\\\) (\\\)" \ \False\ +value "bin_imprim_code (\\\) (\\\\\\\)" \ \False\ +value "bin_imprim_code (\\\\\\\\\) (\\\\\\\\\\\)" \ \False\ + + +end diff --git a/thys/Binary_Code_Imprimitive/Binary_Square_Interpretation.thy b/thys/Binary_Code_Imprimitive/Binary_Square_Interpretation.thy --- a/thys/Binary_Code_Imprimitive/Binary_Square_Interpretation.thy +++ b/thys/Binary_Code_Imprimitive/Binary_Square_Interpretation.thy @@ -1,1063 +1,1102 @@ (* Title: Binary Square Interpretation - File: Combinatorics_Words_Interpretations.Binary_Square_Interpretation + File: Binary_Code_Imprimitive.Binary_Square_Interpretation 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 Binary_Square_Interpretation imports - Combinatorics_Words.Equations_Basic + Combinatorics_Words.Submonoids + Combinatorics_Words.Equations_Basic begin section \Lemmas for covered x square\ text \This section explores various variants of the situation when @{term "x \ x"} is covered with - @{term "x\y\<^sup>@k\u \ v\y\<^sup>@l\x"}, with @{term "y = u\v"}, and the displayed dots being synchronized. + @{term "x\y\<^sup>@k\u \ v\y\<^sup>@l\x"}, with @{term "y = u\v"}, and the displayed dots being synchronized. \ subsection \Two particular cases\ \ \Very short and very large overlap\ -lemma pref_suf_pers_short: assumes "x \p v \ x" and "\<^bold>|v \ u\<^bold>| < \<^bold>|x\<^bold>|" and "x \s p \ u \ v \ u" and "p \ \{u,v}\" +lemma pref_suf_pers_short: assumes "x \p v \ x" and "\<^bold>|v \ u\<^bold>| < \<^bold>|x\<^bold>|" and "x \s r \ u \ v \ u" and "r \ \{u,v}\" \ \@{term "x \ x"} is covered by @{term "(p\u\v\u) \ (v\x)"}, the displayed dots being synchronized\ \ \That is, the condition on the first @{term x} in @{term "x\y\<^sup>@k\u \ v\y\<^sup>@l\x"} is relaxed\ shows "u\v = v\u" proof (rule nemp_comm) - have "v \ u \<^bold>|v \ u\<^bold>| < \<^bold>|x\<^bold>|\, of "p \ u", unfolded rassoc, OF \x \s p \ u \ v \ u\]. + have "v \ u \<^bold>|v \ u\<^bold>| < \<^bold>|x\<^bold>|\, of "r \ u", unfolded rassoc, OF \x \s r \ u \ v \ u\]. assume "u \ \" and "v \ \" obtain q where "x = q \ v \ u" and "q \ \" - using \v \ u by (auto simp add: suf_def) - hence "q \s p \ u" - using \x \s p \ u \ v \ u\ by (auto simp add: suf_def) + using \v \ u by (auto simp add: suffix_def) + hence "q \s r \ u" + using \x \s r \ u \ v \ u\ by (auto simp add: suffix_def) + from suf_trans[OF primroot_suf this] + have "\ q \s r \ u". have "q \ v = v \ q" using pref_marker[OF \x \p v\x\, of q ] \x = q \ v \ u\ by simp from suf_marker_per_root[OF \x \p v \ x\, of q u, unfolded rassoc \x = q \ v \ u\] - have "u \p v \ u" - by blast - from root_comm_root[OF this \q\v = v\q\ \v \ \\] - have "u \p q \ u" by simp + have "u

u" + using \v \ \\ by blast + from per_root_primroot[OF this] + comm_primroots'[OF \q \ \\ \v \ \\ \q \ v = v \ q\] + have "u \p \ q \ u" + by force - consider "u \s q" | "q \s u" - using \q \s p \ u\ suffix_same_cases by blast - thus "u\v = v\u" - proof (cases) - assume "u \s q" - from two_elem_root_suf_comm'[OF \u \p v \ u\ _ _ \p \ \{u,v}\\, of "q\<^sup><\u", unfolded rq_suf[OF this] lassoc, OF _ \q \ v = v \ q\] - show ?thesis - using \q \s p \ u\ rq_suf[OF \u \s q\] same_suffix_suffix by metis - next - assume "q \s u" - from root_suf_comm[OF \u \p q \ u\ suffix_appendI[OF this]] - have "q\u = u\q". - from comm_trans[OF \q \ u = u \ q\[symmetric] \q \ v = v \ q\[symmetric] \q \ \\] - show "u\v = v\u". - qed -qed + from gen_prim[OF \r \ \{u, v}\\, unfolded ] + have "r \ \{u, \ q}\" + unfolding \\ q = \ v\. + from two_elem_root_suf_comm[OF \u \p \ q \ u\ \\ q \s r \ u\ this] + show "u \ v = v \ u" + using comm_primroot_conv[of _ v, folded \\ q = \ v\] by blast +qed -lemma pref_suf_pers_large_overlap: +lemma pref_suf_pers_large_overlap: assumes "p \p x" and "s \s x" and "p \p r \ p" and "s \s s \ r" and "\<^bold>|x\<^bold>| + \<^bold>|r\<^bold>| \ \<^bold>|p\<^bold>| + \<^bold>|s\<^bold>|" - shows "x \ r = r \ x" + shows "x \ r = r \ x" using assms -proof (cases "r = \", force) +proof (cases "r = \") assume "r \ \" hence "r \ \" by blast have "\<^bold>|s\<^bold>| \ \<^bold>|x\<^bold>|" - using \s \s x\ unfolding suf_def by force + using \s \s x\ unfolding suffix_def by force have "\<^bold>|p\<^bold>| \ \<^bold>|x\<^bold>|" using \p \p x\ by (force simp add: prefix_def) have "\<^bold>|r\<^bold>| \ \<^bold>|p\<^bold>|" - using \\<^bold>|x\<^bold>| + \<^bold>|r\<^bold>| \ \<^bold>|p\<^bold>| + \<^bold>|s\<^bold>|\ \\<^bold>|s\<^bold>| \ \<^bold>|x\<^bold>|\ unfolding lenmorph by linarith + using \\<^bold>|x\<^bold>| + \<^bold>|r\<^bold>| \ \<^bold>|p\<^bold>| + \<^bold>|s\<^bold>|\ \\<^bold>|s\<^bold>| \ \<^bold>|x\<^bold>|\ unfolding lenmorph by linarith have "\<^bold>|r\<^bold>| \ \<^bold>|s\<^bold>|" - using \\<^bold>|x\<^bold>| + \<^bold>|r\<^bold>| \ \<^bold>|p\<^bold>| + \<^bold>|s\<^bold>|\ \\<^bold>|p\<^bold>| \ \<^bold>|x\<^bold>|\ unfolding lenmorph by linarith - obtain p1 ov s1 where "p1 \ ov \ s1 = x" and "p1 \ ov = p" and "ov \ s1 = s" + using \\<^bold>|x\<^bold>| + \<^bold>|r\<^bold>| \ \<^bold>|p\<^bold>| + \<^bold>|s\<^bold>|\ \\<^bold>|p\<^bold>| \ \<^bold>|x\<^bold>|\ unfolding lenmorph by linarith + obtain p1 ov s1 where "p1 \ ov \ s1 = x" and "p1 \ ov = p" and "ov \ s1 = s" using pref_suf_overlapE[OF \p \p x\ \s \s x\] using \\<^bold>|x\<^bold>| + \<^bold>|r\<^bold>| \ \<^bold>|p\<^bold>| + \<^bold>|s\<^bold>|\ by auto - have "\<^bold>|r\<^bold>| \ \<^bold>|ov\<^bold>|" + have "\<^bold>|r\<^bold>| \ \<^bold>|ov\<^bold>|" using \\<^bold>|x\<^bold>| + \<^bold>|r\<^bold>| \ \<^bold>|p\<^bold>| + \<^bold>|s\<^bold>|\[folded \p1 \ ov \ s1 = x\ \p1 \ ov = p\ \ov \ s1 = s\] unfolding lenmorph by force have "r \p p" - using \\<^bold>|r\<^bold>| \ \<^bold>|p\<^bold>|\[unfolded swap_len] pref_prod_long[OF \p \p r \ p\] by blast + using \\<^bold>|r\<^bold>| \ \<^bold>|p\<^bold>|\[unfolded swap_len] pref_prod_long[OF \p \p r \ p\] by blast hence "r \p x" using \p \p x\ by auto have "r \s s" - using \\<^bold>|r\<^bold>| \ \<^bold>|s\<^bold>|\[unfolded swap_len] pref_prod_long[reversed, OF \s \s s \ r\] by blast + using \\<^bold>|r\<^bold>| \ \<^bold>|s\<^bold>|\[unfolded swap_len] pref_prod_long[reversed, OF \s \s s \ r\] by blast hence "r \s x" using \s \s x\ by auto - obtain k where "p \p r\<^sup>@k" - using per_prefE[OF \p \p r \ p\ \r \ \\]. + obtain k where "p \p r\<^sup>@k" "0 < k" + using per_root_powE[OF per_rootI[OF \p \p r \ p\ \r \ \\]] sprefD1 by metis hence "p1 \ ov \f r\<^sup>@k" unfolding \p1 \ ov = p\ by blast - obtain l where "s \s r\<^sup>@l" - using per_prefE[reversed, OF \s \s s \ r\ \r \ \\]. - hence "ov \ s1 \f r\<^sup>@l" + obtain l where "s \s r\<^sup>@ l" \0 < l\ + using per_root_powE[reversed, OF per_rootI[reversed, OF \s \s s \ r\ \r \ \\]] ssufD1 by metis + hence "ov \ s1 \f r\<^sup>@ l" unfolding \ov \ s1 = s\ by blast - from per_glue_facs[OF \p1 \ ov \f r\<^sup>@k\ \ov \ s1 \f r\<^sup>@l\ \\<^bold>|r\<^bold>| \ \<^bold>|ov\<^bold>|\, unfolded \p1 \ ov \ s1 = x\] + from per_glue_facs[OF \p1 \ ov \f r\<^sup>@ k\ \ov \ s1 \f r\<^sup>@ l\ \\<^bold>|r\<^bold>| \ \<^bold>|ov\<^bold>|\, unfolded \p1 \ ov \ s1 = x\] obtain m where "x \f r \<^sup>@ m". - show "x \ r = r \ x" + show "x \ r = r \ x" using root_suf_comm[OF pref_prod_root[OF marker_fac_pref[OF \x \f r \<^sup>@ m\ \r \p x\]] - suffix_appendI[OF \r \s x\]].. -qed + suffix_appendI[OF \r \s x\]].. +qed simp subsection \Main cases\ -locale pref_suf_pers = +locale pref_suf_pers = fixes x u v k m - assumes - x_pref: "x \p (v \ (u \ v)\<^sup>@(Suc k)) \ x" \ \@{term "x \p p \ x"} and @{term "p \p q \ p"} where @{term "q \p v \ u"}\ - and - x_suf: "x \s x \ (u \ v)\<^sup>@(Suc m) \ u" \ \@{term "x \s s \ x"} and @{term "s \s q' \ s"} where @{term "q' \p u \ v"}\ + assumes + x_pref: "x \p (v \ (u \ v)\<^sup>@k) \ x" \ \@{term "x \p p \ x"} and @{term "p \p q \ p"} where @{term "q = v \ u"}\ + and + x_suf: "x \s x \ (u \ v)\<^sup>@m \ u" \ \@{term "x \s s \ x"} and @{term "s \s q' \ s"} where @{term "q' = u \ v"}\ + and k_pos: "0 < k" and m_pos: "0 < m" begin lemma pref_suf_commute_all_commutes: assumes "\<^bold>|u \ v\<^bold>| \ \<^bold>|x\<^bold>|" and "u \ v = v \ u" shows "commutes {u,v,x}" using assms -proof (cases "u \ v = \", force) - let ?p = "(v \ (u \ v)\<^sup>@(Suc k))" - let ?s = "(u \ v)\<^sup>@(Suc m) \ u" +proof (cases "u \ v = \") + let ?p = "(v \ (u \ v)\<^sup>@k)" + let ?s = "(u \ v)\<^sup>@m \ u" note x_pref x_suf assume "u \ v \ \" have "?p \ \" and "?s \ \" and "v \ u \ \" - using \u \ v \ \\ by force+ + using \u \ v \ \\ m_pos k_pos by auto obtain r where "u \ r*" and "v \ r*" and "primitive r" using \u \ v = v \ u\ comm_primrootE by metis hence "r \ \" by force - have "?p \ r*" and "?s \ r*" and "v \ u \ r*" and "u \ v \ r*" - using \u \ r*\ \v \ r*\ by fast+ + have "?p \ r*" and "?s \ r*" and "v \ u \ r*" and "u \ v \ r*" + using \u \ r*\ \v \ r*\ + by (simp_all add: add_roots root_pow_root) have "x \p r \ x" - using \?p \ r*\ \x \p ?p \ x\ \?p \ \\ by blast + using \?p \ r*\ \x \p ?p \ x\ \?p \ \\ by blast have "v \ u \s x" - using ruler_le[reversed, OF _ _ \\<^bold>|u \ v\<^bold>| \ \<^bold>|x\<^bold>|\[unfolded swap_len[of u]], - of "(x \ (u \ v) \<^sup>@ m \ u) \ v \ u", OF triv_suf, unfolded rassoc, OF \x \s x \ ?s\[unfolded pow_Suc2 rassoc]]. - have "r \s v \ u" - using \v \ u \ \\ \v \ u \ r*\ by blast + using ruler_le[reversed, OF _ _ \\<^bold>|u \ v\<^bold>| \ \<^bold>|x\<^bold>|\[unfolded swap_len[of u]], + of "(x \ (u \ v) \<^sup>@ (m-1) \ u) \ v \ u", OF triv_suf, unfolded rassoc, OF \x \s x \ ?s\[unfolded pow_pos'[OF m_pos] rassoc]]. + have "r \s v \ u" + using \v \ u \ \\ \v \ u \ r*\ per_root_suf by blast have "r \s r \ x" - using suf_trans[OF \r \s v \ u\ \v \ u \s x\, THEN suffix_appendI] by blast + using suf_trans[OF \r \s v \ u\ \v \ u \s x\, THEN suffix_appendI] by blast have "x \ r = r \ x" using root_suf_comm[OF \x \p r \ x\ \r \s r \ x\, symmetric]. hence "x \ r*" - by (simp add: \primitive r\ prim_comm_root) - thus "commutes {u,v,x}" + by (simp add: \primitive r\ prim_comm_root) + thus "commutes {u,v,x}" using \u \ r*\ \v \ r*\ commutesI_root[of "{u,v,x}"] by blast -qed +qed simp lemma no_overlap: assumes - len: "\<^bold>|v \ (u \ v)\<^sup>@(Suc k)\<^bold>| + \<^bold>|(u \ v)\<^sup>@(Suc m) \ u\<^bold>| \ \<^bold>|x\<^bold>|" (is "\<^bold>|?p\<^bold>| + \<^bold>|?s\<^bold>| \ \<^bold>|x\<^bold>|") + len: "\<^bold>|v \ (u \ v)\<^sup>@k\<^bold>| + \<^bold>|(u \ v)\<^sup>@m \ u\<^bold>| \ \<^bold>|x\<^bold>|" (is "\<^bold>|?p\<^bold>| + \<^bold>|?s\<^bold>| \ \<^bold>|x\<^bold>|") and + "0 < k" "0 < m" shows "commutes {u,v,x}" using assms -proof (cases "u \ v = \", force) +proof (cases "u \ v = \") note x_pref x_suf assume "u \ v \ \" have "?p \ \" and "?s \ \" - using \u \ v \ \\ by force+ - from \\<^bold>|?p\<^bold>| + \<^bold>|?s\<^bold>| \ \<^bold>|x\<^bold>|\ - have "\<^bold>|?p\<^bold>| + \<^bold>|?s\<^bold>| - (gcd \<^bold>|?p\<^bold>| \<^bold>|?s\<^bold>|) \ \<^bold>|x\<^bold>|" - by linarith - from per_lemma_pref_suf[OF \x \p ?p \ x\ \x \s x \ ?s\ \?p \ \\ \?s \ \\ this] + using \u \ v \ \\ m_pos k_pos by force+ + from per_lemma_pref_suf[OF per_rootI[OF \x \p ?p \ x\ \?p \ \\] per_rootI[reversed, OF \x \s x \ ?s\ \?s \ \\] \\<^bold>|?p\<^bold>| + \<^bold>|?s\<^bold>| \ \<^bold>|x\<^bold>|\] obtain r s kp ks mw where "?p = (r \ s)\<^sup>@kp" and "?s = (s \ r)\<^sup>@ks" and "x = (r \ s)\<^sup>@mw \ r" and "primitive (r \ s)". hence "\ ?p = r \ s" - using \v \ (u \ v) \<^sup>@ Suc k \ \\ comm_primroots nemp_pow_nemp pow_comm prim_self_root by metis - moreover have "\ ?s = s \ r" - using pow_prim_primroot[OF \?s \ \\ _ \?s = (s \ r)\<^sup>@ks\] prim_conjug[OF \primitive (r \ s)\] by blast - ultimately have "\ ?p \ \ ?s" + using \v \ (u \ v) \<^sup>@k \ \\ comm_primroots nemp_pow_nemp pow_comm prim_self_root by metis + moreover have "\ ?s = s \ r" + using primroot_unique[OF \?s \ \\ _ \?s = (s \ r)\<^sup>@ks\] prim_conjug[OF \primitive (r \ s)\] by blast + ultimately have "\ ?p \ \ ?s" by force - from conj_pers_conj_comm[OF this] + from conj_pers_conj_comm[OF this k_pos m_pos] have "u \ v = v \ u". from pref_suf_commute_all_commutes[OF _ this] - show "commutes {u,v,x}" + show "commutes {u,v,x}" using len by auto -qed +qed simp lemma no_overlap': assumes - len: "\<^bold>|v \ (u \ v)\<^sup>@(Suc k)\<^bold>| + \<^bold>|(u \ v)\<^sup>@(Suc m) \ u\<^bold>| \ \<^bold>|x\<^bold>|" (is "\<^bold>|?p\<^bold>| + \<^bold>|?s\<^bold>| \ \<^bold>|x\<^bold>|") + len: "\<^bold>|v \ (u \ v)\<^sup>@k\<^bold>| + \<^bold>|(u \ v)\<^sup>@m \ u\<^bold>| \ \<^bold>|x\<^bold>|" (is "\<^bold>|?p\<^bold>| + \<^bold>|?s\<^bold>| \ \<^bold>|x\<^bold>|") + and "0 < k" "0 < m" shows "u \ v = v \ u" - by (rule commutesE[of "{u,v,x}"], simp_all add: no_overlap[OF len]) + by (rule commutesE[of "{u,v,x}"], simp_all add: no_overlap[OF assms]) -lemma short_overlap: +lemma short_overlap: assumes - len1: "\<^bold>|x\<^bold>| < \<^bold>|v \ (u \ v)\<^sup>@(Suc k)\<^bold>| + \<^bold>|(u \ v)\<^sup>@(Suc m) \ u\<^bold>|" (is "\<^bold>|x\<^bold>| < \<^bold>|?p\<^bold>| + \<^bold>|?s\<^bold>|") and - len2: "\<^bold>|v \ (u \ v)\<^sup>@(Suc k)\<^bold>| + \<^bold>|(u \ v)\<^sup>@(Suc m) \ u\<^bold>| \ \<^bold>|x\<^bold>| + \<^bold>|u\<^bold>|" (is "\<^bold>|?p\<^bold>| + \<^bold>|?s\<^bold>| \ \<^bold>|x\<^bold>| + \<^bold>|u\<^bold>|") + len1: "\<^bold>|x\<^bold>| < \<^bold>|v \ (u \ v)\<^sup>@k\<^bold>| + \<^bold>|(u \ v)\<^sup>@m \ u\<^bold>|" (is "\<^bold>|x\<^bold>| < \<^bold>|?p\<^bold>| + \<^bold>|?s\<^bold>|") and + len2: "\<^bold>|v \ (u \ v)\<^sup>@k\<^bold>| + \<^bold>|(u \ v)\<^sup>@m \ u\<^bold>| \ \<^bold>|x\<^bold>| + \<^bold>|u\<^bold>|" (is "\<^bold>|?p\<^bold>| + \<^bold>|?s\<^bold>| \ \<^bold>|x\<^bold>| + \<^bold>|u\<^bold>|") shows "commutes {u,v,x}" proof (rule pref_suf_commute_all_commutes) show "\<^bold>|u \ v\<^bold>| \ \<^bold>|x\<^bold>|" - using len2 by force + using len2 unfolding pow_pos[OF k_pos] lenmorph by simp next note x_pref x_suf \ \obtain the overlap\ have "\<^bold>|?p\<^bold>| \ \<^bold>|x\<^bold>|" using len2 unfolding lenmorph by linarith hence "?p \p x" - using \x \p ?p \ x\ pref_prod_long by blast + using \x \p ?p \ x\ pref_prod_long by blast have "\<^bold>|?s\<^bold>| \ \<^bold>|x\<^bold>|" - using len2 unfolding pow_len lenmorph by auto + using len2 unfolding pow_pos[OF k_pos] pow_len lenmorph by auto hence "?s \s x" - using suf_prod_long[OF \x \s x \ ?s\] by blast + using suf_prod_long[OF \x \s x \ ?s\] by blast from pref_suf_overlapE[OF \?p \p x\ \?s \s x\ less_imp_le[OF len1]] obtain p1 ov s1 where "p1 \ ov \ s1 = x" and "p1 \ ov = ?p" and "ov \ s1 = ?s". from len1[folded this] have "ov \ \" - by fastforce + by fastforce have "\<^bold>|ov\<^bold>| \ \<^bold>|u\<^bold>|" using len2[folded \p1 \ ov \ s1 = x\ \p1 \ ov = ?p\ \ov \ s1 = ?s\] unfolding lenmorph by auto - then obtain s' where "ov \ s' = u" and "s' \ v \ (u \ v) \<^sup>@ m \ u = s1" - using eqdE[OF \ov \ s1 = ?s\[unfolded pow_Suc rassoc]] by auto + then obtain s' where "ov \ s' = u" and "s' \ v \ (u \ v) \<^sup>@ (m -1) \ u = s1" + using eqdE[OF \ov \ s1 = ?s\[unfolded pow_pos[OF m_pos] rassoc]] by auto \ \obtain the left complement\ - from eqdE[reversed, of p1 ov "v \ (u \ v)\<^sup>@k" "u \ v", unfolded rassoc, - OF \p1 \ ov = ?p\[unfolded pow_Suc2]] \\<^bold>|ov\<^bold>| \ \<^bold>|u\<^bold>|\ - have "v \ (u \ v) \<^sup>@ k \p p1" by (auto simp add: prefix_def) + from eqdE[reversed, of p1 ov "v \ (u \ v)\<^sup>@(k-1)" "u \ v", unfolded rassoc, + OF \p1 \ ov = ?p\[unfolded pow_pos'[OF k_pos]] ] \\<^bold>|ov\<^bold>| \ \<^bold>|u\<^bold>|\ + have "v \ (u \ v) \<^sup>@ (k -1) \p p1" + unfolding lenmorph by (auto simp add: prefix_def) - then obtain q where "v \ (u \ v)\<^sup>@k \ q = p1" + then obtain q where "v \ (u \ v)\<^sup>@(k-1) \ q = p1" by (force simp add: prefix_def) \ \main proof using the lemma @{thm uvu_suf_uvvu}\ show "u \ v = v \ u" proof (rule sym, rule uvu_suf_uvvu) - show "s' s u" using \ov \ s' = u\ \ov \ \\ by blast show "u \ v \ v \ u \ s' = q \ u \ v \ u" \ \the main fact: the overlap situation\ proof- have "u \ v \ u \p ?s" - unfolding pow_Suc rassoc pref_cancel_conv shift_pow by blast + unfolding pow_pos[OF m_pos] rassoc pref_cancel_conv shift_pow by blast hence "p1 \ u \ v \ u \p x" unfolding \p1 \ ov \ s1 = x\[symmetric] \ov \ s1 = ?s\ pref_cancel_conv. - hence "v \ (u \ v)\<^sup>@k \ q \ u \ v \ ov \p x" - using \v \ (u \ v)\<^sup>@k \ q = p1\ \ov \ s' = u\ by (force simp add: prefix_def) + hence "v \ (u \ v)\<^sup>@(k-1) \ q \ u \ v \ ov \p x" + using \v \ (u \ v)\<^sup>@(k-1) \ q = p1\ \ov \ s' = u\ by (force simp add: prefix_def) have "v \ u \p x" - using \?p \p x\[unfolded pow_Suc] by (auto simp add: prefix_def) + using \?p \p x\[unfolded pow_pos[OF k_pos]] by (auto simp add: prefix_def) have "\<^bold>|?p \ v \ u\<^bold>| \ \<^bold>|x\<^bold>|" - using len2 unfolding lenmorph by force + using len2 unfolding pow_pos[OF m_pos] lenmorph by force hence "?p \ v \ u \p x" using \x \p ?p \ x\ \v \ u \p x\ pref_prod_longer by blast - hence "v \ (u \ v)\<^sup>@k \ u \ v \ v \ u \p x" - unfolding pow_Suc2 rassoc. + hence "v \ (u \ v)\<^sup>@(k-1) \ u \ v \ v \ u \p x" + unfolding pow_pos'[OF k_pos] rassoc. - have "\<^bold>|v \ (u \ v)\<^sup>@k \ u \ v \ v \ u\<^bold>| = \<^bold>|v \ (u \ v)\<^sup>@k \ q \ u \ v \ ov\<^bold>|" - using lenarg[OF \p1 \ ov = ?p\[folded \v \ (u \ v)\<^sup>@k \ q = p1\, unfolded pow_Suc2 rassoc cancel]] + have "\<^bold>|v \ (u \ v)\<^sup>@(k-1) \ u \ v \ v \ u\<^bold>| = \<^bold>|v \ (u \ v)\<^sup>@(k-1) \ q \ u \ v \ ov\<^bold>|" + using lenarg[OF \p1 \ ov = ?p\[folded \v \ (u \ v)\<^sup>@(k-1) \ q = p1\, unfolded pow_pos[OF k_pos] rassoc cancel]] by force - from ruler_eq_len[OF \v \ (u \ v)\<^sup>@k \ u \ v \ v \ u \p x\ \v \ (u \ v)\<^sup>@k \ q \ u \ v \ ov \p x\ this, unfolded cancel] + from ruler_eq_len[OF \v \ (u \ v)\<^sup>@(k-1) \ u \ v \ v \ u \p x\ \v \ (u \ v)\<^sup>@(k-1) \ q \ u \ v \ ov \p x\ this, unfolded cancel] have "u \ v \ v \ u = q \ u \ v \ ov". thus "u \ v \ v \ u \ s' = q \ u \ v \ u" using \ov \ s' = u\ by auto qed show "q \s v \ u" proof (rule ruler_le[reversed]) show "q \s x" proof (rule suf_trans) show "p1 \s x" using \p1 \ ov \ s1 = x\[unfolded \ov \ s1 = ?s\] \x \s x \ ?s\ same_suffix_suffix by blast show "q \s p1" - using \v \ (u \ v) \<^sup>@ k \ q = p1\ by auto - qed + using \v \ (u \ v) \<^sup>@ (k-1) \ q = p1\ by auto + qed show "v \ u \s x" - using \?s \s x\[unfolded pow_Suc2 rassoc] suffix_appendD by metis - show "\<^bold>|q\<^bold>| \ \<^bold>|v \ u\<^bold>|" + using \?s \s x\[unfolded pow_pos'[OF m_pos] rassoc] suf_extD by metis + show "\<^bold>|q\<^bold>| \ \<^bold>|v \ u\<^bold>|" using lenarg[OF \u \ v \ v \ u \ s' = q \ u \ v \ u\] lenarg[OF \ov \ s' = u\] by force qed qed auto qed lemma medium_overlap: - assumes - len1: "\<^bold>|x\<^bold>| + \<^bold>|u\<^bold>| < \<^bold>|v \ (u \ v)\<^sup>@(Suc k)\<^bold>| + \<^bold>|(u \ v)\<^sup>@(Suc m) \ u\<^bold>|" (is "\<^bold>|x\<^bold>| + \<^bold>|u\<^bold>| < \<^bold>|?p\<^bold>| + \<^bold>|?s\<^bold>|") and - len2: "\<^bold>|v \ (u \ v)\<^sup>@(Suc k)\<^bold>| + \<^bold>|(u \ v)\<^sup>@(Suc m) \ u\<^bold>| < \<^bold>|x\<^bold>| + \<^bold>|u \ v\<^bold>|" (is "\<^bold>|?p\<^bold>| + \<^bold>|?s\<^bold>| < \<^bold>|x\<^bold>| + \<^bold>|u \ v\<^bold>|") + assumes + len1: "\<^bold>|x\<^bold>| + \<^bold>|u\<^bold>| < \<^bold>|v \ (u \ v)\<^sup>@k\<^bold>| + \<^bold>|(u \ v)\<^sup>@m \ u\<^bold>|" (is "\<^bold>|x\<^bold>| + \<^bold>|u\<^bold>| < \<^bold>|?p\<^bold>| + \<^bold>|?s\<^bold>|") and + len2: "\<^bold>|v \ (u \ v)\<^sup>@k\<^bold>| + \<^bold>|(u \ v)\<^sup>@m \ u\<^bold>| < \<^bold>|x\<^bold>| + \<^bold>|u \ v\<^bold>|" (is "\<^bold>|?p\<^bold>| + \<^bold>|?s\<^bold>| < \<^bold>|x\<^bold>| + \<^bold>|u \ v\<^bold>|") shows "commutes {u,v,x}" proof (rule pref_suf_commute_all_commutes) show "\<^bold>|u \ v\<^bold>| \ \<^bold>|x\<^bold>|" - using len2 by force + using len2 unfolding pow_pos[OF k_pos] by force next note x_pref x_suf have "\<^bold>|?p\<^bold>| \ \<^bold>|x\<^bold>|" - using len2 by auto + using len2 unfolding pow_pos[OF m_pos] by auto hence "?p \p x" - using \x \p ?p \ x\ pref_prod_long by blast - hence "v \ (u \ v)\<^sup>@k \ u \ v \ v \p ?p \ x" - using \x \p ?p \ x\ unfolding pow_Suc2 rassoc by (auto simp add: prefix_def) + using \x \p ?p \ x\ pref_prod_long by blast + hence "v \ (u \ v)\<^sup>@(k-1) \ u \ v \ v \p ?p \ x" + using \x \p ?p \ x\ unfolding pow_pos'[OF k_pos] rassoc by (auto simp add: prefix_def) have "\<^bold>|?s\<^bold>| \ \<^bold>|x\<^bold>|" - using len2 unfolding pow_len lenmorph by auto + using len2 unfolding pow_pos[OF k_pos] pow_len lenmorph by auto hence "?s \s x" using suf_prod_long[OF \x \s x \ ?s\] by blast then obtain p' where "p' \ u \ v \p x" and "p' \ ?s = x" - by (auto simp add: suf_def) + unfolding pow_pos[OF m_pos] by (auto simp add: suffix_def) have "\<^bold>|p' \ u \ v\<^bold>| \ \<^bold>|?p \ v\<^bold>|" using len1[folded \p' \ ?s = x\] by force - have "\<^bold>|v \ (u \ v)\<^sup>@k\<^bold>| < \<^bold>|p'\<^bold>|" - using len2[folded \p' \ ?s = x\] by force + have "\<^bold>|v \ (u \ v)\<^sup>@(k-1)\<^bold>| < \<^bold>|p'\<^bold>|" + using len2[folded \p' \ ?s = x\] unfolding pow_pos'[OF k_pos] by force from less_imp_le[OF this] - obtain p where "v \ (u \ v)\<^sup>@k \ p = p'" - using ruler_le[OF \?p \p x\ \p' \ u \ v \p x\, unfolded pow_Suc2 lassoc, THEN pref_cancel_right, THEN pref_cancel_right] - by (auto simp add: prefix_def) + obtain p where "v \ (u \ v)\<^sup>@(k-1) \ p = p'" + using ruler_le[OF \?p \p x\ \p' \ u \ v \p x\, + unfolded pow_pos'[OF k_pos] lassoc, THEN pref_cancel_right, THEN pref_cancel_right] + unfolding lenmorph by (auto simp add: prefix_def) have "\<^bold>|p\<^bold>| \ \<^bold>|v\<^bold>|" - using \v \ (u \ v)\<^sup>@k \ p = p'\ \\<^bold>|p' \ u \ v\<^bold>| \ \<^bold>|?p \ v\<^bold>|\ by force + using \v \ (u \ v)\<^sup>@(k-1) \ p = p'\ \\<^bold>|p' \ u \ v\<^bold>| \ \<^bold>|?p \ v\<^bold>|\ unfolding pow_pos'[OF k_pos] by force show "u \ v = v \ u" proof (rule uv_fac_uvv) show "p \ u \ v \p u \ v \ v" - proof (rule pref_cancel[of "v \ (u \ v)\<^sup>@k"], rule ruler_le) - show "(v \ (u \ v) \<^sup>@ k) \ p \ u \ v \p ?p \ x" - unfolding lassoc \v \ (u \ v)\<^sup>@k \ p = p'\[unfolded lassoc] - using \p' \ u \ v \p x\ \x \p ?p \ x\ by force - show "(v \ (u \ v) \<^sup>@ k) \ u \ v \ v \p (v \ (u \ v) \<^sup>@ Suc k) \ x" - unfolding pow_Suc2 rassoc - using \v \ (u \ v) \<^sup>@ Suc k \p x\ by (auto simp add: prefix_def) - show "\<^bold>|(v \ (u \ v) \<^sup>@ k) \ p \ u \ v\<^bold>| \ \<^bold>|(v \ (u \ v) \<^sup>@ k) \ u \ v \ v\<^bold>|" - using \v \ (u \ v)\<^sup>@k \ p = p'\ \\<^bold>|p' \ u \ v\<^bold>| \ \<^bold>|?p \ v\<^bold>|\ by force + proof (rule pref_cancel[of "v \ (u \ v)\<^sup>@(k-1)"], rule ruler_le) + show "(v \ (u \ v) \<^sup>@ (k-1)) \ p \ u \ v \p ?p \ x" + unfolding lassoc \v \ (u \ v)\<^sup>@(k-1) \ p = p'\[unfolded lassoc] + using \p' \ u \ v \p x\ \x \p ?p \ x\ unfolding pow_pos'[OF k_pos] by force + show "(v \ (u \ v) \<^sup>@ (k-1)) \ u \ v \ v \p (v \ (u \ v) \<^sup>@ k) \ x" + unfolding pow_pos'[OF k_pos] rassoc + using \v \ (u \ v) \<^sup>@ k \p x\ by (auto simp add: prefix_def) + show "\<^bold>|(v \ (u \ v) \<^sup>@ (k-1)) \ p \ u \ v\<^bold>| \ \<^bold>|(v \ (u \ v) \<^sup>@ (k-1)) \ u \ v \ v\<^bold>|" + using \v \ (u \ v)\<^sup>@(k-1) \ p = p'\ \\<^bold>|p' \ u \ v\<^bold>| \ \<^bold>|?p \ v\<^bold>|\ unfolding pow_pos'[OF k_pos] by force qed - have "p \s x" - using \p' \ ?s = x\[folded \v \ (u \ v)\<^sup>@k \ p = p'\] \x \s x \ ?s\ suf_cancel suffix_appendD by metis + have "p \s x" + using \p' \ ?s = x\[folded \v \ (u \ v)\<^sup>@(k-1) \ p = p'\] \x \s x \ ?s\ suf_cancel suf_extD by metis - from ruler_le[reversed, OF this \?s \s x\, unfolded pow_Suc2 rassoc] - show "p \s (u \ v) \<^sup>@ m \ u \ v \ u" - using \\<^bold>|p\<^bold>| \ \<^bold>|v\<^bold>|\ unfolding lenmorph by auto + from ruler_le[reversed, OF this \?s \s x\, unfolded pow_pos'[OF m_pos] rassoc] + show "p \s (u \ v) \<^sup>@ (m-1) \ u \ v \ u" + using \\<^bold>|p\<^bold>| \ \<^bold>|v\<^bold>|\ unfolding lenmorph by auto - show "(u \ v) \<^sup>@ m \ u \ v \ u \ \{u, v}\" + show "(u \ v) \<^sup>@ (m-1) \ u \ v \ u \ \{u, v}\" by (simp add: gen_in hull_closed power_in) - show "p \ \" - using \\<^bold>|v \ (u \ v)\<^sup>@k\<^bold>| < \<^bold>|p'\<^bold>|\ \v \ (u \ v)\<^sup>@k \ p = p'\ by force + show "p \ \" + using \\<^bold>|v \ (u \ v)\<^sup>@(k-1)\<^bold>| < \<^bold>|p'\<^bold>|\ \v \ (u \ v)\<^sup>@(k-1) \ p = p'\ by force qed qed -thm +thm no_overlap short_overlap medium_overlap end -thm +thm pref_suf_pers.no_overlap pref_suf_pers.short_overlap pref_suf_pers.medium_overlap pref_suf_pers_large_overlap section \Square interpretation\ -text \In this section fundamental description is given of (the only) -possible @{term "{x,y}"}-interpretation of the square @{term "x\x"}, where @{term "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|"}. +text \In this section fundamental description is given of (the only) +possible @{term "{x,y}"}-interpretation of the square @{term "x\x"}, where @{term "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|"}. The proof is divided into several locales. \ \ \An example motivating disjointness: an interpretation which is not disjoint.\ lemma cover_not_disjoint: - shows "primitive [0::nat,1,0,1,0,1,0]" (is "primitive ?x") and - "primitive[0::nat, 1]" (is "primitive ?y") and - "[0::nat,1,0,1,0,1,0] \ [0,1] \ [0,1] \ [0,1,0,1,0,1,0]" - (is "?x \ ?y \ ?y \ ?x") and - "\ [0::nat,1,0,1,0,1,0] \ [0,1,0,1,0,1,0] [1,0,1,0] \\<^sub>\ [[0,1,0,1,0,1,0],[0,1],[0,1],[0,1,0,1,0,1,0]]" - (is "\ ?x \ ?x ?s \\<^sub>\ [?x,?y,?y,?x]") - unfolding factor_interpretation_def - by (primitivity_inspection+) force + shows "primitive (\\\\\\\\\\\\\)" (is "primitive ?x") and + "primitive (\\\)" (is "primitive ?y") and + "(\\\\\\\\\\\\\) \ (\\\) \ (\\\) \ (\\\\\\\\\\\\\)" + (is "?x \ ?y \ ?y \ ?x") and + "\ (\\\\\\\\\\\\\) \ (\\\\\\\\\\\\\) (\\\\\\\) \\<^sub>\ [(\\\\\\\\\\\\\),(\\\),(\\\),(\\\\\\\\\\\\\)]" + (is "\ ?x \ ?x ?s \\<^sub>\ [?x,?y,?y,?x]") + unfolding factor_interpretation_def + by primitivity_inspection+ force subsection \Locale: interpretation\ locale square_interp = \ \The basic set of assumptions\ - \ \The goal is to arrive at @{term "ws = [x] \ [y]\<^sup>@k \ [x]"} including the description + \ \The goal is to arrive at @{term "ws = [x] \ [y]\<^sup>@k \ [x]"} including the description of the interpretation in terms of the first and the second occurrence of x in the interpreted square.\ - fixes x y p s ws + fixes x y p s ws assumes - prim_x: "primitive x" and prim_y: "primitive y" and - y_le_x: "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" and + non_comm: "x \ y \ y \ x" and + prim_x: "primitive x" and + y_le_x: "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" and ws_lists: "ws \ lists {x,y}" and nconjug: "\ x \ y" and - disjoint: "\ p1 p2. p1 \p [x,x] \ p2 \p ws \ p \ concat p1 \ concat p2" and - interp: "p (x\x) s \\<^sub>\ ws" + disj_interp: "p [x,x] s \\<^sub>\ ws" begin +lemma interp: "p (x\x) s \\<^sub>\ ws" + using disj_interpD[OF disj_interp] by force + +lemma disjoint: "p1 \p [x,x] \ p2 \p ws \ p \ concat p1 \ concat p2" + using disj_interpD1[OF disj_interp]. + interpretation binary_code x y - using binary_code_def comm_prim nconjug nconjug_neq prim_x prim_y by metis + using non_comm by unfold_locales -lemmas interpret_concat = fac_interpretE(3)[OF interp] +lemmas interpret_concat = fac_interpD(3)[OF interp] lemma p_nemp: "p \ \" using disjoint[of \ \] by auto lemma s_nemp: "s \ \" using disjoint[of "[x,x]" ws] interpret_concat by force lemma x_root: "\ x = x" using prim_x by blast -lemma y_root: "\ y = y" - using prim_y by blast lemma ws_nemp: "ws \ \" - using bin_fst_nemp fac_interpret_nemp interp by blast + using bin_fst_nemp fac_interp_nemp interp by blast lemma hd_ws_lists: "hd ws \ {x, y}" using lists_hd_in_set ws_lists ws_nemp by auto lemma last_ws_lists: "last ws \ {x, y}" using lists_hd_in_set[reversed, OF ws_nemp ws_lists]. lemma kE: obtains k where "[hd ws] \ [y]\<^sup>@k \ [last ws] = ws" proof- from list.collapse[OF ws_nemp] hd_word obtain ws' where "ws = [hd ws] \ ws'" by metis hence "\<^bold>|hd ws\<^bold>| \ \<^bold>|x\<^bold>|" using two_elem_cases[OF lists_hd_in_set[OF ws_nemp ws_lists]] y_le_x by blast hence "\<^bold>|x\<^bold>| \ \<^bold>|concat ws'\<^bold>|" using lenarg[OF interpret_concat, unfolded lenmorph] - unfolding concat.simps clean_emp arg_cong[OF \ws = [hd ws] \ ws'\, of "\ x. \<^bold>|concat x\<^bold>|", unfolded concat_morph lenmorph] - by linarith + unfolding concat.simps emp_simps arg_cong[OF \ws = [hd ws] \ ws'\, of "\ x. \<^bold>|concat x\<^bold>|", unfolded concat_morph lenmorph] + by linarith hence "ws' \ \" using nemp_len[OF bin_fst_nemp] by fastforce then obtain mid_ws where "ws' = mid_ws \ [last ws]" using \ws = [hd ws] \ ws'\ append_butlast_last_id last_appendR by metis note \ws = [hd ws] \ ws'\[unfolded this] - fac_interpretE[OF interp] - obtain p' where [symmetric]:"p \ p' = hd ws" and "p' \ \" - using sprefE[OF \p

]. - obtain s' where [symmetric]: "s'\ s = last ws" and "s' \ \" - using sprefE[reversed, OF \s ]. - have "p' \ concat mid_ws \ s' = x \ x" - using \ws = [hd ws] \ mid_ws \ [last ws]\[unfolded \hd ws = p \ p'\ \last ws = s'\ s\] - \p \ (x \ x) \ s = concat ws\ by simp + fac_interpD[OF interp] + obtain p' where [symmetric]:"p \ p' = hd ws" and "p' \ \" + using spref_exE[OF \p

]. + obtain s' where [symmetric]: "s'\ s = last ws" and "s' \ \" + using spref_exE[reversed, OF \s ]. + have "p' \ concat mid_ws \ s' = x \ x" + using \ws = [hd ws] \ mid_ws \ [last ws]\[unfolded \hd ws = p \ p'\ \last ws = s'\ s\] + \p \ (x \ x) \ s = concat ws\ by simp note over = prim_overlap_sqE[OF prim_x, folded this] have "mid_ws \ lists {x,y}" - using \ws = [hd ws] \ ws'\ \ws' = mid_ws \ [last ws]\ append_in_lists_conv ws_lists by metis - have "x \ set mid_ws" + using \ws = [hd ws] \ ws'\ \ws' = mid_ws \ [last ws]\ append_in_lists_conv ws_lists by metis + have "x \ set mid_ws" proof assume "x \ set mid_ws" then obtain r q where "concat mid_ws = r \ x \ q" using concat.simps(2) concat_morph in_set_conv_decomp_first by metis - have "(p' \ r) \ x \ (q \ s') = x \ x" + have "(p' \ r) \ x \ (q \ s') = x \ x" using \p' \ concat mid_ws \ s' = x \ x\[unfolded \concat mid_ws = r \ x \ q\] unfolding rassoc. from prim_overlap_sqE[OF prim_x this] show False using \p' \ \\ \s' \ \\ by blast qed hence "mid_ws \ lists {y}" using \mid_ws \ lists {x,y}\ by force from that sing_lists_exp[OF this] - show thesis + show thesis using \ws = [hd ws] \ mid_ws \ [last ws]\ by metis qed lemma l_mE: obtains m u v l where "(hd ws)\y\<^sup>@m\u = p\x" and "v \ y\<^sup>@l \ (last ws) = x \ s" and - "u\v = y" and "u \ v \ v \ u" -proof- - note fac_interpretE[OF interp] + "u\v = y" "u \ \" "v \ \" and "x \ (v \ u) \ (v \ u) \ x" + proof- + note fac_interpD[OF interp] obtain k where "[hd ws] \ [y]\<^sup>@k \ [last ws] = ws" using kE. from arg_cong[OF this, of concat, folded interpret_concat, unfolded concat_morph rassoc concat_sing' concat_sing_pow] - have "hd ws \ y\<^sup>@k \ last ws = p \ x \ x \ s". + have "hd ws \ y\<^sup>@k \ last ws = p \ x \ x \ s". have "\<^bold>|hd ws\<^bold>| \ \<^bold>|p \ x\<^bold>|" - unfolding lenmorph using y_le_x two_elem_cases[OF hd_ws_lists] using dual_order.trans by fastforce + unfolding lenmorph by (rule two_elem_cases[OF hd_ws_lists]) + (use dual_order.trans[OF le_add2 y_le_x] le_add2[of "\<^bold>|x\<^bold>|"] in fast)+ from eqd[OF _ this] obtain ya where "hd ws \ ya = p \ x" - using \hd ws \ y\<^sup>@k \ last ws = p \ x \ x \ s\ by auto + using \hd ws \ y\<^sup>@k \ last ws = p \ x \ x \ s\ by auto have "\<^bold>|last ws\<^bold>| \ \<^bold>|x\<^bold>|" - unfolding lenmorph using dual_order.trans last_ws_lists y_le_x by auto + unfolding lenmorph using dual_order.trans last_ws_lists y_le_x by auto hence "\<^bold>|last ws\<^bold>| < \<^bold>|x \ s\<^bold>|" - unfolding lenmorph using nemp_len[OF s_nemp] by linarith - from eqd[reversed, OF _ less_imp_le[OF this]] + unfolding lenmorph using nemp_len[OF s_nemp] by linarith + from eqd[reversed, OF _ less_imp_le[OF this]] obtain yb where "yb \ (last ws) = x \ s" - using \(hd ws) \ y\<^sup>@k \ (last ws) = p \ x \ x \ s\ rassoc by metis - hence "yb \ \" - using s_nemp \\<^bold>|last ws\<^bold>| < \<^bold>|x \ s\<^bold>|\ by force + using \(hd ws) \ y\<^sup>@k \ (last ws) = p \ x \ x \ s\ rassoc by metis + hence "yb \ \" + using s_nemp \\<^bold>|last ws\<^bold>| < \<^bold>|x \ s\<^bold>|\ by force have "ya \ yb = y\<^sup>@k" - using \(hd ws) \ y\<^sup>@k \ (last ws) = p \ x \ x \ s\[folded \yb \ (last ws) = x \ s\, unfolded lassoc cancel_right, folded \(hd ws) \ ya = p \ x\, unfolded rassoc cancel, symmetric]. - then obtain m u where "m < k" and "u

@m \ u = ya" - using pref_mod_power[of ya y k] \yb \ \\ by blast + using \(hd ws) \ y\<^sup>@k \ (last ws) = p \ x \ x \ s\[folded \yb \ (last ws) = x \ s\, unfolded lassoc cancel_right, folded \(hd ws) \ ya = p \ x\, unfolded rassoc cancel, symmetric]. + from pref_mod_pow'[OF sprefI[OF prefI[OF this]], folded this] + obtain m u where "m < k" and "u

@m \ u = ya" + using \yb \ \\ by blast have "y\<^sup>@m \ u \ (u\\<^sup>>y) \ y\<^sup>@(k - m - 1) = y\<^sup>@m \ y \ y\<^sup>@(k - m - 1)" - using \u

by (auto simp add: prefix_def) + using \u

by (auto simp add: prefix_def) also have "... = y\<^sup>@(m + 1 + (k-m-1))" - using mult_assoc add_exps pow_one' by metis + using rassoc add_exps pow_1 by metis also have "... = y\<^sup>@k" using \m < k\ by auto - then obtain l v where "u\v = y" and "y\<^sup>@m \ u \ v \ y\<^sup>@l = y\<^sup>@k" - using \y \<^sup>@ m \ u \ u\\<^sup>>y \ y \<^sup>@ (k - m - 1) = y \<^sup>@ m \ y \ y \<^sup>@ (k - m - 1)\ calculation by auto + finally obtain l v where "u\v = y" and "y\<^sup>@m \ u \ v \ y\<^sup>@l = y\<^sup>@k" + using \u

lq_pref by blast have "concat ([hd ws]\[y] \<^sup>@ m) = hd ws \ y \<^sup>@ m" by simp - have "v \ \" - using \u

\u\v = y\ by fast - + using \u

\u\v = y\ by force have "[hd ws] \ [y] \<^sup>@ m \p ws" - using \[hd ws] \ [y]\<^sup>@k \ [last ws] = ws\[folded pop_pow[OF less_imp_le[OF \m < k\]]] by fastforce + using \[hd ws] \ [y]\<^sup>@k \ [last ws] = ws\[folded pop_pow[OF less_imp_le[OF \m < k\]]] by fastforce from disjoint[OF _ this, of "[x]", unfolded \concat ([hd ws] \ [y] \<^sup>@ m) = hd ws \ y \<^sup>@ m\] have "u \ \" using \(hd ws) \ ya = p \ x\[folded \y\<^sup>@m \ u = ya\] s_nemp by force - have "u\v \ v\u" - using comm_not_prim[OF \u \ \\ \v \ \\] prim_y \u\v = y\ by blast - - from that[of m u "u\\<^sup>>y" l, OF \hd ws \ ya = p \ x\[folded \y \<^sup>@ m \ u = ya\], folded \yb \ last ws = x \ s\ \u \ v = y\, - unfolded lq_triv lassoc cancel_right, OF _ _ this] + have "x \ (v \ u) \ (v \ u) \ x" + proof + assume "x \ v \ u = (v \ u) \ x" + from comm_primroots'[OF bin_fst_nemp suf_nemp[OF \u \ \\] this, unfolded x_root] + have "x = \ (v \ u)". + thus False + using \u \ v = y\ nconjug y_le_x + using conjugI' nle_le pref_same_len primroot_emp primroot_len_le primroot_pref swap_len by metis + qed + with that[of m u "u\\<^sup>>y" l, OF \hd ws \ ya = p \ x\[folded \y \<^sup>@ m \ u = ya\], folded \yb \ last ws = x \ s\ \u \ v = y\, + unfolded lq_triv lassoc cancel_right, OF _ _ \u \ \\ \v \ \\ this[unfolded lassoc]] show thesis using \y \<^sup>@ m \ u \ v \ y \<^sup>@ l = y \<^sup>@ k\[folded \ya \ yb = y \<^sup>@ k\ \y \<^sup>@ m \ u = ya\, unfolded rassoc cancel, folded \u \ v = y\] by blast qed lemma last_ws: "last ws = x" proof(rule ccontr) assume "last ws \ x" hence "last ws = y" - using last_ws_lists by blast + using last_ws_lists by blast obtain l m u v where "(hd ws)\y\<^sup>@m\u = p\x" and "v \ y\<^sup>@l \ (last ws) = x \ s" and - "u\v = y" and "u \ v \ v \ u" + "u\v = y" and "u \ \" and "v \ \" and "x \ v \ u \ (v \ u) \ x" using l_mE by metis note y_le_x[folded \u \ v = y\,unfolded swap_len[of u]] from \v \ y\<^sup>@l \ (last ws) = x \ s\[unfolded \last ws = y\, folded \u \ v = y\] have "x \p (v \ u)\<^sup>@Suc l \ v" - unfolding pow_Suc2 rassoc using append_eq_appendI prefix_def shift_pow by metis + unfolding pow_Suc' rassoc using append_eq_appendI prefix_def shift_pow by metis moreover have "(v \ u) \<^sup>@ Suc l \ v \p (v \ u) \ (v \ u) \<^sup>@ Suc l \ v" unfolding lassoc pow_comm[symmetric] using rassoc by blast ultimately have "x \p (v \ u) \ x" - using pref_keeps_root by blast + using pref_keeps_per_root by blast thus False proof (cases "m = 0") assume "m \ 0" - then obtain m' where "m = Suc m'" - using not0_implies_Suc by blast have "v \ u \s x" - using \(hd ws)\y\<^sup>@m\u = p\x\[folded \u \ v = y\, unfolded \m = Suc m'\ pow_Suc2 rassoc] - suffix_appendD[THEN suf_prod_long[OF _ \\<^bold>|v \ u\<^bold>| \ \<^bold>|x\<^bold>|\], of p "hd ws \ (u \ v) \<^sup>@ m' \ u", unfolded rassoc] by simp - have "(v \ u) \ x = x \ (v \ u)" + using \(hd ws)\y\<^sup>@m\u = p\x\[folded \u \ v = y\, unfolded pow_pos'[OF \m \ 0\[unfolded neq0_conv]] rassoc] + suf_extD[THEN suf_prod_long[OF _ \\<^bold>|v \ u\<^bold>| \ \<^bold>|x\<^bold>|\], of p "hd ws \ (u \ v) \<^sup>@ (m-1) \ u", unfolded rassoc] by simp + have [symmetric]: "(v \ u) \ x = x \ (v \ u)" using root_suf_comm'[OF \x \p (v \ u) \ x\ \(v \ u) \s x\]. thus False - using \u \ v = y\ comm_prim conjugI nconjug prim_conjug prim_x prim_y by metis + using \x \ v \ u \ (v \ u) \ x\ by blast next - assume "m = 0" + assume "m = 0" thus False proof (cases "hd ws = y") assume "hd ws = y" have "p \ (x \ x) \ s = y\<^sup>@Suc (Suc (Suc (m+l)))" unfolding rassoc \v \ y\<^sup>@l \ (last ws) = x \ s\[unfolded \last ws = y\, symmetric] power_Suc2 unfolding lassoc \(hd ws)\y\<^sup>@m\u = p\x\[unfolded \hd ws = y\, symmetric] - \u \ v = y\[symmetric] + \u \ v = y\[symmetric] by comparison have "\ x \ \ y" - proof (rule fac_two_conjug_primroot) + proof (rule fac_two_conjug_primroot') show "x \ \" and "y \ \" using bin_fst_nemp bin_snd_nemp. show "x \ x \f y\<^sup>@Suc (Suc (Suc (m+l)))" using facI[of "x\x" p s,unfolded \p \ (x \ x) \ s = y\<^sup>@Suc (Suc (Suc (m+l)))\]. - show "x \ x \f x\<^sup>@2" + show "x \ x \f x\<^sup>@2" unfolding pow_two by blast - show "\<^bold>|x\<^bold>| + \<^bold>|y\<^bold>| - (gcd \<^bold>|x\<^bold>| \<^bold>|y\<^bold>|) \ \<^bold>|x \ x\<^bold>|" + show "\<^bold>|x\<^bold>| + \<^bold>|y\<^bold>| \ \<^bold>|x \ x\<^bold>|" using y_le_x unfolding lenmorph by auto qed thus False - unfolding x_root y_root using nconjug by blast + unfolding x_root using nconjug y_le_x + by (metis conjug_len long_pref primroot_pref) next assume "hd ws \ y" hence "hd ws = x" using hd_ws_lists by auto + have "x \s x \ u" + using \(hd ws)\y\<^sup>@m\u = p\x\[unfolded \m = 0\ \hd ws = x\ pow_zero emp_simps] + by (simp add: suffix_def) + have "v \ u \p x" + using \x \p (v \ u) \ x\ y_le_x[folded \u \ v = y\,unfolded swap_len[of u]] + pref_prod_long by blast + hence "\<^bold>|v \ u\<^bold>| < \<^bold>|x\<^bold>|" + using nconjug conjugI[OF _ \u \ v = y\, of x] \\<^bold>|v \ u\<^bold>| \ \<^bold>|x\<^bold>|\ + le_neq_implies_less pref_same_len by blast have "u \ v = v \ u" proof (rule pref_suf_pers_short[reversed]) - show "x \s x \ u" - using \(hd ws)\y\<^sup>@m\u = p\x\[unfolded \m = 0\ \hd ws = x\ pow_zero clean_emp] - by (simp add: suf_def) - have "v \ u \p x" - using \x \p (v \ u) \ x\ y_le_x[folded \u \ v = y\,unfolded swap_len[of u]] - pref_prod_long by blast - thus "\<^bold>|v \ u\<^bold>| < \<^bold>|x\<^bold>|" - using nconjug conjugI[OF _ \u \ v = y\, of x] \\<^bold>|v \ u\<^bold>| \ \<^bold>|x\<^bold>|\ - le_neq_implies_less pref_same_len by blast - from \x \p (v \ u)\<^sup>@Suc l \ v\ + from \x \p (v \ u)\<^sup>@Suc l \ v\ show "x \p ((v \ u) \ v) \ (u \ v)\<^sup>@l" by comparison - show "(u \ v) \<^sup>@ l \ \{v, u}\" + show "(u \ v) \<^sup>@ l \ \{v, u}\" by blast - qed - thus False - using prim_y \u \ v \ v \ u\ by simp + qed fact+ + from pref_extD[OF \v \ u \p x\[folded \u \ v = v \ u\]] + have "x \ u = u \ x" + using \x \s x \ u\ suf_root_pref_comm by blast + with comm_trans[OF this \u \ v = v \ u\[symmetric] \u \ \\] + have "x \ (v \ u) = (v \ u) \ x" + using comm_prod by blast + thus False + using \x \ v \ u \ (v \ u) \ x\ by blast qed qed qed -lemma rev_square_interp: +lemma rev_square_interp: "square_interp (rev x) (rev y) (rev s) (rev p) (rev (map rev ws))" proof (unfold_locales) show "rev (map rev ws) \ lists {rev x, rev y}" using ws_lists by force - show "(rev s) (rev x \ rev x) (rev p) \\<^sub>\ rev (map rev ws)" - using interp rev_fac_interp by fastforce show "\<^bold>|rev y\<^bold>| \ \<^bold>|rev x\<^bold>|" using y_le_x by simp show "\ (rev x) \ (rev y)" - by (simp add: conjug_rev_conv nconjug) - show "primitive (rev x)" and "primitive (rev y)" - using prim_x prim_y by (simp_all add: prim_rev_iff) - show "\p1 p2. p1 \p [rev x, rev x] \ p2 \p rev (map rev ws) \ rev s \ concat p1 \ concat p2" + by (simp add: conjug_rev_conv nconjug) + show "primitive (rev x)" + using prim_x + by (simp_all add: prim_rev_iff) + show "(rev s) [rev x, rev x] (rev p) \\<^sub>\ (rev (map rev ws))" proof - fix p1' p2' assume "p1' \p [rev x, rev x]" and "p2' \p rev (map rev ws)" and "rev s \ concat p1' = concat p2'" - obtain p1 p2 where "p1' \ p1 = [rev x, rev x]" and "p2'\p2 = rev (map rev ws)" - using \p1' \p [rev x, rev x]\ \p2' \p rev (map rev ws)\ by (auto simp add: prefix_def) - hence "rev s \ (concat p1' \ concat p1) \ rev p = concat p2' \ concat p2" - unfolding concat_morph[symmetric] using \(rev s) (rev x \ rev x) (rev p) \\<^sub>\ rev (map rev ws)\ fac_interpretE(3) by force - from this[unfolded lassoc, folded \rev s \ concat p1' = concat p2'\, unfolded rassoc cancel] - have "concat p1 \ rev p = concat p2". - hence "p \ (concat (rev (map rev p1))) = concat (rev (map rev p2))" - using rev_append rev_concat rev_map rev_rev_ident by metis - have "rev (map rev p1) \p [x,x]" - using arg_cong[OF \p1' \ p1 = [rev x, rev x]\, of "\ x. rev (map rev x)", unfolded map_append rev_append] - by fastforce - have "rev (map rev p2) \p ws" - using arg_cong[OF \p2'\p2 = rev (map rev ws)\, of "\ x. rev (map rev x)", unfolded map_append rev_append rev_map - rev_rev_ident map_rev_involution, folded rev_map] by blast - from disjoint[OF \rev (map rev p1) \p [x,x]\ \rev (map rev p2) \p ws\] - show False - using \p \ (concat (rev (map rev p1))) = concat (rev (map rev p2))\ by blast + show "(rev s) (concat [rev x, rev x]) (rev p) \\<^sub>\ rev (map rev ws)" + using interp rev_fac_interp by fastforce + show "\p1 p2. p1 \p [rev x, rev x] \ p2 \p rev (map rev ws) \ rev s \ concat p1 \ concat p2" + proof + fix p1' p2' assume "p1' \p [rev x, rev x]" and "p2' \p rev (map rev ws)" and "rev s \ concat p1' = concat p2'" + obtain p1 p2 where "p1' \ p1 = [rev x, rev x]" and "p2'\p2 = rev (map rev ws)" + using \p1' \p [rev x, rev x]\ \p2' \p rev (map rev ws)\ by (auto simp add: prefix_def) + hence "rev s \ (concat p1' \ concat p1) \ rev p = concat p2' \ concat p2" + unfolding concat_morph[symmetric] using \(rev s) (concat[rev x,rev x]) (rev p) \\<^sub>\ rev (map rev ws)\ + fac_interpD(3) by force + from this[unfolded lassoc, folded \rev s \ concat p1' = concat p2'\, unfolded rassoc cancel] + have "concat p1 \ rev p = concat p2". + hence "p \ (concat (rev (map rev p1))) = concat (rev (map rev p2))" + using rev_append rev_concat rev_map rev_rev_ident by metis + have "rev (map rev p1) \p [x,x]" + using arg_cong[OF \p1' \ p1 = [rev x, rev x]\, of "\ x. rev (map rev x)", unfolded map_append rev_append] + by fastforce + have "rev (map rev p2) \p ws" + using arg_cong[OF \p2'\p2 = rev (map rev ws)\, of "\ x. rev (map rev x)", unfolded map_append rev_append rev_map + rev_rev_ident map_rev_involution, folded rev_map] by blast + from disjoint[OF \rev (map rev p1) \p [x,x]\ \rev (map rev p2) \p ws\] + show False + using \p \ (concat (rev (map rev p1))) = concat (rev (map rev p2))\ by blast + qed qed + show "rev x \ rev y \ rev y \ rev x" + using non_comm unfolding comm_rev_iff. qed lemma hd_ws: "hd ws = x" -using square_interp.last_ws[reversed, OF rev_square_interp] -unfolding hd_map[OF ws_nemp] - by simp + using square_interp.last_ws[reversed, OF rev_square_interp] + unfolding hd_map[OF ws_nemp] + by simp lemma p_pref: "p

Locale with additional parameters\ \ \Obtained parameters added into the context, we show that there is just one @{term y} in @{term ws}, that is, that @{term "m = 0"} and @{term "l = 0"}. - The proof harvests results obtained in the section "Lemmas for covered x square" + The proof harvests results obtained in the section "Lemmas for covered x square" \ locale square_interp_plus = square_interp + - fixes l m u v + fixes l m u v assumes fst_x: "x \ y\<^sup>@m \ u = p \ x" and - snd_x: "v \ y\<^sup>@l \ x = x \ s" and + snd_x: "v \ y\<^sup>@l \ x = x \ s" and uv_y: "u \ v = y" and - uv_code: "u \ v \ v \ u" + u_nemp: "u \ \" and v_nemp: "v \ \" and + vu_x_non_comm: "x \ (v \ u) \ (v \ u) \ x" begin interpretation binary_code x y - using binary_code.intro comm_prim nconjug nconjug_neq prim_x prim_y by metis + using non_comm by unfold_locales -interpretation uv: binary_code u v - using uv_code by (simp add: binary_code.intro) -lemma rev_square_interpret_plus: "square_interp_plus (rev x) (rev y) (rev s) (rev p) (rev (map rev ws)) m l (rev v) (rev u)" +lemma rev_square_interp_plus: "square_interp_plus (rev x) (rev y) (rev s) (rev p) (rev (map rev ws)) m l (rev v) (rev u)" proof- - note fac_interpretE[OF interp, unfolded hd_ws last_ws] + note fac_interpD[OF interp, unfolded hd_ws last_ws] note \s [unfolded strict_suffix_to_prefix] note \p

[unfolded spref_rev_suf_iff] interpret i: square_interp "(rev x)" "(rev y)" "(rev s)" "(rev p)" "(rev (map rev ws))" using rev_square_interp. show ?thesis - apply standard - apply (simp_all del: rev_append add: rev_pow[symmetric] rev_append[symmetric]) - by (simp_all only: uv_code, simp_all add: fst_x snd_x uv_y) + by standard + (simp_all del: rev_append add: rev_pow[symmetric] rev_append[symmetric], + simp_all add: fst_x snd_x uv_y v_nemp u_nemp vu_x_non_comm[symmetric, unfolded rassoc]) qed subsubsection \Exactly one of the exponents is zero: impossible.\ text \Uses lemma @{thm pref_suf_pers_short} and exploits the symmetric interpretation.\ -lemma fst_exp_zero: assumes "m = 0" and "l \ 0" shows "False" -proof (rule notE[OF uv_code]) +lemma fst_exp_zero: assumes "m = 0" and "0 < l" shows "False" +proof (rule notE[OF vu_x_non_comm]) note y_le_x[folded uv_y, unfolded swap_len[of u]] have "x \p (v \ (u \ v) \<^sup>@ l) \ x" - unfolding rassoc using snd_x[folded uv_y] by fast - moreover have "v \ (u \ v) \<^sup>@ l \ \" - using uv_code by force - ultimately obtain exp where "x \p (v \ (u \ v) \<^sup>@ l)\<^sup>@exp" - using per_prefE by blast - hence "exp \ 0" - using pow_zero bin_fst_nemp[folded prefix_Nil] by metis + unfolding rassoc using snd_x[folded uv_y] by blast + have "v \ (u \ v) \<^sup>@ l \ \" + using v_nemp by force + obtain exp where "x \p (v \ (u \ v) \<^sup>@ l)\<^sup>@exp" "0 < exp" + using per_root_powE[OF per_rootI[OF \x \p (v \ (u \ v) \<^sup>@ l) \ x\ \v \ (u \ v) \<^sup>@ l \ \\], of thesis] by blast - show "u \ v = v \ u" - proof (rule pref_suf_pers_short[reversed]) - show "x \s x \ u" - using fst_x[unfolded \m = 0\ pow_zero clean_emp] by (simp add: suf_def) - have "((v \ u) \ v) \ ((u \ v)\<^sup>@(l-1)) \ (v \ (u \ v) \<^sup>@ l)\<^sup>@(exp -1) = (v \ (u \ v) \<^sup>@ l)\<^sup>@exp" + have "x \s x \ u" + using fst_x[unfolded \m = 0\ pow_zero emp_simps] by (simp add: suffix_def) + have "((v \ u) \ v) \ ((u \ v)\<^sup>@(l-1)) \ (v \ (u \ v) \<^sup>@ l)\<^sup>@(exp-1) = (v \ (u \ v) \<^sup>@ l)\<^sup>@exp" (is "((v \ u) \ v) \ ?suf = (v \ (u \ v) \<^sup>@ l)\<^sup>@exp") - by (simp add: \exp \ 0\ \l \ 0\ pop_pow_one) - show "((u \ v)\<^sup>@(l-1)) \ (v \ (u \ v) \<^sup>@ l)\<^sup>@(exp -1) \ \{v,u}\" - by (simp add: gen_in hull_closed power_in) + using \0 < l\ \0 < exp\ by comparison have "v \ u \p x" using pref_prod_longer[OF \x \p (v \ (u \ v) \<^sup>@ l) \ x\[unfolded rassoc] _ \\<^bold>|v \ u\<^bold>| \ \<^bold>|x\<^bold>|\] - unfolding pop_pow_one[OF \l \ 0\] rassoc by blast - thus "\<^bold>|v \ u\<^bold>| < \<^bold>|x\<^bold>|" + unfolding pow_pos[OF \0 < l\] rassoc by blast + hence "\<^bold>|v \ u\<^bold>| < \<^bold>|x\<^bold>|" using nconjug conjugI[OF _ uv_y, of x] \\<^bold>|v \ u\<^bold>| \ \<^bold>|x\<^bold>|\ - le_neq_implies_less pref_same_len by blast - show "x \p ((v \ u) \ v) \ ?suf" + le_neq_implies_less pref_same_len by blast + have "u \ v = v \ u" + proof (rule pref_suf_pers_short[reversed]) + show "x \p ((v \ u) \ v) \ ?suf" unfolding \((v \ u) \ v) \ ?suf = (v \ (u \ v) \<^sup>@ l)\<^sup>@exp\ by fact - qed + show "((u \ v)\<^sup>@(l-1)) \ (v \ (u \ v) \<^sup>@ l)\<^sup>@(exp-1) \ \{v,u}\" + by (simp add: gen_in hull_closed power_in) + qed fact+ + show "x \ v \ u = (v \ u) \ x" + using root_suf_comm[OF _ \x \s x \ u\] pref_keeps_per_root comm_trans[OF \u \ v = v \ u\[symmetric] _ u_nemp, symmetric] \v \ u \p x\ comm_prod prefI + by metis qed -lemma snd_exp_zero: assumes "m \ 0" and "l = 0" shows "False" -using square_interp_plus.fst_exp_zero[OF rev_square_interpret_plus, reversed, - rotated, OF assms]. +lemma snd_exp_zero: assumes "0 < m" and "l = 0" shows "False" + using square_interp_plus.fst_exp_zero[OF rev_square_interp_plus, reversed, + rotated, OF assms]. subsubsection \Both exponents positive: impossible\ -lemma both_exps_pos: assumes "m \ 0" and "l \ 0" shows "False" +lemma both_exps_pos: assumes "0 < m" and "0 < l" shows "False" proof- - note fac_interpretE[OF interp, unfolded hd_ws last_ws] - have "\<^bold>|p\<^bold>| \ \<^bold>|x\<^bold>|" and "\<^bold>|s\<^bold>| \ \<^bold>|x\<^bold>|" + note fac_interpD[OF interp, unfolded hd_ws last_ws] + have "\<^bold>|p\<^bold>| \ \<^bold>|x\<^bold>|" and "\<^bold>|s\<^bold>| \ \<^bold>|x\<^bold>|" using pref_len[OF sprefD1[OF \p

]] suf_len[OF ssufD1[OF \s ]]. - obtain m' l' where "Suc m' = m" and "Suc l' = l" - using assms predE by metis - have "x \p (v \ (u \ v)\<^sup>@Suc l') \ x" + have "x \p (v \ (u \ v)\<^sup>@l) \ x" (is "x \p ?pref \ x") - using snd_x[folded uv_y \Suc l' = l\] by force - moreover have "x \s x \ ((u \ v)\<^sup>@Suc m' \ u)" - (is "x \s x \ ?suf") - using fst_x[folded uv_y \Suc m' = m\] by force + using snd_x[folded uv_y] by force + moreover have "x \s x \ ((u \ v)\<^sup>@m \ u)" + (is "x \s x \ ?suf") + using fst_x[folded uv_y] by force - ultimately interpret pref_suf_pers x u v l' m' - by (unfold_locales) + ultimately interpret pref_suf_pers x u v l m + using \0 < l\ \0 < m\ by unfold_locales have "?pref \p x" - using snd_x[folded uv_y \Suc l' = l\ rassoc, symmetric] eqd[reversed, OF _ \\<^bold>|s\<^bold>| \ \<^bold>|x\<^bold>|\] by blast - have "?suf \s x" - using fst_x[folded uv_y \Suc m' = m\, symmetric] eqd[OF _ \\<^bold>|p\<^bold>| \ \<^bold>|x\<^bold>|\] by blast + using snd_x[folded uv_y rassoc, symmetric] eqd[reversed, OF _ \\<^bold>|s\<^bold>| \ \<^bold>|x\<^bold>|\] by blast + have "?suf \s x" + using fst_x[folded uv_y, symmetric] eqd[OF _ \\<^bold>|p\<^bold>| \ \<^bold>|x\<^bold>|\] by blast - have in_particular: "commutes {u,v,x} \ u \ v = v \ u" - using commutes_def insertCI by metis - have in_particular': "x \ v \ u = (v \ u) \ x \ x \ y" - using comm_prim conjugI' prim_conjug prim_x prim_y uv_y by metis + have in_particular: "commutes {u,v,x} \ x \ (v\u) = (v\u) \ x" + unfolding commutes_def by (rule comm_prod) blast+ \ \Case analysis based on (slightly modified) lemmas for covered x square.\ note no_overlap_comm = no_overlap[THEN in_particular] and short_overlap_comm = short_overlap[THEN in_particular] and medium_overlap_comm = medium_overlap[THEN in_particular] and - large_overlap_conjug = pref_suf_pers_large_overlap[OF \?pref \p x\ \?suf \s x\,THEN in_particular'] + large_overlap_conjug = pref_suf_pers_large_overlap[OF \?pref \p x\ \?suf \s x\, of "v\u"] consider (no_overlap) "\<^bold>|?pref\<^bold>| + \<^bold>|?suf\<^bold>| \ \<^bold>|x\<^bold>|" | (short_overlap) "\<^bold>|x\<^bold>| < \<^bold>|?pref\<^bold>| + \<^bold>|?suf\<^bold>| \ \<^bold>|?pref\<^bold>| + \<^bold>|?suf\<^bold>| \ \<^bold>|x\<^bold>| + \<^bold>|u\<^bold>|" | - (medium_overlap) "\<^bold>|x\<^bold>| + \<^bold>|u\<^bold>| < \<^bold>|?pref\<^bold>| + \<^bold>|?suf\<^bold>| \ \<^bold>|?pref\<^bold>| + \<^bold>|?suf\<^bold>| < \<^bold>|x\<^bold>| + \<^bold>|u \ v\<^bold>|" | + (medium_overlap) "\<^bold>|x\<^bold>| + \<^bold>|u\<^bold>| < \<^bold>|?pref\<^bold>| + \<^bold>|?suf\<^bold>| \ \<^bold>|?pref\<^bold>| + \<^bold>|?suf\<^bold>| < \<^bold>|x\<^bold>| + \<^bold>|u \ v\<^bold>|" | (large_overlap) "\<^bold>|x\<^bold>| + \<^bold>|v \ u\<^bold>| \ \<^bold>|?pref\<^bold>| + \<^bold>|?suf\<^bold>|" unfolding swap_len[of v] by linarith - thus False + thus False proof (cases) case no_overlap - then show False - using no_overlap_comm uv_code by blast + then show False + using no_overlap_comm vu_x_non_comm \0 < l\ \0 < m\ by blast next case short_overlap - then show False - using short_overlap_comm uv_code by blast + then show False + using short_overlap_comm vu_x_non_comm by blast next case medium_overlap - then show False - using medium_overlap_comm uv_code by blast + then show False + using medium_overlap_comm vu_x_non_comm by blast next case large_overlap show False - thm large_overlap_conjug nconjug - proof (rule notE[OF nconjug], rule large_overlap_conjug[OF _ _ large_overlap]) - have "(u \ v) \<^sup>@ l' \p (u \ v) \<^sup>@ Suc l'" - using pref_pow_ext by blast - thus "v \ (u \ v) \<^sup>@ Suc l' \p (v \ u) \ v \ (u \ v) \<^sup>@ Suc l'" - unfolding pow_Suc rassoc pref_cancel_conv. - show "(u \ v) \<^sup>@ Suc m' \ u \s ((u \ v) \<^sup>@ Suc m' \ u) \ v \ u" - by comparison + thm large_overlap_conjug nconjug + proof (rule notE[OF vu_x_non_comm], rule large_overlap_conjug[OF _ _ large_overlap]) + have "(u \ v) \<^sup>@ (l-1) \p (u \ v) \<^sup>@ Suc (l-1)" + using pref_pow_ext by blast + thus "v \ (u \ v) \<^sup>@ l \p (v \ u) \ v \ (u \ v) \<^sup>@ l" + unfolding pow_pos[OF \0 < l\] pow_Suc rassoc pref_cancel_conv. + show "(u \ v) \<^sup>@ m \ u \s ((u \ v) \<^sup>@ m \ u) \ v \ u" + by comparison qed qed -qed +qed thm suf_cancel_conv -end +end subsection \Back to the main locale\ context square_interp begin definition u where "u = x\\<^sup>>(p \ x)" definition v where "v = (x \ s)\<^sup><\x" -lemma cover_xyx: "ws = [x,y,x]" and uv_code: "u \ v \ v \ u" and uv_y: "u \ v = y" and - px_xu: "p \ x = x \ u" and vx_xs: "v \ x = x \ s" +lemma cover_xyx: "ws = [x,y,x]" and vu_x_non_comm: "x \ (v \ u) \ (v \ u) \ x" and uv_y: "u \ v = y" and + px_xu: "p \ x = x \ u" and vx_xs: "v \ x = x \ s" and u_nemp: "u \ \" and v_nemp: "v \ \" proof- - note prim_nemp[OF prim_y] - obtain k where ws: "[x] \ [y]\<^sup>@k \ [x] = ws" + obtain k where ws: "[x] \ [y]\<^sup>@k \ [x] = ws" using kE[unfolded hd_ws last_ws]. - obtain m u' v' l where "x \ y \<^sup>@ m \ u' = p \ x" and "v' \ y \<^sup>@ l \ x = x \ s" and "u' \ v' = y" and "u' \ v' \ v' \ u'" - using l_mE[unfolded hd_ws last_ws]. + obtain m u' v' l where "x \ y \<^sup>@ m \ u' = p \ x" and "v' \ y \<^sup>@ l \ x = x \ s" and "u' \ v' = y" + and "u' \ \" and "v' \ \" and "x \ v' \ u' \ (v' \ u') \ x" + using l_mE[unfolded hd_ws last_ws]. then interpret square_interp_plus x y p s ws l m u' v' by (unfold_locales) - have "m = 0" and "l = 0" - using both_exps_pos snd_exp_zero fst_exp_zero by blast+ + have "m = 0" and "l = 0" and "y \ \" + using both_exps_pos snd_exp_zero fst_exp_zero \u' \ v' = y\ \u' \ \\ by blast+ have "u' = u" unfolding u_def - using conjug_lq[OF fst_x[unfolded \m = 0\ pow_zero clean_emp, symmetric]]. + using conjug_lq[OF fst_x[unfolded \m = 0\ pow_zero emp_simps, symmetric]]. have "v' = v" unfolding v_def - using conjug_lq[reversed, OF snd_x[unfolded \l = 0\ pow_zero clean_emp, symmetric]]. + using conjug_lq[reversed, OF snd_x[unfolded \l = 0\ pow_zero emp_simps, symmetric]]. have "x \ y \<^sup>@ m \ (u' \ v') \ y\<^sup>@l \ x = concat ws" unfolding interpret_concat[symmetric] using fst_x snd_x by force - from this[folded ws, unfolded \u' \ v' = y\ \m = 0\ \l = 0\ pow_zero clean_emp] + from this[folded ws, unfolded \u' \ v' = y\ \m = 0\ \l = 0\ pow_zero emp_simps] have "k = 1" - unfolding eq_pow_exp[OF \y \ \\, of k 1, symmetric] pow_one' concat_morph concat_pow + unfolding eq_pow_exp[OF \y \ \\, of k 1, symmetric] pow_1 concat_morph concat_pow by simp - from ws[unfolded this pow_one'] - show "ws = [x,y,x]" by simp - show "u \ v = y" and "u \ v \ v \ u" + from ws[unfolded this pow_1] + show "ws = [x,y,x]" by simp + show "u \ v = y" unfolding \u' = u\[symmetric] \v' = v\[symmetric] by fact+ show "p \ x = x \ u" - using \x \ y \<^sup>@ m \ u' = p \ x\[unfolded \m = 0\ \u' = u\ pow_zero clean_emp, symmetric]. + using \x \ y \<^sup>@ m \ u' = p \ x\[unfolded \m = 0\ \u' = u\ pow_zero emp_simps, symmetric]. show " v \ x = x \ s" - using \v' \ y \<^sup>@ l \ x = x \ s\[unfolded \l = 0\ \v' = v\ pow_zero clean_emp]. + using \v' \ y \<^sup>@ l \ x = x \ s\[unfolded \l = 0\ \v' = v\ pow_zero emp_simps]. + show "x \ (v \ u) \ (v \ u) \ x" + using \x \ v' \ u' \ (v' \ u') \ x\[unfolded \u' = u\ \v' = v\]. + show "u \ \" and "v \ \" + using \u' \ \\ \v' \ \\ unfolding \u' = u\ \v' = v\. qed -lemma u_nemp: "u \ \" and v_nemp: "v \ \" - using uv_code by force+ - lemma cover: "x \ y \ x = p \ x \ x \ s" - using interpret_concat cover_xyx by auto + using interpret_concat cover_xyx by auto lemma conjug_facs: "\ u \ \ v" proof- note sufI[OF px_xu] have "u \ \" - using p_nemp px_xu by force - obtain expu where "x \f u\<^sup>@expu" - using per_prefE[reversed, OF \ x \s x \ u\ \u \ \\ pref_fac[reversed,elim_format]]. + using p_nemp px_xu by force + obtain expu where "x @ expu" "0 < expu" + using per_root_powE[reversed, OF per_rootI[reversed, OF \ x \s x \ u\ \u \ \\]]. + hence "x \f u\<^sup>@ expu" + using ssufD1 by blast note prefI[OF vx_xs[symmetric]] have "v \ \" using s_nemp vx_xs by force - obtain expv where "x \f v\<^sup>@expv" - using per_prefE[OF \x \p v \ x\ \v \ \\ pref_fac[elim_format]]. + obtain expv where "x

@expv" "0 < expv" + using per_root_powE[OF per_rootI[OF \x \p v \ x\ \v \ \\]]. + hence "x \f v\<^sup>@expv" by blast show "\ u \ \ v" - proof(rule fac_two_conjug_primroot[OF \x \f u\<^sup>@expu\ \x \f v\<^sup>@expv\ \u \ \\ \v \ \\]) - show "\<^bold>|u\<^bold>| + \<^bold>|v\<^bold>| - (gcd \<^bold>|u\<^bold>| \<^bold>|v\<^bold>|) \ \<^bold>|x\<^bold>|" + proof(rule fac_two_conjug_primroot'[OF \x \f u\<^sup>@expu\ \x \f v\<^sup>@expv\ \u \ \\ \v \ \\]) + show "\<^bold>|u\<^bold>| + \<^bold>|v\<^bold>| \ \<^bold>|x\<^bold>|" using y_le_x[folded uv_y, unfolded lenmorph] by fastforce - qed + qed qed term square_interp.v \ \We have a detailed information about all words\ lemma bin_sq_interpE: obtains r t m k l - where "(t \ r)\<^sup>@Suc k = u" and "(r \ t)\<^sup>@Suc l = v" and - "(r \ t)\<^sup>@Suc m \ r = x" and "(t \ r)\<^sup>@Suc k \ (r \ t)\<^sup>@Suc l = y" - and "(r \ t)\<^sup>@Suc k = p" and "(t \ r)\<^sup>@Suc l = s" and "r \ t \ t \ r" + where "(t \ r)\<^sup>@k = u" and "(r \ t)\<^sup>@l = v" and + "(r \ t)\<^sup>@m \ r = x" and "(t \ r)\<^sup>@k \ (r \ t)\<^sup>@ l = y" + and "(r \ t)\<^sup>@k = p" and "(t \ r)\<^sup>@ l = s" and "r \ t \ t \ r" and + "0 < k" and "0 < m" and "0 < l" proof- - obtain r t k m where "(r \ t)\<^sup>@Suc k = p" and "(t \ r)\<^sup>@Suc k = u" and "(r \ t)\<^sup>@m \ r = x" and - "t \ \" and "primitive (r \ t)" - using conjug_eq_primrootE[OF px_xu p_nemp]. + obtain r t k m where "(r \ t)\<^sup>@ k = p" and "(t \ r)\<^sup>@ k = u" and "(r \ t)\<^sup>@m \ r = x" and + "t \ \" and "0 < k" and "primitive (r \ t)" + using conjug_eq_primrootE[OF px_xu p_nemp]. have "t \ r = \ u" - using prim_conjug[OF \primitive (r \ t)\, THEN pow_prim_primroot[OF u_nemp], OF conjugI' \(t \ r)\<^sup>@Suc k = u\[symmetric]].. + using prim_conjug[OF \primitive (r \ t)\, THEN primroot_unique[OF u_nemp], OF conjugI' \(t \ r)\<^sup>@k = u\[symmetric]].. - have "m \ 0" - proof - assume "m = 0" + have "0 < m" + proof (rule ccontr) + assume "\ 0 < m" hence "x = r" using \(r \ t)\<^sup>@m \ r = x\ by simp - from y_le_x[folded uv_y, folded \(t \ r)\<^sup>@Suc k = u\, unfolded lenmorph pow_len this] show False - using nemp_len[OF \t \ \\] by force + using \0 < k\ \(r \ t) \<^sup>@ k = p\ \x = r\ comp_pows_pref_zero p_pref by blast qed - then obtain pred_m where "m = Suc pred_m" - using not0_implies_Suc by auto - from \(r \ t)\<^sup>@m \ r = x\[unfolded this] + from \(r \ t)\<^sup>@m \ r = x\[unfolded pow_pos[OF \0 < m\]] have "r \ t \p x" by auto have "r \ t = \ v" proof (rule ruler_eq_len[of "\ v" "x" "r \ t", symmetric]) have "\<^bold>|\ v\<^bold>| \ \<^bold>|x\<^bold>|" unfolding conjug_len[OF conjug_facs, symmetric] \t \ r = \ u\[symmetric] - unfolding \(r \ t)\<^sup>@m \ r = x\[symmetric] - lenmorph pow_len - using \m = Suc pred_m\ by auto + unfolding \(r \ t)\<^sup>@m \ r = x\[symmetric] pow_pos[OF \0 < m\] + lenmorph pow_len by auto from ruler_le[OF _ _ this, of "v \ x"] show "\ v \p x" - using vx_xs prefI prefix_prefix primroot_pref v_nemp by metis + using vx_xs prefI prefix_prefix primroot_pref v_nemp by metis show "r \ t \p x" by fact show "\<^bold>|\ v\<^bold>| = \<^bold>|r \ t\<^bold>|" unfolding conjug_len[OF conjug_facs, symmetric, folded \t \ r = \ u\] lenmorph by simp qed - then obtain l where "(r \ t)\<^sup>@Suc l = v" + then obtain l where "(r \ t)\<^sup>@ l = v" and "0 < l" using primroot_expE v_nemp by metis - have "(t \ r)\<^sup>@Suc l = s" - using vx_xs[folded \(r \ t)\<^sup>@m \ r = x\ \(r \ t)\<^sup>@Suc l = v\, unfolded lassoc pows_comm[of _ _ m], - unfolded rassoc cancel, unfolded shift_pow cancel]. + have "(t \ r)\<^sup>@ l = s" + using vx_xs[folded \(r \ t)\<^sup>@m \ r = x\ \(r \ t)\<^sup>@ l = v\, unfolded lassoc pows_comm[of _ _ m], + unfolded rassoc cancel, unfolded shift_pow cancel]. have "r \ t \ t \ r" - using \(t \ r) \<^sup>@ Suc k = u\ \(r \ t) \<^sup>@ Suc l = v\ pows_comm[of "t \ r" "Suc k" "Suc l"] uv_code by force + proof + assume "r \ t = t \ r" + hence aux: "r \ (t \ r) \<^sup>@ e = (t \ r) \<^sup>@ e \ r" for e + by comparison + have "x \ (v \ u) = (v \ u) \ x" + unfolding \(t \ r) \<^sup>@ k = u\[symmetric] \(r \ t) \<^sup>@ l = v\[symmetric] + unfolding \(r \ t)\<^sup>@m \ r = x\[symmetric] add_exps[symmetric] \r \ t = t \ r\ aux rassoc + unfolding lassoc cancel_right add_exps[symmetric] + by (simp add: add.commute) + thus False + using vu_x_non_comm by blast + qed show thesis - using that[OF \(t \r)\<^sup>@Suc k = u\ \(r \ t) \<^sup>@ Suc l = v\ \(r \ t)\<^sup>@m \ r = x\[unfolded \m = Suc pred_m\] - uv_y[folded \(t \r)\<^sup>@Suc k = u\ \(r \ t) \<^sup>@ Suc l = v\] \(r \ t) \<^sup>@ Suc k = p\ \(t \ r) \<^sup>@ Suc l = s\ \r \ t \ t \ r\]. + using that[OF \(t \r)\<^sup>@ k = u\ \(r \ t) \<^sup>@ l = v\ \(r \ t)\<^sup>@m \ r = x\ + uv_y[folded \(t \r)\<^sup>@ k = u\ \(r \ t) \<^sup>@ l = v\] \(r \ t) \<^sup>@ k = p\ \(t \ r) \<^sup>@ l = s\ \r \ t \ t \ r\ + \0 < k\ \0 < m\ \0 < l\]. qed end subsection \Locale: Extendable interpretation\ text \Further specification follows from the assumption that the interpretation is extendable, that is, the covered @{term "x\x"} is a factor of a word composed of @{term "{x,y}"}. Namely, @{term u} and @{term v} are then conjugate by @{term x}.\ locale square_interp_ext = square_interp + assumes p_extend: "\ pe. pe \ \{x,y}\ \ p \s pe" and s_extend: "\ se. se \ \{x,y}\ \ s \p se" begin lemma s_pref_y: "s \p y" proof- obtain sy ry eu ev ex - where "(ry \ sy)\<^sup>@Suc eu = u" and "(sy \ ry)\<^sup>@Suc ev = v" and - "(sy \ ry)\<^sup>@Suc eu = p" and "(ry \ sy)\<^sup>@Suc ev = s" and - "(sy \ ry)\<^sup>@Suc ex \ sy = x" and "sy \ ry \ ry \ sy" + where "(ry \ sy)\<^sup>@eu = u" and "(sy \ ry)\<^sup>@ ev = v" and + "(sy \ ry)\<^sup>@ eu = p" and "(ry \ sy)\<^sup>@ ev = s" and + "(sy \ ry)\<^sup>@ ex \ sy = x" and "sy \ ry \ ry \ sy" and + "0 < eu" and "0 < ev" and "0 < ex" using bin_sq_interpE. obtain se where "se \ \{x,y}\" and "s \p se" using s_extend by blast hence "se \ \" using s_nemp by force - from \(sy \ ry)\<^sup>@Suc ex \ sy = x\ + from \(sy \ ry)\<^sup>@ ex \ sy = x\ have "sy \ ry \p x" - unfolding pow_Suc rassoc by force + unfolding pow_pos[OF \0 < ex\] rassoc by force have "x \p se \ y \p se" using \se \ \\ hull.cases[OF \se \ \{x,y}\\, of "x \p se \ y \p se"] - prefix_append triv_pref two_elem_cases by blast + prefix_append triv_pref two_elem_cases by blast moreover have "\ x \p se" proof assume "x \p se" from ruler_eq_len[of "sy \ ry" se "ry \ sy", OF pref_trans[OF \sy \ ry \p x\ this]] - show False - using \s \p se\[folded \(ry \ sy)\<^sup>@Suc ev = s\[unfolded pow_Suc]] \sy \ ry \ ry \ sy\ by (force simp add: prefix_def) + show False + using \s \p se\[folded \(ry \ sy)\<^sup>@ ev = s\[unfolded pow_pos[OF \0 < ev\]]] \sy \ ry \ ry \ sy\ by (force simp add: prefix_def) qed ultimately have y_pref_se: "y \p se" by blast - from ruler_le[OF \s \p se\ this] + from ruler_le[OF \s \p se\ this] show "s \p y" using lenarg[OF vx_xs] unfolding uv_y[symmetric] lenmorph by linarith qed -lemma rev_square_interpret_ext: "square_interp_ext (rev x) (rev y) (rev s) (rev p) (rev (map rev ws))" +lemma rev_square_interp_ext: "square_interp_ext (rev x) (rev y) (rev s) (rev p) (rev (map rev ws))" proof- interpret i: square_interp "(rev x)" "(rev y)" "(rev s)" "(rev p)" "(rev (map rev ws))" using rev_square_interp. show ?thesis - proof + proof show "\pe. pe \ \{rev x, rev y}\ \ rev s \s pe" - using pref_rev_suf_iff s_pref_y by blast + using s_pref_y unfolding pref_rev_suf_iff by blast obtain pe where "pe \ \{x, y}\" and "p \s pe" using p_extend by blast hence "rev pe \ \{rev x, rev y}\" - by (simp add: rev_hull rev_in_conv) + by (simp add: rev_hull rev_in_conv) thus "\se. se \ \{rev x, rev y}\ \ rev p \p se" using \p \s pe\[unfolded suf_rev_pref_iff prefix_def] rev_rev_ident by blast qed qed lemma p_suf_y: "p \s y" proof- interpret i: square_interp_ext "(rev x)" "(rev y)" "(rev s)" "(rev p)" "(rev (map rev ws))" - using rev_square_interpret_ext. + using rev_square_interp_ext. from i.s_pref_y[reversed] show "p \s y". -qed +qed -theorem bin_sq_interpret_extE: obtains r t k m where "(r \ t)\<^sup>@Suc m \ r = x" and "(t \ r)\<^sup>@Suc k \ (r \ t)\<^sup>@ Suc k = y" - "(r \ t)\<^sup>@Suc k = p" and "(t \ r)\<^sup>@ Suc k = s" and "r \ t \ t \ r" and "u = s" and "v = p" and "\<^bold>|p\<^bold>| = \<^bold>|s\<^bold>|" -proof- +theorem bin_sq_interp_extE: obtains r t k m where "(r \ t)\<^sup>@m \ r = x" and "(t \ r)\<^sup>@k \ (r \ t)\<^sup>@ k = y" + "(r \ t)\<^sup>@ k = p" and "(t \ r)\<^sup>@ k = s" and "r \ t \ t \ r" and "u = s" and "v = p" and "\<^bold>|p\<^bold>| = \<^bold>|s\<^bold>|" and + "0 < k" and "0 < m" +proof- obtain r t k k' m - where u: "(t \ r)\<^sup>@Suc k = u" and v: "(r \ t)\<^sup>@Suc k' = v" and - p: "(r \ t)\<^sup>@Suc k = p" and s: "(t \ r)\<^sup>@Suc k' = s" and - x: "(r \ t)\<^sup>@Suc m \ r = x" and code: "r \ t \ t \ r" - using bin_sq_interpE. + where u: "(t \ r)\<^sup>@ k = u" and v: "(r \ t)\<^sup>@ k' = v" and + p: "(r \ t)\<^sup>@ k = p" and s: "(t \ r)\<^sup>@ k' = s" and + x: "(r \ t)\<^sup>@ m \ r = x" and code: "r \ t \ t \ r" and + "0 < k'" "0 < m" "0 < k" + using bin_sq_interpE. have "\<^bold>|u \ v\<^bold>| = \<^bold>|s \ p\<^bold>|" using lenarg[OF px_xu, unfolded lenmorph] lenarg[OF vx_xs, unfolded lenmorph] by simp hence "u \ v = s \ p" - unfolding uv_y using s_pref_y p_suf_y by (auto simp add: prefix_def suf_def) - note eq = \u \ v = s \ p\[unfolded \(t \ r)\<^sup>@Suc k = u\[symmetric] \(r \ t)\<^sup>@Suc k' = v\[symmetric], - unfolded \(t \ r)\<^sup>@Suc k' = s\[symmetric] \(r \ t)\<^sup>@Suc k = p\[symmetric]] - from pows_eq_comm[OF this, THEN comm_add_exps, of "Suc k" "Suc k'"] + unfolding uv_y using s_pref_y p_suf_y by (auto simp add: prefix_def suffix_def) + note eq = \u \ v = s \ p\[unfolded \(t \ r)\<^sup>@ k = u\[symmetric] \(r \ t)\<^sup>@ k' = v\[symmetric], + unfolded \(t \ r)\<^sup>@ k' = s\[symmetric] \(r \ t)\<^sup>@ k = p\[symmetric]] + from pows_comm_comm[OF this] have "k = k'" - unfolding \(t \ r) \<^sup>@ Suc k = u\ \(r \ t) \<^sup>@ Suc k' = v\ using uv_code by blast + using \r \ t \ t \ r\ eqd_eq(1)[OF _ swap_len, of t r] by fastforce have "\<^bold>|p\<^bold>| = \<^bold>|s\<^bold>|" using lenarg[OF p] lenarg[OF s] unfolding \k = k'\ pow_len lenmorph add.commute[of "\<^bold>|r\<^bold>|"] by fastforce thus thesis - using that[OF x uv_y[folded u v \k = k'\] p s[folded \k = k'\] code] u v p s unfolding \k = k'\ by argo + using that[OF x uv_y[folded u v \k = k'\] p s[folded \k = k'\] code _ _ _ \0 < k\ \0 < m\] u v p s unfolding \k = k'\ by argo qed lemma ps_len: "\<^bold>|p\<^bold>| = \<^bold>|s\<^bold>|" and p_eq_v: "p = v" and s_eq_u: "s = u" - using bin_sq_interpret_extE by blast+ + using bin_sq_interp_extE by blast+ lemma v_x_x_u: "v \ x = x \ u" using vx_xs unfolding s_eq_u. lemma sp_y: "s \ p = y" - using p_eq_v s_eq_u uv_y by auto + using p_eq_v s_eq_u uv_y by auto lemma p_x_x_s: "p \ x = x \ s" by (simp add: px_xu s_eq_u) lemma xxy_root: "x \ x \ y = (x \ p) \ (x \ p)" using p_x_x_s sp_y by force -theorem sq_ext_interp: "ws = [x, y, x]" "s \ p = y" "p \ x = x \ s" +theorem sq_ext_interp: "ws = [x, y, x]" "s \ p = y" "p \ x = x \ s" using cover_xyx sp_y p_x_x_s. end -theorem bin_sq_interpE: - assumes "primitive x" and "primitive y" and "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" and "ws \ lists {x, y}" and "\ x \ y" and - "\ p1 p2. p1 \p [x, x] \ p2 \p ws \ p \ concat p1 \ concat p2" and "p x \ x s \\<^sub>\ ws" - obtains r t m k l where "(r \ t)\<^sup>@Suc m \ r = x" and "(t \ r)\<^sup>@Suc k \ (r \ t)\<^sup>@ Suc l = y" - "(r \ t)\<^sup>@Suc k = p" and "(t \ r)\<^sup>@ Suc l = s" and "r \ t \ t \ r" +theorem bin_sq_interpE: + assumes "x \ y \ y \ x" and "primitive x" and "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" and "ws \ lists {x, y}" and "\ x \ y" and + "p [x,x] s \\<^sub>\ ws" + obtains r t m k l where "(r \ t)\<^sup>@ m \ r = x" and "(t \ r)\<^sup>@ k \ (r \ t)\<^sup>@l = y" + "(r \ t)\<^sup>@ k = p" and "(t \ r)\<^sup>@ l = s" and "r \ t \ t \ r" and "0 < k" "0 < m" "0 < l" using square_interp.bin_sq_interpE[OF square_interp.intro, OF assms, of thesis]. -theorem bin_sq_interpret_extE: - assumes "primitive x" and "primitive y" and "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" and "ws \ lists {x, y}" and "\ x \ y" and - "\ p1 p2. p1 \p [x, x] \ p2 \p ws \ p \ concat p1 \ concat p2" and "p x \ x s \\<^sub>\ ws" and +theorem bin_sq_interp: + assumes "x \ y \ y \ x" and "primitive x" and "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" and "ws \ lists {x, y}" and "\ x \ y" and + "p [x,x] s \\<^sub>\ ws" + shows "ws = [x,y,x]" + using square_interp.cover_xyx[OF square_interp.intro, OF assms]. + +theorem bin_sq_interp_extE: + assumes "x \ y \ y \ x" and "primitive x" and "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" and "ws \ lists {x, y}" and "\ x \ y" and + "p [x,x] s \\<^sub>\ ws" and p_extend: "\ pe. pe \ \{x,y}\ \ p \s pe" and s_extend: "\ se. se \ \{x,y}\ \ s \p se" - obtains r t m k where "(r \ t)\<^sup>@Suc m \ r = x" and "(t \ r)\<^sup>@Suc k \ (r \ t)\<^sup>@ Suc k = y" - "(r \ t)\<^sup>@Suc k = p" and "(t \ r)\<^sup>@ Suc k = s" and "r \ t \ t \ r" - using square_interp_ext.bin_sq_interpret_extE[OF square_interp_ext.intro, OF square_interp.intro square_interp_ext_axioms.intro, OF assms, of thesis]. + obtains r t m k where "(r \ t)\<^sup>@ m \ r = x" and "(t \ r)\<^sup>@ k \ (r \ t)\<^sup>@ k = y" + "(r \ t)\<^sup>@ k = p" and "(t \ r)\<^sup>@ k = s" and "r \ t \ t \ r" and "0 < k" and "0 < m" + using square_interp_ext.bin_sq_interp_extE[OF square_interp_ext.intro, OF square_interp.intro square_interp_ext_axioms.intro, OF assms, of thesis]. -end \ No newline at end of file +end diff --git a/thys/Binary_Code_Imprimitive/ROOT b/thys/Binary_Code_Imprimitive/ROOT --- a/thys/Binary_Code_Imprimitive/ROOT +++ b/thys/Binary_Code_Imprimitive/ROOT @@ -1,12 +1,13 @@ chapter AFP session Binary_Code_Imprimitive = Combinatorics_Words + options [timeout = 600] sessions Combinatorics_Words_Graph_Lemma theories Binary_Square_Interpretation Binary_Code_Imprimitive + Binary_Imprimitive_Decision document_files root.tex root.bib 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,136 +1,157 @@ (* 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\In this section we give some specific auxiliary lemmas on natural numbers.\ lemma zero_diff_eq: "i \ j \ (0::nat) = j - i \ j = i" by simp -lemma zero_less_diff': "i < j \ j - i \ (0::nat)" +lemma zero_less_diff': "i < j \ j - i \ (0::nat)" by simp lemma nat_prod_le: "m \ (0 :: nat) \ m*n \ k \ n \ k" using le_trans[of n "m*n" k] by auto lemma get_div: "(p :: nat) < a \ m = (m * a + p) div a" by simp lemma get_mod: "(p :: nat) < a \ p = (m * a + p) mod a" by simp lemma plus_one_between: "(a :: nat) < b \ \ b < a + 1" by auto -lemma quotient_smaller: "k \ (0 :: nat) \ b \ k * b" +lemma quotient_smaller: "k \ (0 :: nat) \ b \ k * b" by simp -lemma mult_cancel_le: "b \ 0 \ a*b \ c*b \ a \ (c::nat)" +lemma mult_cancel_le: "b \ 0 \ a*b \ c*b \ a \ (c::nat)" by simp lemma add_lessD2: "k + m < (n::nat) \ m < n" unfolding add.commute[of k] using add_lessD1. lemma mod_offset: assumes "M \ (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 \ (0::nat)" shows "p \ p + q - gcd p q" using gcd_le2_nat[OF \q \ 0\, 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 \ (n :: nat)" and "q \ 0" shows "p \ n" - using le unfolding add_diff_assoc[OF gcd_le2_nat[OF \q \ 0\], symmetric] by (rule add_leD1) +lemmas gcd_le2_pos = gcd_le2_nat[folded zero_order(4)] and + gcd_le1_pos = gcd_le1_nat[folded zero_order(4)] -lemma predE: assumes "k \ 0" obtains pred where "k = Suc pred" - using assms not0_implies_Suc by auto +lemma ge1_pos_conv: "1 \ k \ 0 < (k::nat)" + by linarith + +lemma per_lemma_len_le: assumes le: "p + q - gcd p q \ (n :: nat)" and "0 < q" shows "p \ n" + using le unfolding add_diff_assoc[OF gcd_le2_pos[OF \0 < q\], symmetric] by (rule add_leD1) lemma Suc_less_iff_Suc_le: "Suc n < k \ Suc n \ k - 1" by auto lemma nat_induct_pair: "P 0 0 \ (\ m n. P m n \ P m (Suc n)) \ (\ m n. P m n \ P (Suc m) n) \ P m n" by (induction m arbitrary: n) (metis nat_induct, simp) lemma One_less_Two_le_iff: "1 < k \ 2 \ (k :: nat)" - by fastforce + by fastforce lemma at_least2_Suc: assumes "2 \ 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 \ 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 \ (l::nat)" and "3 \ k" shows "l + k + 1 \ l*k" -proof- - obtain l' where l: "l = Suc (Suc l')" - using \2 \ l\ at_least2_Suc[OF \2 \ l\] by blast - obtain k' where k: "k = Suc (Suc (Suc k'))" - using \3 \ k\ at_least3_Suc[OF \3 \ k\] by blast - show "l + k + 1 \ 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] +lemmas not0_SucE[elim] = not0_implies_Suc[THEN exE] lemma le1_SucE: assumes "1 \ n" - obtains k where "n = Suc k" using Suc_le_D[OF assms[unfolded One_nat_def]] by blast + obtains k where "n = Suc k" using Suc_le_D[OF assms[unfolded One_nat_def]] by blast lemma Suc_minus: "k \ 0 \ Suc (k - 1) = k" - by simp + by simp lemma Suc_minus': "1 \ k \ Suc(k - 1) = k" by simp -lemmas Suc_minus'' = Suc_diff_1 +lemmas Suc_minus_pos = Suc_diff_1 lemma Suc_minus2: "2 \ k \ Suc (Suc(k - 2)) = k" by auto -lemma almost_equal_equal: assumes "(a:: nat) \ 0" and "b \ 0" and eq: "k*(a+b) + a = m*(a+b) + b" - shows "k = m" and "a = b" -proof- +lemma Suc_leE: assumes "Suc k \ n" obtains m where "n = Suc m" and "k \ m" +using Suc_le_D assms by blast + +lemma two_three_add_le_mult: "2 \ (l::nat) \ 3 \ k \ k + l + 1 \ k*l" + unfolding numeral_nat + by (elim Suc_leE) simp + +lemma almost_equal_equal: assumes "(a:: nat) \ 0" and "b \ 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" + assume "k < m" from add_le_mono1[OF mult_le_mono1[OF Suc_leI[OF this]]] have "(Suc k)*(a + b) + b \ m*(a+b) + b". - hence False + hence False using \b \ 0\ unfolding mult_Suc eq[symmetric] by force thus ?thesis by blast next - assume "m < k" + assume "m < k" from add_le_mono1[OF mult_le_mono1[OF Suc_leI[OF this]]] have "(Suc m)*(a + b) + a \ k*(a+b) + a". - hence False + hence False using \a \ 0\ unfolding mult_Suc eq by force thus ?thesis by blast - qed (simp) + qed (simp) thus "a = b" using eq by auto qed +lemma crossproduct_le: assumes "(a::nat) \ b" and "c \ d" + shows "a*d + b*c \ a*c + b*d" +proof- + have "b * c \ b * d + a * c" + using assms by (simp add: trans_le_add1) + note mult_le_mono[OF assms] + have "a * (d - c) \ b * (d - c)" + using mult_le_mono1[OF \a \ b\]. + hence "a * d - a * c \ b * d - b * c" + using diff_mult_distrib2 by metis + hence "a * d \ b * d - b * c + a * c" + using le_diff_conv by blast + hence "a * d \ (b * d + a * c) - b * c" + by (simp add: \c \ d\) + hence "a * d + b * c \ (b * d + a * c) - b * c + b * c" + by simp + thus ?thesis + using \b * c \ b * d + a * c\ by force +qed -end \ No newline at end of file +lemma (in linorder) le_less_cases: "(a \ b \ P) \ (b < a \ P) \ P" + by (metis local.not_less) + +end diff --git a/thys/Combinatorics_Words/Binary_Code_Morphisms.thy b/thys/Combinatorics_Words/Binary_Code_Morphisms.thy --- a/thys/Combinatorics_Words/Binary_Code_Morphisms.thy +++ b/thys/Combinatorics_Words/Binary_Code_Morphisms.thy @@ -1,1354 +1,1894 @@ (* Title: Binary Code Morphisms - File: CoW.Binary_Code_Morphisms + File: Combinatorics_Words.Binary_Code_Morphisms Author: Štěpán Holub, Charles University + Martin Raška, 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 +theory Binary_Code_Morphisms + imports CoWBasic Submonoids Morphisms begin chapter "Binary alphabet and binary morphisms" section "Datatype of a binary alphabet" text\Basic elements for construction of binary words.\ type_notation Enum.finite_2 ("binA") -notation finite_2.a\<^sub>1 ("bin0") -notation finite_2.a\<^sub>2 ("bin1") +notation finite_2.a\<^sub>1 ("bina") +notation finite_2.a\<^sub>2 ("binb") 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_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" ("\") where - "bin_word_0 \ [bin0]" +abbreviation bin_word_a :: "binA list" ("\") where + "bin_word_a \ [bina]" -abbreviation bin_word_1 :: "binA list" ("\") where - "bin_word_1 \ [bin1]" +abbreviation bin_word_b :: "binA list" ("\") where + "bin_word_b \ [binb]" abbreviation binUNIV :: "binA set" where "binUNIV \ UNIV" -lemma bin_basis_code: "code {\,\}" +lemma binUNIV_I [simp, intro]: "bina \ A \ binb \ A \ A = UNIV" + unfolding UNIV_finite_2 by auto + +lemma bin_basis_code: "code {\,\}" by (rule bin_code_code) blast -lemma bin_num: "bin0 = 0" "bin1 = 1" +lemma bin_num: "bina = 0" "binb = 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" +lemma binA_simps [simp]: "bina - binb = binb" "binb - bina = binb" "1 - bina = binb" "1 - binb = bina" "a - a = bina" "1 - (1 - a) = a" by simp_all definition bin_swap :: "binA \ binA" where "bin_swap x \ 1 - x" -lemma bin_swap_if_then: "1-x = (if x = bin0 then bin1 else bin0)" +lemma bin_swap_if_then: "1-x = (if x = bina then binb else bina)" by fastforce definition bin_swap_morph where "bin_swap_morph \ map bin_swap" -lemma alphabet_or[simp]: "a = bin0 \ a = bin1" +lemma alphabet_or[simp]: "a = bina \ a = binb" by auto -lemma bin_im_or: "f [a] = f \ \ f [a] = f \" - by (rule bin_exhaust[of a], simp_all) +lemma bin_im_or: "f [a] = f \ \ f [a] = f \" + by (rule bin_exhaust[of a], simp_all) thm triv_forall_equality -lemma binUNIV_card: "card binUNIV = 2" +lemma binUNIV_card: "card binUNIV = 2" unfolding bin_UNIV card_2_iff by auto lemma other_letter: obtains b where "b \ (a :: binA)" using finite_2.distinct(1) by metis lemma alphabet_or_neq: "x \ y \ x = (a :: binA) \ y = a" using alphabet_or[of x] alphabet_or[of y] alphabet_or[of a] by argo lemma binA_neq_cases: assumes neq: "a \ b" - obtains "a = bin0" and "b = bin1" | "a = bin1" and "b = bin0" + obtains "a = bina" and "b = binb" | "a = binb" and "b = bina" using alphabet_or_neq assms by auto -lemma bin_neq_sym_pred: assumes "a \ b" and "P bin0 bin1" and "P bin1 bin0" shows "P a b" +lemma bin_neq_sym_pred: assumes "a \ b" and "P bina binb" and "P binb bina" shows "P a b" using assms(2-3) binA_neq_cases[OF \a \ b\, of "P a b"] by blast lemma no_third: "(c :: binA) \ a \ b \ a \ b = c" - using alphabet_or[of a] by fastforce + using alphabet_or[of a] by fastforce lemma two_in_bin_UNIV: assumes "a \ b" and "a \ S" and "b \ S" shows "S = binUNIV" using \a \ S\ \b \ S\ alphabet_or_neq[OF \a \ b\] by fast lemmas two_in_bin_set = two_in_bin_UNIV[unfolded bin_UNIV] lemma bin_not_comp_set_UNIV: assumes "\ u \ v" shows "set (u \ v) = binUNIV" proof- have uv: "u \ v = ((u \\<^sub>p v) \ ([hd ((u \\<^sub>p v)\\<^sup>>u)] \ tl ((u \\<^sub>p v)\\<^sup>>u))) \ (u \\<^sub>p v) \ ([hd ((u \\<^sub>p v)\\<^sup>>v)] \ tl ((u \\<^sub>p v)\\<^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 \\<^sub>p v)\\<^sup>>u) \ set (u \ v)" and "hd ((u \\<^sub>p v)\\<^sup>>v) \ set (u \ v)" unfolding uv by simp_all with lcp_mismatch_lq(3)[OF assms] show ?thesis - using two_in_bin_UNIV by blast + using two_in_bin_UNIV by blast qed -lemma bin_basis_singletons: "{[q] |q. q \ {bin0, bin1}} = {\,\}" +lemma bin_basis_singletons: "{[q] |q. q \ {bina, binb}} = {\,\}" by blast -lemma bin_basis_generates: "\{\,\}\ = UNIV" - using sings_gen_lists[of binUNIV, unfolded lists_UNIV bin_UNIV bin_basis_singletons, folded bin_UNIV, unfolded lists_UNIV]. +lemma bin_basis_generates: "\{\,\}\ = 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] \ {\,\}" +lemma a_in_bin_basis: "[a] \ {\,\}" using Set.UNIV_I by auto -lemma lcp_zero_one_emp: "\ \\<^sub>p \ = \" and lcp_one_zero_emp: "\ \\<^sub>p \ = \" +lemma lcp_zero_one_emp: "\ \\<^sub>p \ = \" and lcp_one_zero_emp: "\ \\<^sub>p \ = \" by simp+ -lemma neq_induct: "(a::binA) \ b \ P a \ P b \ P c" - by (elim binA_neq_cases) (hypsubst, rule finite_2.induct, assumption+)+ +lemma bin_neq_induct: "(a::binA) \ b \ P a \ P b \ P c" +proof (elim binA_neq_cases) + show " P a \ P b \ a = bina \ b = binb \ P c" + using finite_2.induct by blast + show " P a \ P b \ a = binb \ b = bina \ P c" + using finite_2.induct by blast +qed + +lemma bin_neq_induct': assumes"(a::binA) \ b" and "P a" and "P b" shows "\ c. P c" + using bin_neq_induct[OF assms] by blast lemma neq_exhaust: assumes "(a::binA) \ 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) \ a" +lemma bin_swap_neq [simp]: "1-(a :: binA) \ a" by simp lemmas bin_swap_neq'[simp] = bin_swap_neq[symmetric] -lemmas bin_swap_induct = neq_induct[OF bin_swap_neq'] +lemmas bin_swap_induct = bin_neq_induct[OF bin_swap_neq'] and bin_swap_exhaust = neq_exhaust[OF bin_swap_neq'] lemma bin_swap_induct': "P (a :: binA) \ P (1-a) \ (\ 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 \ d \ d = 1-(c :: binA)" - by (rule bin_swap_exhaust[of d c]) blast+ + using bin_swap_induct by auto -lemma neq_bin_swap': "c \ d \ c = 1-(d :: binA)" - using neq_bin_swap by presburger +lemma swap_UNIV: "{a, 1-a} = binUNIV" (is "?P a") + using bin_swap_induct[of ?P bina, unfolded binA_simps] by fastforce -lemma bin_neq_iff: "c \ d \ d = 1-(c :: binA)" - using neq_bin_swap[of c d] bin_swap_neq[of c] by argo +lemma bin_neq_swap'[intro]: "a \ b \ 1 - b = (a :: binA)" + by (rule bin_swap_exhaust[of a b]) blast+ -lemma bin_neq_iff': "c \ d \ c = 1-(d :: binA)" +lemma bin_neq_swap[intro]: "a \ b \ 1 - a = (b :: binA)" + using bin_neq_swap' by auto + +lemma bin_neq_swap''[intro]: "a \ b \ b = 1-(a:: binA)" + using bin_neq_swap by blast + +lemma bin_neq_swap'''[intro]: "a \ b \ a = 1-(b:: binA)" + using bin_neq_swap by blast + +lemma bin_neq_iff: "c \ d \ 1 - d = (c :: binA)" + using bin_neq_swap[of d c] bin_swap_neq[of d] by argo + +lemma bin_neq_iff': "c \ d \ 1 - c = (d :: binA)" unfolding bin_neq_iff by force -lemma bin_neq_swap': "a \ b \ b = 1-(a:: binA)" - by (simp add: bin_neq_iff') - lemma binA_neq_cases_swap: assumes neq: "a \ (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 + using assms bin_neq_swap bin_swap_exhaust[of a c] by metis + +lemma im_swap_neq: "f a = f b \ f bina \ f binb \ a = b" + using binA_neq_cases_swap[of a b bina False, unfolded binA_simps] by fastforce lemma bin_without_letter: assumes "(a1 :: binA) \ set w" obtains k where "w = [1-a1]\<^sup>@k" proof- have "\ c. c \ set w \ c = 1-a1" - using assms bin_swap_exhaust by blast + 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 \ b \ a = 1-(b:: binA)" - by (simp add: bin_neq_iff') - lemma bin_empty_iff: "S = {} \ (a :: binA) \ S \ 1-a \ S" using bin_swap_induct[of "\a. a \ S"] by blast lemma bin_UNIV_iff: "S = binUNIV \ a \ S \ 1-a \ S" using two_in_bin_UNIV[OF bin_swap_neq'] by blast lemma bin_UNIV_I: "a \ S \ 1-a \ S \ 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} \ a \ A \ 1-a \ A" proof (rule sym, intro iffI conjI, elim conjE) assume "a \ A" and "1-a \ A" - have "b \ A \ b = a" for b + have "b \ A \ b = a" for b using \a \ A\ \1-a \ A\ bin_swap_neq by (intro bin_swap_induct[of "\c. (c \ 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 +lemma bin_set_cases: obtains "S = {}" | "S = {bina}" | "S = {binb}" | "S = binUNIV" + unfolding bin_empty_iff[of _ "bina"] bin_UNIV_iff[of _ "bina"] bin_sing_iff by fastforce lemma not_UNIV_E: assumes "A \ binUNIV" obtains a where "A \ {a}" using assms by (cases rule: bin_set_cases[of A]) auto lemma not_UNIV_nempE: assumes "A \ binUNIV" and "A \ {}" obtains a where "A = {a}" using assms by (cases rule: bin_set_cases[of A]) auto lemma bin_sing_gen_iff: "x \ \{[a]}\ \ 1-(a :: binA) \ set x" - unfolding sing_gen_lists[symmetric] in_lists_conv_set using bin_empty_iff bin_sing_iff by metis + unfolding sing_gen_lists[symmetric] in_lists_conv_set using bin_empty_iff bin_sing_iff by metis lemma set_hd_pow_conv: "w \ [hd w]* \ set w \ binUNIV" - unfolding root_sing_set_iff + unfolding root_sing_set_iff proof assume "set w \ {hd w}" - thus "set w \ binUNIV" + thus "set w \ binUNIV" unfolding bin_UNIV using bin_distinct(1) by force -next +next assume "set w \ binUNIV" thus "set w \ {hd w}" - proof (cases "w = \", simp) + proof (cases "w = \") assume "set w \ binUNIV" and "w \ \" from hd_tl[OF this(2)] this(2) have "hd w \ set w" by simp - hence "1-hd w \ set w" - using \set w \ binUNIV\ unfolding swap_UNIV[symmetric, of "hd w"] by fast + hence "1-hd w \ set w" + using \set w \ binUNIV\ unfolding bin_UNIV_iff[of "set w" "hd w"] by blast thus "set w \ {hd w}" using bin_sing_iff by auto - qed + qed simp qed lemma not_swap_eq: "P a b \ (\ (c :: binA). \ P c (1-c)) \ a = b" - using bin_neq_iff by metis + using bin_neq_iff by metis -lemma bin_distinct_letter: assumes "set w = binUNIV" +lemma bin_distinct_letter: assumes "set w = binUNIV" obtains k w' where "[hd w]\<^sup>@Suc k \ [1-hd w] \ 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 \ [b] \ q = w" "b \ hd w". - from that[OF this(1)[unfolded bin_neq_swap[of _ "hd w", OF this(2)]]] - show thesis. + with that bin_neq_swap'[OF this(2)] + show thesis + by blast qed lemma "P a \ P (1-a) \ P a \ (\ (b :: binA). P b)" using bin_swap_induct' by blast lemma bin_sym_all: "P (a :: binA) \ P (1-a) \ P a \ P x" - using bin_swap_induct[of "\ a. P a" a, unfolded binsimp] by blast + using bin_swap_induct[of "\ a. P a" a, unfolded binA_simps] by blast lemma bin_sym_all_comm: "f [a] \ f [1-a] \ f [1-a] \ f [a] \ f [b] \ f [1-b] \ f [1-b] \ f [(b :: binA)]" (is "?P a \ ?P b") - using bin_sym_all[of ?P a, unfolded binsimp, OF neq_commute]. + using bin_sym_all[of ?P a, unfolded binA_simps, OF neq_commute]. lemma bin_sym_all_neq: "f [(a :: binA)] \ f [1-a] \ f [b] \ f [1-b]" (is "?P a \ ?P b") - using bin_sym_all[of ?P a, unfolded binsimp, OF neq_commute]. - -section \Binary code morphism\ - -subsection \From a binary code to a binary morphism\ - -definition bin_morph_of' :: "'a list \ 'a list \ binA list \ 'a list" where "bin_morph_of' x y u = concat (map (\ a. (case a of bin0 \ x | bin1 \ y)) u)" - -definition bin_morph_of :: "'a list \ 'a list \ binA list \ 'a list" where "bin_morph_of x y u = concat (map (\ a. if a = bin0 then x else y) u)" - -lemma case_finite_2_if_else: "case_finite_2 x y = (\ 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 (\ a. (case a of bin0 \ x | bin1 \ y)) u)" - unfolding bin_morph_of_def case_finite_2_if_else.. + using bin_sym_all[of ?P a, unfolded binA_simps, OF neq_commute]. -lemma case_finiteD: "case_finite_2 (f \) (f \) = f\<^sup>\" -proof - show "(case x of bin0 \ f \ | bin1 \ f \) = f\<^sup>\ x" for x - unfolding core_def by (cases rule: finite_2.exhaust[of x]) auto -qed - -lemma case_finiteD': "case_finite_2 (f \) (f \) u = f\<^sup>\ u" - using case_finiteD by metis +lemma bin_len_count: + fixes w :: "binA list" + shows "\<^bold>|w\<^bold>| = count_list w a + count_list w (1-a)" + using sum_count_set[of w "{a,1-a}"] swap_UNIV by force -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_len_count': + fixes w :: "binA list" + shows "\<^bold>|w\<^bold>| = count_list w bina + count_list w binb" + using bin_len_count[of w bina] by force -lemma bin_morph_of_morph: "morphism (bin_morph_of x y)" - unfolding bin_morph_of_def by (simp add: morphism.intro) +section \Binary morphisms\ -lemma bin_morph_ofD: "(bin_morph_of x y) \ = x" "(bin_morph_of x y) \ = y" - unfolding bin_morph_of_def by simp_all +lemma bin_map_core_lists: "(map f\<^sup>\ w) \ lists {f \, f \}" + unfolding core_def by (induct w, simp, unfold map_hd) + (rule append_in_lists, simp_all add: bin_im_or) -lemma bin_range: "range f = {f bin0, f bin1}" +lemma bin_range: "range f = {f bina, f binb}" 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>\ = {f \, f \}" +lemma bin_core_range: "range f\<^sup>\ = {f \, f \}" unfolding core_def bin_range.. lemma bin_core_range_swap: "range f\<^sup>\ = {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>\ w) \ lists {f \, f \}" - unfolding core_def by (induct w, simp, unfold map_hd) - (rule append_in_lists, simp_all add: bin_im_or) + by (rule bin_induct[of ?P, unfolded binA_simps], unfold bin_core_range, simp, force) lemma bin_map_core_lists_swap: "(map f\<^sup>\ w) \ lists {f [(a :: binA)], f [1-a]}" - using map_core_lists[of f, unfolded bin_core_range_swap[of f 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>\ = {x,y}" - unfolding bin_core_range bin_morph_ofD.. +locale binary_morphism = morphism f + for f :: "binA list \ 'a list" +begin -lemma bin_morph_of_range: "range (bin_morph_of x y) = \{x,y}\" - using morphism.range_hull[of "bin_morph_of x y", unfolded bin_morph_of_core_range, OF bin_morph_of_morph]. +lemma bin_len_count_im: + fixes a :: binA + shows "\<^bold>|f w\<^bold>| = count_list w a * \<^bold>|f [a]\<^bold>| + count_list w (1-a) * \<^bold>|f [1-a]\<^bold>|" +proof (induct w) + case (Cons b w) + show ?case + unfolding hd_word[of b w] morph lenmorph Cons.hyps count_list_append + by (induct a) simp_all +qed simp -lemma bin_neq_inj_core: assumes "f [(a :: binA)] \ f [1-a]" shows "inj f\<^sup>\" +lemma bin_len_count_im': + shows "\<^bold>|f w\<^bold>| = count_list w bina * \<^bold>|f \\<^bold>| + count_list w binb * \<^bold>|f \\<^bold>|" + proof (induct w) + case (Cons a w) + show ?case + unfolding hd_word[of a w] morph lenmorph Cons.hyps count_list_append + by (induct a) simp_all + qed simp + + +lemma bin_neq_inj_core: assumes "f [a] \ f [1-a]" shows "inj f\<^sup>\" proof show "f\<^sup>\ x = f\<^sup>\ y \ x = y" for x y proof (rule ccontr) assume "x \ y" - from bin_sym_all_neq[OF assms] + from bin_sym_all_neq[OF assms] have "f\<^sup>\ x \ f\<^sup>\ y" - unfolding core_def bin_neq_swap'[OF \x \ y\]. + unfolding core_def bin_neq_swap''[OF \x \ y\]. thus "f\<^sup>\ x = f\<^sup>\ y \ False" by blast qed qed -lemma bin_code_morphismI: "morphism f \ f [a] \ f [1-a] \ f [1-a] \ f [(a :: binA)] \ code_morphism f" -proof (standard, simp add: morphism.morph) - assume "morphism f" and "f [a] \ f [1-a] \ f [1-a] \ f [(a :: binA)]" - from bin_sym_all_comm[OF this(2)] - have "f [b] \ f [1-b] \ f [1-b] \ f [b]" for b. - hence "inj f\<^sup>\" - 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>\ xs) = concat (map f\<^sup>\ ys)" - by (simp add: morphism.morph_concat_map[OF \morphism f\]) - from bin_code_code[unfolded code_def, rule_format, - OF \f [a] \ f [1-a] \ f [1-a] \ f [a]\ bin_map_core_lists_swap bin_map_core_lists_swap this] - show "xs = ys" - using \inj f\<^sup>\\ by simp - qed +lemma bin_code_morphism_inj: assumes "f [a] \ f [1-a] \ f [1-a] \ f [a]" + shows "inj f" + unfolding inj_on_def +proof (rule ballI, rule ballI, rule impI) + have "f [b] \ f [1-b]" for b + using bin_sym_all_comm[OF assms, of b] by force + from bin_neq_inj_core[OF this] + have "inj f\<^sup>\". + fix xs ys assume "f xs = f ys" + hence "concat (map f\<^sup>\ xs) = concat (map f\<^sup>\ ys)" + unfolding morph_concat_map. + from bin_code_code[unfolded code_def, rule_format, + OF \f [a] \ f [1-a] \ f [1-a] \ f [a]\ bin_map_core_lists_swap bin_map_core_lists_swap this] + show "xs = ys" + using \inj f\<^sup>\\ by simp qed -subsection \Locale - binary code morphism\ +lemma bin_code_morphismI: "f [a] \ f [1-a] \ f [1-a] \ f [a] \ code_morphism f" + using code_morphismI[OF bin_code_morphism_inj]. -locale binary_code_morphism = code_morphism "f :: binA list \ 'a list" for f +end + +subsection \Binary periodic morphisms\ + +locale binary_periodic_morphism = periodic_morphism f + for f :: "binA list \ 'a list" +begin + +sublocale binary_morphism + by unfold_locales + +definition fn0 where "fn0 \ (SOME n. f \ = mroot\<^sup>@n)" +definition fn1 where "fn1 \ (SOME n. f \ = mroot\<^sup>@n)" + +lemma bin0_im: "f \ = mroot\<^sup>@fn0" + using per_morph_rootI[rule_format, of \] someI[of "\ n. f \ = mroot\<^sup>@n"] unfolding fn0_def by blast + +lemma bin1_im: "f \ = mroot\<^sup>@fn1" + using per_morph_rootI[rule_format, of \] someI[of "\ n. f \ = mroot\<^sup>@n"] unfolding fn1_def by blast + +lemma sorted_image : "f w = (f [a])\<^sup>@(count_list w a) \ (f [1-a])\<^sup>@(count_list w (1-a))" +proof- + obtain k where "f w = mroot\<^sup>@k" + using per_morph_rootI by blast + have len: "\<^bold>|f w\<^bold>| = \<^bold>|(f [a])\<^sup>@(count_list w a) \ (f [1-a])\<^sup>@(count_list w (1-a))\<^bold>|" + using bin_len_count_im unfolding lenmorph pow_len. + have *: "(f [a])\<^sup>@(count_list w a) \ (f [1-a])\<^sup>@(count_list w (1-a)) = mroot\<^sup>@(fn0 * (count_list w bina) + fn1 * (count_list w binb))" + by (induct a) (unfold binA_simps bin0_im bin1_im, unfold pow_mult[symmetric] add_exps[symmetric], simp_all add: add.commute) + show ?thesis + using len nemp_len[OF prim_nemp[OF per_morph_root_prim]] + unfolding * \f w = mroot\<^sup>@k\ pow_len by force +qed + +lemma bin_per_morph_expI: "f u = mroot\<^sup>@((mexp bina) * (count_list u bina) + (mexp binb) * (count_list u binb))" + using sorted_image[of u bina, unfolded binA_simps] + by (simp add: add_exps per_morph_expI' pow_mult) + +end + + +section \From two words to a binary morphism\ + +definition bin_morph_of' :: "'a list \ 'a list \ binA list \ 'a list" where "bin_morph_of' x y u = concat (map (\ a. (case a of bina \ x | binb \ y)) u)" + +definition bin_morph_of :: "'a list \ 'a list \ binA list \ 'a list" where "bin_morph_of x y u = concat (map (\ a. if a = bina then x else y) u)" + +lemma case_finite_2_if_else: "case_finite_2 x y = (\ a. if a = bina 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 (\ a. (case a of bina \ x | binb \ y)) u)" + unfolding bin_morph_of_def case_finite_2_if_else.. + +lemma case_finiteD: "case_finite_2 (f \) (f \) = f\<^sup>\" +proof + show "(case x of bina \ f \ | binb \ f \) = f\<^sup>\ x" for x + unfolding core_def by (cases rule: finite_2.exhaust[of x]) auto +qed + +lemma case_finiteD': "case_finite_2 (f \) (f \) u = f\<^sup>\ 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_ofD: "(bin_morph_of x y) \ = x" "(bin_morph_of x y) \ = y" + unfolding bin_morph_of_def by simp_all + +lemma bin_range_swap: "range f = {f (a::binA), f (1-a)}" (is "?P a") + using bin_swap_induct[of ?P bina] unfolding binA_simps bin_UNIV by auto + +lemma bin_morph_of_core_range: "range (bin_morph_of x y)\<^sup>\ = {x,y}" + unfolding bin_core_range bin_morph_ofD.. + +lemma bin_morph_of_morph: "morphism (bin_morph_of x y)" + unfolding bin_morph_of_def by (simp add: morphism.intro) + +lemma bin_morph_of_bin_morph: "binary_morphism (bin_morph_of x y)" + unfolding binary_morphism_def using bin_morph_of_morph. + +lemma bin_morph_of_range: "range (bin_morph_of x y) = \{x,y}\" + using morphism.range_hull[of "bin_morph_of x y", unfolded bin_morph_of_core_range, OF bin_morph_of_morph]. + +context binary_code +begin + +lemma code_morph_of: "code_morphism (bin_morph_of u\<^sub>0 u\<^sub>1)" + using binary_morphism.bin_code_morphismI[OF bin_morph_of_bin_morph, of u\<^sub>0 u\<^sub>1 bina] + unfolding binA_simps bin_morph_ofD using non_comm. + +lemma inj_morph_of: "inj (bin_morph_of u\<^sub>0 u\<^sub>1)" + using code_morphism.code_morph[OF code_morph_of]. + +end + +section \Two binary morphism\ + +locale two_binary_morphisms = two_morphisms g h + for g h :: "binA list \ 'a list" begin -lemma morph_bin_morph_of: "f = bin_morph_of (f \) (f \)" - 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] \ f [1-a] \ f [1-a] \ f [a]" - unfolding morph[symmetric] using code_morph_code bin_swap_neq by blast - -lemma non_comp_morph: "\ f [a] \ f [1-a] \ f [1-a] \ f [a]" - using comm_comp_eq non_comm_morph by blast - -lemma swap_non_comm_morph [simp, intro]: "a \ b \ f [a] \ f [b] \ f [b] \ 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 \" "f \" - using non_comm_morph[of bin1] unfolding binsimp by unfold_locales - -sublocale binary_code "f \" "f \" - using swap.bin_code_swap. - -notation bin_code_lcp ("\") and - bin_code_lcs ("\") and - bin_code_mismatch_fst ("c\<^sub>0") and - bin_code_mismatch_snd ("c\<^sub>1") -term "bin_lcp (f \) (f \)" -abbreviation bin_morph_mismatch ("\") - where "bin_morph_mismatch a \ bin_mismatch (f[a]) (f[1-a])" -abbreviation bin_morph_mismatch_suf ("\

") - where "bin_morph_mismatch_suf a \ bin_mismatch_suf (f[1-a]) (f[a])" - -lemma bin_lcp_def': "\ = f ([a] \ [1-a]) \\<^sub>p f ([1-a] \ [a])" - by (rule bin_exhaust[of a "\ = f ([a] \ [1-a]) \\<^sub>p f ([1-a] \ [a])"], - unfold morph, use binsimp(3-4) bin_lcp_def in force) - (unfold bin_lcp_def lcp_sym[of "f[a] \ f[1-a]" "f[1-a] \ f[a]"], - use binsimp(3-4) in auto) - -lemma bin_lcp_neq: "a \ b \ \ = f ([a] \ [b]) \\<^sub>p f ([b] \ [a])" - using neq_bin_swap[of a b] unfolding bin_lcp_def'[of a] by blast - -lemma sing_im: "f [a] \ {f \, f \}" - using finite_2.exhaust[of a ?thesis] by fastforce - -lemma bin_mismatch_inj: "inj \" - unfolding inj_on_def - using non_comm_morph[folded bin_mismatch_comm] neq_bin_swap by force - -lemma map_in_lists: "map (\x. f [x]) w \ lists {f \, f \}" -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>|\\<^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: "\ f([a] \ [1-a]) \p \" - using pref_len[of "f [a] \ f [1-a]" \] unfolding morph lenmorph using bin_morph_lcp_short[of a] by force - -thm local.bin_mismatch_inj - -lemma bin_mismatch_suf_inj: "inj \
" - 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]) = \" - 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]) = \" - 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: "\ a \ \ (1-a)" - using bin_code_morph_sing binary_code.bin_mismatch_neq by auto - -lemma long_bin_lcp_hd: assumes "\<^bold>|f w\<^bold>| \ \<^bold>|\\<^bold>|" - shows "w \ [hd w]*" -proof (rule ccontr) - assume "\ w \ [hd w]*" - from distinct_letter_in_hd[OF this] - obtain m b suf where w: "[hd w]\<^sup>@m \ [b]\ suf = w" and "b \ hd w" and "m \ 0". - have ineq: "\<^bold>|f [b]\<^bold>| + \<^bold>|f [hd w]\<^bold>| \ \<^bold>|f w\<^bold>|" - using quotient_smaller[OF \m \ 0\, of "\<^bold>|f [hd w]\<^bold>|"] - unfolding arg_cong[OF w, of "\ x. \<^bold>|f(x)\<^bold>|", unfolded morph lenmorph pow_morph pow_len, symmetric] - by linarith - hence "\<^bold>|f \\<^bold>| + \<^bold>|f \\<^bold>| \ \<^bold>|f w\<^bold>|" - using \b \ hd w\ alphabet_or[of b] alphabet_or[of "hd w"] add.commute by fastforce - thus False - using bin_lcp_short \\<^bold>|f w\<^bold>| \ \<^bold>|\\<^bold>|\ 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: - "\ \ [\ a] \p f [a] \ \" - using binary_code.bin_fst_mismatch[OF bin_code_morph_sing] unfolding bin_lcp_sing. - -lemma "[\
a] \ \ \s \ \ f [a]" using binary_code_morphism.bin_morph_lcp_mismatch_pref[OF bin_code_morph_rev_map, reversed]. - -lemma bin_lcp_pref_all: "\ \p f w \ \" -proof(induct w rule: rev_induct, simp) - case (snoc x xs) - from pref_prolong[OF this, of "f[x]\\", 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 \ \" and "\<^bold>|f w\<^bold>| \ \<^bold>|\\<^bold>|" - shows "w \ [hd w]*" -proof(rule ccontr) - assume "w \ [hd w]*" - obtain m b q where "[hd w]\<^sup>@m \ [b] \ q = w" and "b \ hd w" and "m \ 0" - using distinct_letter_in_hd[OF \w \ [hd w]*\]. - have ineq: "\<^bold>|f ([hd w]\<^sup>@m \ [b])\<^bold>| \ \<^bold>|f w\<^bold>|" - using arg_cong[OF \[hd w] \<^sup>@ m \ [b] \ q = w\, of "\ 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 \ [b])\<^bold>|" - by (simp add: morph pow_len pow_morph) - have "\<^bold>|f [hd w]\<^bold>| + \<^bold>|f [b]\<^bold>| \ m*\<^bold>|f [hd w]\<^bold>| + \<^bold>|f [b]\<^bold>|" - using ineq \m \ 0\ by simp - hence "\<^bold>|f [hd w]\<^bold>| + \<^bold>|f [b]\<^bold>| \ \<^bold>|f w\<^bold>|" - using eq ineq by linarith - hence "\<^bold>|f \\<^bold>| + \<^bold>|f \\<^bold>| \ \<^bold>|f w\<^bold>|" - using binA_neq_cases [OF \b \ hd w\] by fastforce - thus False - using bin_lcp_short \\<^bold>|f w\<^bold>| \ \<^bold>|\\<^bold>|\ by linarith -qed - -thm sing_to_nemp - nonerasing - -lemma bin_mismatch_code_morph: "c\<^sub>0 = \ 0" "c\<^sub>1 = \ 1" - unfolding bin_mismatch_def bin_lcp_def by simp_all - -lemma bin_lcp_mismatch_pref_all: "\ \ [\ a] \p f [a] \ f w \ \" - 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: "\ \ [c\<^sub>0] \p f \ \ f w \ \" - using pref_prolong[OF bin_fst_mismatch bin_lcp_pref_all[of w]]. - -lemma bin_snd_mismatch_all: "\ \ [c\<^sub>1] \p f \ \ f w \ \" - using pref_prolong[OF bin_snd_mismatch bin_lcp_pref_all[of w]] by simp - -lemma bin_long_mismatch: assumes "\<^bold>|\\<^bold>| < \<^bold>|f w\<^bold>|" shows "\ \ [\ (hd w)] \p f w" -proof- - have "w \ \" - using assms emp_to_emp emp_len by force - have "f w = f[hd w] \ f (tl w)" - unfolding pop_hd[symmetric] unfolding hd_word[of "hd w" "tl w"] - hd_tl[OF \w \ \\].. - have "\ \ [\ (hd w)] \p f w \ \" - using bin_lcp_mismatch_pref_all[of "hd w" "tl w"] - unfolding lassoc \f w = f[hd w] \ f (tl w)\[symmetric]. - moreover have "\<^bold>|\ \ [\ (hd w)]\<^bold>| \ \<^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 "\ a = b" -proof- - \ \auxiliary\ - have aritm: "Suc n * Suc \<^bold>|\\<^bold>| = Suc (n*\<^bold>|\\<^bold>| + n + \<^bold>|\\<^bold>|)" - by auto - have set: "set ([b] \<^sup>@ (Suc n * Suc \<^bold>|\\<^bold>|)) = {b}" - unfolding aritm using sing_pow_set_Suc. - have elem: "\ a \ set (\ \ [\ a])" - by simp - have hd: "hd ([a] \<^sup>@ Suc \<^bold>|\\<^bold>|) = a" - by fastforce - \ \proof\ - let ?w = "[a]\<^sup>@Suc \<^bold>|\\<^bold>|" - have fw: "f ?w = [b]\<^sup>@(Suc n*Suc \<^bold>|\\<^bold>|)" - unfolding power_mult assms[symmetric] pow_morph.. - have "\<^bold>|\\<^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 "\ a = b" - unfolding hd set using elem by blast -qed - -lemma sing_pow_mismatch_suf: "f [a] = [b]\<^sup>@Suc n \ \
a = b" - using binary_code_morphism.sing_pow_mismatch[OF bin_code_morph_rev_map, reversed]. - -lemma bin_mismatch_swap_all: "f [a] \ f w \ \ \\<^sub>p f [1-a] \ f w' \ \ = \" - using lcp_first_mismatch[OF bin_mismatch_swap_neq, of \ 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 \ \ f w \ \ \\<^sub>p f \ \ f w' \ \ = \" - using bin_mismatch_swap_all[of bin0, unfolded binsimp]. - -lemma bin_mismatch_swap_not_comp: "\ f [a] \ f w \ \ \ f [1-a] \ f w' \ \" - 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: "\ \p (f [a])\<^sup>\" - using alphabet_or[of a] per_rootI[OF bin_lcp_pref_all[of \] bin_snd_nemp] per_rootI[OF bin_lcp_pref_all[of \] bin_fst_nemp] by blast - -lemma bin_lcp_pref: assumes "w \ \*" and "w \ \*" - shows "\ \p (f w)" -proof- - have "w \ \" - using \\ (w \ \*)\ emp_all_roots by blast - have "w \ [hd w]*" - using assms alphabet_or[of "hd w"] by presburger - hence "\<^bold>|\\<^bold>| \ \<^bold>|f w\<^bold>|" - using long_bin_lcp[OF \w \ \\] nat_le_linear[of "\<^bold>|f w\<^bold>|" "\<^bold>|\\<^bold>|" ] by blast - show ?thesis - using pref_prod_le[OF bin_lcp_pref_all \\<^bold>|\\<^bold>| \ \<^bold>|f w\<^bold>|\]. -qed - -lemma bin_mismatch_sings: "a \ b \ f [a] \ \ \\<^sub>p f [b] \ \ = \" - using bin_mismatch bin_mismatch[unfolded lcp_sym[of "f \ \ \" "f \ \ \"]] - by (elim bin_neq_sym_pred) - -lemma bin_lcp_pref'': "[a] \f w \ [1-a] \f w \ \ \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': "\ \f w \ \ \f w \ \ \p (f w)" - using bin_lcp_pref''[of bin0, unfolded binsimp]. - -lemma bin_lcp_mismatch_pref_all_set: assumes "1-a \ set w" - shows "\ \ [\ a] \p f [a] \ f w" -proof- - have "\<^bold>|f[1-a]\<^bold>| \ \<^bold>|f w\<^bold>|" - using fac_len' morph split_list'[OF assms] by metis - hence "\<^bold>|\ \ [\ a]\<^bold>| \ \<^bold>|f [a] \ 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: "\ \ f (\ \ w0) \\<^sub>p f (\ \ w1)" - using ruler[OF bin_lcp_pref_all[of "\ \ w0"] - pref_trans[OF lcp_pref[of "f (\ \ w0)" "f (\ \ w1)"], of "f (\ \ w0) \ \", OF triv_pref]] - unfolding prefix_comparable_def. - -lemma sing_mismatch: assumes "f \ \ [a]*" shows "c\<^sub>0 = a" -proof- - have "\ \ [a]*" - using per_one[OF per_root_trans[OF bin_lcp_root assms]]. - hence "f \ \ \ \ [a]*" - using \f \ \ [a]*\ 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 \ \ [a]*" shows "c\<^sub>1 = a" -proof- - have "\ \ [a]*" - using per_one[OF per_root_trans[OF bin_lcp_root assms]]. - hence "f \ \ \ \ [a]*" - using \f \ \ [a]*\ 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: "\ \ (f w)" - unfolding prefix_comparable_def using ruler[OF bin_lcp_pref_all triv_pref]. - -lemma not_comp_bin_swap: "\ f [a] \ \ \ f [1-a] \ \" - by (rule bin_exhaust[of a ?thesis], use not_comp_bin_fst_snd in simp_all) - -lemma mismatch_pref: - assumes "\ \p f ([a] \ w0)" and "\ \p f ([1-a] \ w1)" - shows "\ = f ([a] \ w0) \\<^sub>p f ([1-a] \ w1)" -proof- - have "f ([a] \ w0) \ \ \\<^sub>p f ([1-a] \ w1) \ \ = \" - unfolding morph using bin_mismatch_swap_all[unfolded lassoc]. - hence "f ([a] \ w0) \\<^sub>p f ([1-a] \ w1) \p \" - using lcp_pref_monotone[OF triv_pref[of "f ([a] \ w0)" \] triv_pref[of "f ([1-a] \ w1)" \]] - by presburger - moreover have "\ \p f ([a] \ w0) \\<^sub>p f ([1-a] \ 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>| \ \<^bold>|f w\<^bold>|" -proof- - have "w \ \" - using \set w = UNIV\ 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) \ 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>| \ \<^bold>|f (tl w)\<^bold>|". - with lenarg[OF arg_cong[of _ _ f, OF hd_tl[OF \w \ \\]]] - have "\<^bold>|f [hd w]\<^bold>| + \<^bold>|f [1-hd w]\<^bold>| \ \<^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 "\ \ [\ (hd w)] \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 \ \ = \" -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 \ \ f \) \ hd (f \ \ f \)" - using hd_append finite_2.distinct by auto - thus "\ = \" - unfolding bin_lcp_def using lcp_distinct_hd by blast -next - assume "\ = \" - have "hd (f \) \ hd (f \)" - by (rule nemp_lcp_distinct_hd[OF sing_to_nemp sing_to_nemp]) - (use lcp_append_monotone[of "f \" "f \" "f \" "f \", unfolded \\ = \\[unfolded bin_lcp_def]] - in simp) - show "marked_morphism f" - proof - fix a b :: binA assume "hd (f\<^sup>\ a) = hd (f\<^sup>\ b)" - thus "a = b" - unfolding core_def using \hd (f \) \ hd (f \)\ - 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 \ \ = \ \ f w \ (\ a. a \ set w \ f [a] \ \ = \ \ f [a])" -proof (induct w, simp) - case (Cons a w) - then show ?case - proof (cases "w = \") - assume "w = \" - show ?thesis - using Cons.prems(1) unfolding \w = \\ by force - next - assume "w \ \" - have eq: "f [a] \ f w \ \ = \ \ f [a] \ f w" - unfolding morph[symmetric] - unfolding lassoc morph[symmetric] hd_tl[OF \w \ \\] - using \f (a # w) \ \ = \ \ f (a # w)\ by force - have "f [a] \ \ \p f [a] \ f w \ \" - unfolding pref_cancel_conv using bin_lcp_pref_all. - hence "f [a] \ \ = \ \ f [a]" - using eqd_eq[of "\ \ f [a]", OF _swap_len] unfolding pref_def eq rassoc by metis - from eq[unfolded lassoc, folded this, unfolded rassoc cancel] - have "f w \ \ = \ \ f w". - from Cons.hyps[OF this] \f [a] \ \ = \ \ f [a]\ - show ?thesis by fastforce - qed -qed +lemma eq_on_letters_eq: "g \ = h \ \ g \ = h \ \ g = h" + by (rule def_on_sings_eq, rule bin_induct) blast+ -lemma im_comm_lcp_nemp: assumes "f w \ \ = \ \ f w" and "w \ \" and "\ \ \" - obtains k where "w = [hd w]\<^sup>@Suc k" -proof- - have "set w = {hd w}" - proof- - have "hd w \ set w" using \w \ \\ by force - have "a = hd w" if "a \ set w" for a - proof- - have "f [a] \ \ = \ \ f [a]" and "f [hd w] \ \ = \ \ f [hd w]" - using that im_comm_lcp[OF \f w \ \ = \ \ f w\] \hd w \ set w\ by presburger+ - from comm_trans[OF this \\ \ \\] - show "a = hd w" - using swap_non_comm_morph by blast - qed - thus "set w = {hd w}" - using \hd w \ set w\ by blast - qed - from unique_letter_wordE[OF this] - show thesis - using that by blast -qed - -end - -subsection \More translations\ - -lemma bin_code_code_morph: "binary_code x y \ 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 \ morphism f \ f [a] \ f [1-a] \ f [1-a] \ f [a]" -proof - assume "binary_code_morphism f" - hence "morphism f" - by (simp add: binary_code_morphism_def code_morphism_def) - have "f [a] \ f [1-a] \ f [1-a] \ f [a]" - using \binary_code_morphism f\ binary_code_morphism.non_comm_morph by auto - thus "morphism f \ f [a] \ f [1-a] \ f [1-a] \ f [a]" - using \morphism f\ by blast -next - assume "morphism f \ f [a] \ f [1-a] \ f [1-a] \ f [a]" - hence "morphism f" and "f [a] \ f [1-a] \ f [1-a] \ f [a]" by force+ - interpret morphism f - using \morphism f\. - interpret binary_code "f [a]" "f [1-a]" - using binary_code.intro[OF \f [a] \ f [1-a] \ f [1-a] \ f [a]\]. - show "binary_code_morphism f" - using \morphism f \ f [a] \ f [1 - a] \ f [1 - a] \ f [a]\ bin_code_morphismI binary_code_morphism.intro by blast - qed - -lemma bin_code_morph_iff: "binary_code_morphism (bin_morph_of x y) \ x \ y \ y \ 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) \ x \ \ \ y \ \" -proof - show "x \ \ \ y \ \ \ 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) \ x \ \ \ y \ \" - 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 \ bin_morph_of (f \) (f \) = f" -proof - show "morphism f \ bin_morph_of (f \) (f \) = 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 \Example of a simple symmetry: swap\ - -context binary_code_morphism - -begin - -definition f_swap where "f_swap \ f \ 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 = \" *) - (* 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 \"] 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 \"] 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] \ \" and "f [1-a] \ \" and "hd (f [a]) \ hd (f [1-a])" - shows "marked_morphism f" -proof (standard, simp add: \morphism f\ morphism.morph) - have "f [b] \ \" for b - by (rule bin_swap_exhaust[of b a]) (use assms in force)+ - thus "w = \" if "f w = \" for w - using morphism.noner_sings_conv[OF \morphism f\] that by blast - show "c = b" if "hd (f\<^sup>\ c) = hd (f\<^sup>\ b)" for c b - proof (rule ccontr) - assume "c \ b" - have "hd (f [c]) \ hd (f [b])" - by (rule binA_neq_cases_swap[OF \c \ b\, of a]) - (use \hd (f [a]) \ hd (f [1-a])\ in fastforce)+ - thus False - using that[unfolded core_def] by contradiction - qed -qed - -locale marked_binary_morphism = marked_morphism "f :: binA list \ 'a list" for f - -begin - -lemma bin_marked: "hd (f \) \ hd (f \)" - using marked_morph[of bin0 bin1] by blast - -lemma bin_marked_sing: "hd (f [a]) \ 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: "\ = \" - unfolding bin_lcp_def -proof (rule lcp_distinct_hd) - show "hd (f \ \ f \) \ hd (f \ \ f \)" - unfolding hd_append if_not_P[OF sing_to_nemp] - using bin_marked. -qed - -lemma bin_marked': "(f \)!0 \ (f \)!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 \p f s" shows "r \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 \ s \ f (r \ z1) \\<^sub>p f (s \ z2) = f (r \\<^sub>p s)" - using lcp_ext_right marked_morph_lcp[of "r \ z1" "s \ z2"] by metis - -lemma swap_marked: "hd(f_swap [a]) \ 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]) \ a = b" - using swap_marked bin_neq_swap by auto - -lemma swap_nonerasing: "f_swap w = \ \ w = \" - 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 \p f w\<^sup>\" - shows "r \ f w \ \" -proof- - obtain n where "r \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 \], of "f w \ \", 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 \ 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 = (\ w. \\\<^sup>>(f w \ \))" - -lemma marked_version_conjugates: "\ \ f\<^sub>m w = f w \ \" - unfolding marked_version_def using lq_pref[OF bin_lcp_pref_all, of w]. - -lemma marked_eq_conv: "f w = f w' \ f\<^sub>m w = f\<^sub>m w'" - using cancel[of \ "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 \marked_morphism f\[unfolded marked_lcp_conv]] - by blast - -lemma marked_version_all_nemp: "w \ \ \ f\<^sub>m w \ \" - 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\v) \ \ = (f u \ \) \ \\\<^sup>>(f v \ \)" for u v - unfolding rassoc morph cancel lq_pref[OF bin_lcp_pref_all[of v]].. - thus "\u v. f\<^sub>m (u \ v) = f\<^sub>m u \ 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 \) (f\<^sub>m \) = \ \ \" - 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 (\ \ \)" "f\<^sub>m (\ \ \)" "f\<^sub>m (\ \ \) \\<^sub>s f\<^sub>m (\ \ \) = \ \ f\<^sub>m (\ \ \) \\<^sub>s \ \ f\<^sub>m (\ \ \)" \ \], unfold mv_bcm.morph) - (use mv_bcm.bin_not_comp_suf in argo, simp) - -lemma bin_lcp_shift: assumes "\<^bold>|\\<^bold>| < \<^bold>|f w\<^bold>|" shows "(f w)!\<^bold>|\\<^bold>| = hd (f\<^sub>m w)" -proof- - have "w \ \" - using assms emp_to_emp by fastforce - hence "f\<^sub>m w \ \" - using marked_version_all_nemp by blast - show ?thesis - using pref_index[of "f w" "\\ f\<^sub>m w" "\<^bold>|\\<^bold>|", OF prefI[of "f w" \ " \ \ f\<^sub>m w", OF marked_version_conjugates[of w, symmetric]], OF assms] - unfolding nth_append_length_plus[of \ "f\<^sub>m w" 0, unfolded add_0_right] hd_conv_nth[of "f\<^sub>m w", symmetric, OF \f\<^sub>m w \ \\]. -qed - -lemma mismatch_fst: "hd (f\<^sub>m \) = c\<^sub>0" -proof- - have "(f [bin0,bin1])!\<^bold>|\\<^bold>| = hd (f\<^sub>m [bin0,bin1])" - using bin_lcp_shift[of "[bin0,bin1]", unfolded pop_hd[of bin0 \] lenmorph, OF bin_lcp_short] - unfolding pop_hd[of bin0 \]. - from this[unfolded mv_bcm.pop_hd[of bin0 \, unfolded not_Cons_self2[of bin0 \]] hd_append2[OF mv_bcm.bin_fst_nemp, of "f\<^sub>m \"], symmetric] - show ?thesis - unfolding bin_mismatch_def hd_word[of bin0 \] morph. -qed - -lemma mismatch_snd: "hd (f\<^sub>m \) = c\<^sub>1" -proof- - have "(f [bin1,bin0])!\<^bold>|\\<^bold>| = hd (f\<^sub>m [bin1,bin0])" - using bin_lcp_shift[of "[bin1,bin0]", unfolded pop_hd[of bin1 \] lenmorph, OF bin_lcp_short[unfolded add.commute[of "\<^bold>|f \\<^bold>|" "\<^bold>|f \\<^bold>|"]]] - unfolding pop_hd[of bin1 \]. - from this[unfolded mv_bcm.pop_hd[of bin1 \, unfolded not_Cons_self2[of bin1 \]] hd_append2[OF mv_bcm.bin_snd_nemp, of "f\<^sub>m \"],symmetric] - show ?thesis - unfolding bin_mismatch_def hd_word[of bin1 \] morph bin_lcp_sym[of "f \"]. -qed - -lemma marked_hd_neq: "hd (f\<^sub>m [a]) \ 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 "\ 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] \p f\<^sub>m \" - using mv_bcm.sing_to_nemp[THEN hd_pref, of bin0] unfolding mismatch_fst. - -lemma mismatch_pref1: "[c\<^sub>1] \p f\<^sub>m \" - 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 \ "f\<^sub>m w", unfolded lenmorph[of "f w" \, folded marked_version_conjugates[of w]],symmetric, - unfolded add.commute[of "\<^bold>|f w\<^bold>|" "\<^bold>|\\<^bold>|"]]]. - -lemma bin_code_lcp: "(f r \ \) \\<^sub>p (f s \ \) = f (r \\<^sub>p s) \ \" - by (metis lcp_ext_left marked_version_conjugates mv_mbm.marked_morph_lcp) - -lemma not_comp_lcp: assumes "\ r \ s" - shows "f (r \\<^sub>p s) \ \ = f r \ f (r \ s) \\<^sub>p f s \ f (r \ s)" -proof- - let ?r' = "(r \\<^sub>p s)\\<^sup>>r" - let ?s' = "(r \\<^sub>p s)\\<^sup>>s" - from lcp_mismatch_lq[OF \\ r \ s\] - have "?r' \ \" and "?s' \ \" and "hd ?r' \ hd ?s'". - have "\ f ((r \\<^sub>p s) \ [hd ?r'] \ tl ?r') \ \ \ f ((r \\<^sub>p s) \ [hd ?s'] \ tl ?s') \ \" - using bin_mismatch_swap_not_comp - unfolding morph prefix_comparable_def rassoc pref_cancel_conv - \hd ?r' \ hd ?s'\[symmetric, unfolded bin_neq_iff']. - hence "\ f r \ \ \ f s \ \" - unfolding hd_tl[OF \?r' \ \\] hd_tl[OF \?s' \ \\] lcp_lq. - have pref: "f w \ \ \p f w \ f (r \ s)" for w - unfolding pref_cancel_conv - using append_prefixD[OF not_comp_bin_lcp_pref, OF \\ r \ s\] by blast - from prefE[OF pref[of r], unfolded rassoc] - obtain gr' where gr': "f r \ f (r \ s) = f r \ \ \ gr'". - from prefE[OF pref[of s], unfolded rassoc] - obtain gs' where gs': "f s \ f (r \ s) = f s \ \ \ gs'". - thus "f (r \\<^sub>p s) \ \ = f r \ f (r \ s) \\<^sub>p f s \ f (r \ s)" - unfolding bin_code_lcp[symmetric, of r s] pref_def using \\ f r \ \ \ f s \ \\ - lcp_ext_right[of "f r \ \" "f s \ \" _ gr' gs', unfolded rassoc, folded gr' gs'] by argo -qed - -lemma bin_morph_pref_conv: "f u \ \ \p f v \ \ \ u \p v" -proof - assume "u \p v" - from this[unfolded prefix_def] - obtain z where "v = u \ z" by blast - show "f u \ \ \p f v \ \" - unfolding arg_cong[OF \v = u \ z\, of f, unfolded morph] rassoc pref_cancel_conv using bin_lcp_pref_all. -next - assume "f u \ \ \p f v \ \" - then show "u \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 \ \ \ f v \ \ \ u \ v" - using bin_morph_pref_conv unfolding prefix_comparable_def by auto - -lemma code_lcp': "\ r \ s \ \ \p f z \ \ \p f z' \ f (r \ z) \\<^sub>p f (s \ z') = f (r \\<^sub>p s) \ \" -proof- - assume "\ \p f z" "\ \p f z'" "\ r \ s" - hence eqs: "f (r \ z) = (f r \ \) \ (\\\<^sup>>f z)" "f (s \ z') = (f s \ \) \ (\\\<^sup>>f z')" - unfolding rassoc by (metis lq_pref morph)+ - show ?thesis - using bin_morph_compare_conv \\ r \ s\ bin_code_lcp lcp_ext_right unfolding eqs - by metis -qed - -lemma pref_im_pref: "r \p s \ f r \ \ \p f s \ \" - using marked_version_conjugates - by (metis bin_code_lcp lcp_pref_conv) - -lemma per_comp: - assumes "r \p (f w)\<^sup>\" - shows "r \ f w \ \" -proof- - obtain n where "r \p f w\<^sup>@Suc n \ \" - 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 \Two binary morphisms\ - -locale two_binary_morphisms = two_morphisms g h - for g h :: "binA list \ 'a list" -begin +sublocale g: binary_morphism g + by unfold_locales +sublocale h: binary_morphism h + by unfold_locales 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 \ \" and "g s = h s" and "\a. g [a] \ 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 \ 0" using \s \ \\ by (intro notI) simp + then have "0 < k" using \s \ \\ by blast have "g [a] = h [a]" using \g s = h s\ unfolding * g.pow_morph h.pow_morph - by (fact pow_eq_eq[OF _ \k \ 0\]) + by (fact pow_eq_eq[OF _ \0 < k\]) then show False using \g [a] \ h [a]\ by contradiction qed lemma solution_len_im_sing_less: assumes sol: "g s = h s" and set: "a \ 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>| \ \<^bold>|h [1-a]\<^bold>|" with less_imp_le[OF less] have "\<^bold>|g [b]\<^bold>| \ \<^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>| \ \<^bold>|h [a]\<^bold>|" shows "\<^bold>|h [1-a]\<^bold>| \ \<^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 + have "\<^bold>|h [a]\<^bold>| < \<^bold>|g [a]\<^bold>|" unfolding set binA_simps by blast then show False using \\<^bold>|g [a]\<^bold>| \ \<^bold>|h [a]\<^bold>|\ by simp qed -lemma solution_sing_len_cases: +lemma solution_sing_len_cases: assumes set: "set s = UNIV" and sol: "g s = h s" and "g \ 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>| \ 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>| \ 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 \ \" 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>| \ False" using solution_len_im_sing_less[OF sol, of "1 - (hd s)"] - unfolding set binsimp * by blast + unfolding set binA_simps * by blast next show "\<^bold>|h [1-(hd s)]\<^bold>| < \<^bold>|g [1-(hd s)]\<^bold>| \ False" using swap.solution_len_im_sing_less[OF sol[symmetric], of "1 - (hd s)"] - unfolding set binsimp * by blast + unfolding set binA_simps * 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 \g \ h\ by blast qed lemma len_ims_sing_neq: assumes "g s = h s" "g \ h" "set s = binUNIV" shows "\<^bold>|g [c]\<^bold>| \ \<^bold>|h [c]\<^bold>|" proof(rule solution_sing_len_cases[OF \set s = binUNIV\ \g s = h s\ \g \ h\]) 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>| \ \<^bold>|h [c]\<^bold>|" + show "\<^bold>|g [c]\<^bold>| \ \<^bold>|h [c]\<^bold>|" by (rule bin_swap_exhaust[of c a]) (use less in force)+ qed end +lemma two_binary_morphismsI: "binary_morphism g \ binary_morphism h \ two_binary_morphisms g h" + unfolding binary_morphism_def two_binary_morphisms_def using two_morphisms.intro. + +section \Binary code morphism\ + +subsection \Locale - binary code morphism\ + +locale binary_code_morphism = code_morphism "f :: binA list \ 'a list" for f + +begin + +lemma morph_bin_morph_of: "f = bin_morph_of (f \) (f \)" + 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] \ f [1-a] \ f [1-a] \ f [a]" + unfolding morph[symmetric] using code_morph_code bin_swap_neq by blast + +lemma non_comp_morph: "\ f [a] \ f [1-a] \ f [1-a] \ f [a]" + using comm_comp_eq non_comm_morph by blast + +lemma swap_non_comm_morph [simp, intro]: "a \ b \ f [a] \ f [b] \ f [b] \ 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 \" "f \" + using non_comm_morph[of binb] unfolding binA_simps by unfold_locales + +sublocale binary_code "f \" "f \" + using swap.bin_code_swap. + +notation bin_code_lcp ("\") and + bin_code_lcs ("\") and + bin_code_mismatch_fst ("c\<^sub>0") and + bin_code_mismatch_snd ("c\<^sub>1") +term "bin_lcp (f \) (f \)" +abbreviation bin_morph_mismatch ("\") + where "bin_morph_mismatch a \ bin_mismatch (f[a]) (f[1-a])" +abbreviation bin_morph_mismatch_suf ("\
") + where "bin_morph_mismatch_suf a \ bin_mismatch_suf (f[1-a]) (f[a])" + +lemma bin_lcp_def': "\ = f ([a] \ [1-a]) \\<^sub>p f ([1-a] \ [a])" + by (rule bin_exhaust[of a "\ = f ([a] \ [1-a]) \\<^sub>p f ([1-a] \ [a])"], + unfold morph, use binA_simps(3-4) bin_lcp_def in force) + (unfold bin_lcp_def lcp_sym[of "f[a] \ f[1-a]" "f[1-a] \ f[a]"], + use binA_simps(3-4) in auto) + +lemma bin_lcp_neq: "a \ b \ \ = f ([a] \ [b]) \\<^sub>p f ([b] \ [a])" + using bin_neq_swap[of a b] unfolding bin_lcp_def'[of a] by blast + +lemma sing_im: "f [a] \ {f \, f \}" + using finite_2.exhaust[of a ?thesis] by fastforce + +lemma bin_mismatch_inj: "inj \" + unfolding inj_on_def + using non_comm_morph[folded bin_mismatch_comm] bin_neq_swap by force + +lemma map_in_lists: "map (\x. f [x]) w \ lists {f \, f \}" +proof (induct w) + case (Cons a w) + then show ?case + unfolding list.map(2) using sing_im by simp +qed simp + +lemma bin_morph_lcp_short: "\<^bold>|\\<^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: "\ f([a] \ [1-a]) \p \" + using pref_len[of "f [a] \ f [1-a]" \] unfolding morph lenmorph using bin_morph_lcp_short[of a] by force + +thm local.bin_mismatch_inj + +lemma bin_mismatch_suf_inj: "inj \
" + 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]) = \" + 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]) = \" + 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: "\ a \ \ (1-a)" + using bin_code_morph_sing binary_code.bin_mismatch_neq by auto + +lemma long_bin_lcp_hd: assumes "\<^bold>|f w\<^bold>| \ \<^bold>|\\<^bold>|" + shows "w \ [hd w]*" +proof (rule ccontr) + assume "\ w \ [hd w]*" + from distinct_letter_in_hd[OF this] + obtain m b suf where w: "[hd w]\<^sup>@m \ [b]\ suf = w" and "b \ hd w" and "m \ 0". + have ineq: "\<^bold>|f [b]\<^bold>| + \<^bold>|f [hd w]\<^bold>| \ \<^bold>|f w\<^bold>|" + using quotient_smaller[OF \m \ 0\, of "\<^bold>|f [hd w]\<^bold>|"] + unfolding arg_cong[OF w, of "\ x. \<^bold>|f(x)\<^bold>|", unfolded morph lenmorph pow_morph pow_len, symmetric] + by linarith + hence "\<^bold>|f \\<^bold>| + \<^bold>|f \\<^bold>| \ \<^bold>|f w\<^bold>|" + using \b \ hd w\ alphabet_or[of b] alphabet_or[of "hd w"] add.commute by fastforce + thus False + using bin_lcp_short \\<^bold>|f w\<^bold>| \ \<^bold>|\\<^bold>|\ by linarith +qed + +thm nonerasing + nonerasing_morphism.nonerasing + lemmas nonerasing = nonerasing +thm nonerasing_morphism.nonerasing + binary_code_morphism.nonerasing + +lemma bin_morph_lcp_mismatch_pref: + "\ \ [\ a] \p f [a] \ \" + using binary_code.bin_fst_mismatch[OF bin_code_morph_sing] unfolding bin_lcp_sing. + +lemma "[\
a] \ \ \s \ \ f [a]" using binary_code_morphism.bin_morph_lcp_mismatch_pref[OF bin_code_morph_rev_map, reversed]. + +lemma bin_lcp_pref_all: "\ \p f w \ \" +proof(induct w rule: rev_induct) + case (snoc x xs) + from pref_prolong[OF this, of "f[x]\\", 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 simp + +lemma bin_lcp_spref_all: "w \ \ \ \

\" + using per_rootI[OF bin_lcp_pref_all] nemp_to_nemp by presburger + +lemma pref_mono_lcp: assumes "w \p w'" shows "f w \ \ \p f w' \ \" +proof- + from \w \p w'\ + obtain z where "w' = w \ z" + unfolding prefix_def by fast + show ?thesis + unfolding \w' = w \ z\ morph rassoc pref_cancel_conv using bin_lcp_pref_all. +qed + +lemma long_bin_lcp: assumes "w \ \" and "\<^bold>|f w\<^bold>| \ \<^bold>|\\<^bold>|" + shows "w \ [hd w]*" +proof(rule ccontr) + assume "w \ [hd w]*" + obtain m b q where "[hd w]\<^sup>@m \ [b] \ q = w" and "b \ hd w" and "m \ 0" + using distinct_letter_in_hd[OF \w \ [hd w]*\]. + have ineq: "\<^bold>|f ([hd w]\<^sup>@m \ [b])\<^bold>| \ \<^bold>|f w\<^bold>|" + using arg_cong[OF \[hd w] \<^sup>@ m \ [b] \ q = w\, of "\ 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 \ [b])\<^bold>|" + by (simp add: morph pow_len pow_morph) + have "\<^bold>|f [hd w]\<^bold>| + \<^bold>|f [b]\<^bold>| \ m*\<^bold>|f [hd w]\<^bold>| + \<^bold>|f [b]\<^bold>|" + using ineq \m \ 0\ by simp + hence "\<^bold>|f [hd w]\<^bold>| + \<^bold>|f [b]\<^bold>| \ \<^bold>|f w\<^bold>|" + using eq ineq by linarith + hence "\<^bold>|f \\<^bold>| + \<^bold>|f \\<^bold>| \ \<^bold>|f w\<^bold>|" + using binA_neq_cases [OF \b \ hd w\] by fastforce + thus False + using bin_lcp_short \\<^bold>|f w\<^bold>| \ \<^bold>|\\<^bold>|\ by linarith +qed + +thm sing_to_nemp + nonerasing + +lemma bin_mismatch_code_morph: "c\<^sub>0 = \ 0" "c\<^sub>1 = \ 1" + unfolding bin_mismatch_def bin_lcp_def by simp_all + +lemma bin_lcp_mismatch_pref_all: "\ \ [\ a] \p f [a] \ f w \ \" + 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: "\ \ [c\<^sub>0] \p f \ \ f w \ \" + using pref_prolong[OF bin_fst_mismatch bin_lcp_pref_all[of w]]. + +lemma bin_snd_mismatch_all: "\ \ [c\<^sub>1] \p f \ \ f w \ \" + using pref_prolong[OF bin_snd_mismatch bin_lcp_pref_all[of w]] by simp + +lemma bin_long_mismatch: assumes "\<^bold>|\\<^bold>| < \<^bold>|f w\<^bold>|" shows "\ \ [\ (hd w)] \p f w" +proof- + have "w \ \" + using assms emp_to_emp emp_len by force + have "f w = f[hd w] \ f (tl w)" + unfolding pop_hd[symmetric] unfolding hd_word[of "hd w" "tl w"] + hd_tl[OF \w \ \\].. + have "\ \ [\ (hd w)] \p f w \ \" + using bin_lcp_mismatch_pref_all[of "hd w" "tl w"] + unfolding lassoc \f w = f[hd w] \ f (tl w)\[symmetric]. + moreover have "\<^bold>|\ \ [\ (hd w)]\<^bold>| \ \<^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 "\ a = b" +proof- + \ \auxiliary\ + have aritm: "Suc n * Suc \<^bold>|\\<^bold>| = Suc (n*\<^bold>|\\<^bold>| + n + \<^bold>|\\<^bold>|)" + by auto + have set: "set ([b] \<^sup>@ (Suc n * Suc \<^bold>|\\<^bold>|)) = {b}" + unfolding aritm using sing_pow_set_Suc. + have elem: "\ a \ set (\ \ [\ a])" + by simp + have hd: "hd ([a] \<^sup>@ Suc \<^bold>|\\<^bold>|) = a" + by fastforce + \ \proof\ + let ?w = "[a]\<^sup>@Suc \<^bold>|\\<^bold>|" + have fw: "f ?w = [b]\<^sup>@(Suc n*Suc \<^bold>|\\<^bold>|)" + unfolding pow_mult assms[symmetric] pow_morph.. + have "\<^bold>|\\<^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 "\ a = b" + unfolding hd set using elem by blast +qed + +lemma sing_pow_mismatch_suf: "f [a] = [b]\<^sup>@Suc n \ \

a = b" + using binary_code_morphism.sing_pow_mismatch[OF bin_code_morph_rev_map, reversed]. + +lemma bin_lcp_swap_hd: "f [a] \ f w \ \ \\<^sub>p f [1-a] \ f w' \ \ = \" + using lcp_first_mismatch[OF bin_mismatch_swap_neq, of \ a] + bin_lcp_mismatch_pref_all[of a w] bin_lcp_mismatch_pref_all[of "1-a" w'] + unfolding prefix_def rassoc by force + +lemma bin_lcp_neq_hd: "a \ b \ f [a] \ f w \ \ \\<^sub>p f [b] \ f w' \ \ = \" + using bin_lcp_swap_hd bin_neq_swap by blast + + +lemma bin_mismatch_swap_not_comp: "\ f [a] \ f w \ \ \ f [1-a] \ f w' \ \" + unfolding prefix_comparable_def lcp_pref_conv[symmetric] bin_lcp_swap_hd + bin_lcp_swap_hd[of "1-a", unfolded binA_simps] using sing_to_nemp by auto + +lemma bin_lcp_root: "\

\" + using alphabet_or[of a] per_rootI[OF bin_lcp_pref_all[of \] bin_snd_nemp] per_rootI[OF bin_lcp_pref_all[of \] bin_fst_nemp] by blast + +lemma bin_lcp_pref: assumes "w \ \*" and "w \ \*" + shows "\ \p (f w)" +proof- + have "w \ \" + using \\ (w \ \*)\ emp_all_roots by blast + have "w \ [hd w]*" + using assms alphabet_or[of "hd w"] by presburger + hence "\<^bold>|\\<^bold>| \ \<^bold>|f w\<^bold>|" + using long_bin_lcp[OF \w \ \\] nat_le_linear[of "\<^bold>|f w\<^bold>|" "\<^bold>|\\<^bold>|" ] by blast + show ?thesis + using pref_prod_le[OF bin_lcp_pref_all \\<^bold>|\\<^bold>| \ \<^bold>|f w\<^bold>|\]. +qed + + +lemma bin_lcp_pref'': "[a] \f w \ [1-a] \f w \ \ \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': "\ \f w \ \ \f w \ \ \p (f w)" + using bin_lcp_pref''[of bina, unfolded binA_simps]. + +lemma bin_lcp_mismatch_pref_all_set: assumes "1-a \ set w" + shows "\ \ [\ a] \p f [a] \ f w" +proof- + have "\<^bold>|f[1-a]\<^bold>| \ \<^bold>|f w\<^bold>|" + using fac_len' morph split_list'[OF assms] by metis + hence "\<^bold>|\ \ [\ a]\<^bold>| \ \<^bold>|f [a] \ 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: "\ \ f (\ \ w0) \\<^sub>p f (\ \ w1)" + using ruler[OF bin_lcp_pref_all[of "\ \ w0"] + pref_trans[OF lcp_pref[of "f (\ \ w0)" "f (\ \ w1)"], of "f (\ \ w0) \ \", OF triv_pref]] + unfolding prefix_comparable_def. + +lemma sing_mismatch: assumes "f \ \ [a]*" shows "c\<^sub>0 = a" +proof- + have "\ \ [a]*" + using per_one[OF per_root_trans[OF bin_lcp_root assms]]. + hence "f \ \ \ \ [a]*" + using \f \ \ [a]*\ 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 \ \ [a]*" shows "c\<^sub>1 = a" +proof- + have "\ \ [a]*" + using per_one[OF per_root_trans[OF bin_lcp_root assms]]. + hence "f \ \ \ \ [a]*" + using \f \ \ [a]*\ 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: "\ \ (f w)" + unfolding prefix_comparable_def using ruler[OF bin_lcp_pref_all triv_pref]. + +lemma not_comp_bin_swap: "\ f [a] \ \ \ f [1-a] \ \" + using not_comp_bin_fst_snd bin_exhaust[of a ?thesis] + unfolding prefix_comparable_def + by simp + +lemma mismatch_pref: + assumes "\ \p f ([a] \ w0)" and "\ \p f ([1-a] \ w1)" + shows "\ = f ([a] \ w0) \\<^sub>p f ([1-a] \ w1)" +proof- + have "f ([a] \ w0) \ \ \\<^sub>p f ([1-a] \ w1) \ \ = \" + unfolding morph using bin_lcp_swap_hd[unfolded lassoc]. + hence "f ([a] \ w0) \\<^sub>p f ([1-a] \ w1) \p \" + using lcp.mono[OF triv_pref[of "f ([a] \ w0)" \] triv_pref[of "f ([1-a] \ w1)" \]] + by presburger + moreover have "\ \p f ([a] \ w0) \\<^sub>p f ([1-a] \ 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>| \ \<^bold>|f w\<^bold>|" +proof- + have "w \ \" + using \set w = UNIV\ 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) \ 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>| \ \<^bold>|f (tl w)\<^bold>|". + with lenarg[OF arg_cong[of _ _ f, OF hd_tl[OF \w \ \\]]] + have "\<^bold>|f [hd w]\<^bold>| + \<^bold>|f [1-hd w]\<^bold>| \ \<^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 "\ \ [\ (hd w)] \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 \ \ = \" +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 \ \ f \) \ hd (f \ \ f \)" + using hd_append finite_2.distinct by auto + thus "\ = \" + unfolding bin_lcp_def using lcp_distinct_hd by blast +next + assume "\ = \" + have "hd (f \) \ hd (f \)" + by (rule nemp_lcp_distinct_hd[OF sing_to_nemp sing_to_nemp]) + (use lcp_append_monotone[of "f \" "f \" "f \" "f \", unfolded \\ = \\[unfolded bin_lcp_def]] + in simp) + show "marked_morphism f" + proof + fix a b :: binA assume "hd (f\<^sup>\ a) = hd (f\<^sup>\ b)" + from im_swap_neq[OF this[unfolded core_def] \hd (f \) \ hd (f \)\] + show "a = b". + qed +qed + +lemma im_comm_lcp: "f w \ \ = \ \ f w \ (\ a. a \ set w \ f [a] \ \ = \ \ f [a])" +proof (induct w) + case (Cons a w) + then show ?case + proof (cases "w = \") + assume "w = \" + show ?thesis + using Cons.prems(1) unfolding \w = \\ by force + next + assume "w \ \" + have eq: "f [a] \ f w \ \ = \ \ f [a] \ f w" + unfolding morph[symmetric] + unfolding lassoc morph[symmetric] hd_tl[OF \w \ \\] + using \f (a # w) \ \ = \ \ f (a # w)\ by force + have "f [a] \ \ \p f [a] \ f w \ \" + unfolding pref_cancel_conv using bin_lcp_pref_all. + hence "f [a] \ \ = \ \ f [a]" + using eqd_eq[of "\ \ f [a]", OF _swap_len] unfolding prefix_def eq rassoc by metis + from eq[unfolded lassoc, folded this, unfolded rassoc cancel] + have "f w \ \ = \ \ f w". + from Cons.hyps[OF this] \f [a] \ \ = \ \ f [a]\ + show ?thesis by fastforce + qed +qed simp + +lemma im_comm_lcp_nemp: assumes "f w \ \ = \ \ f w" and "w \ \" and "\ \ \" + obtains k where "w = [hd w]\<^sup>@Suc k" +proof- + have "set w = {hd w}" + proof- + have "hd w \ set w" using \w \ \\ by force + have "a = hd w" if "a \ set w" for a + proof- + have "f [a] \ \ = \ \ f [a]" and "f [hd w] \ \ = \ \ f [hd w]" + using that im_comm_lcp[OF \f w \ \ = \ \ f w\] \hd w \ set w\ by presburger+ + from comm_trans[OF this \\ \ \\] + show "a = hd w" + using swap_non_comm_morph by blast + qed + thus "set w = {hd w}" + using \hd w \ set w\ by blast + qed + from unique_letter_wordE[OF this] + show thesis + using that by blast +qed + +lemma bin_lcp_ims_im_lcp: "f w \ \ \\<^sub>p f w' \ \ = f (w \\<^sub>p w') \ \" +proof (cases "w \ w'") + assume "w \ w'" + from disjE[OF this[unfolded prefix_comparable_def]] + consider "w \p w'" | "w' \p w" by blast + thus ?thesis + proof (cases) + assume "w \p w'" + hence "f w \ \ \p f w' \ \" + using pref_mono_lcp by blast + from this[folded lcp_pref_conv] + show ?thesis + unfolding \w \p w'\[folded lcp_pref_conv]. + next + assume "w' \p w" + hence "f w' \ \ \p f w \ \" + using pref_mono_lcp by blast + from this[folded lcp_pref_conv] + show ?thesis + unfolding lcp_sym[of "f w \ \"] \w' \p w\[folded lcp_pref_conv, unfolded lcp_sym[of w']]. + qed +next + assume "\ w \ w'" + from lcp_mismatchE[OF this] + obtain ws ws' where "(w \\<^sub>p w') \ ws = w" "(w \\<^sub>p w') \ ws' = w'" + "ws \ \" "ws' \ \" "hd ws \ hd ws'". + note hd_tl[OF \ws \ \\] hd_tl[OF \ws' \ \\] + have w: "(w \\<^sub>p w') \ [hd ws] \ tl ws = w" + using \(w \\<^sub>p w') \ ws = w\ \[hd ws] \ tl ws = ws\ by auto + have w': "(w \\<^sub>p w') \ [hd ws'] \ tl ws' = w'" + using \(w \\<^sub>p w') \ ws' = w'\ \[hd ws'] \ tl ws' = ws'\ by auto + have "f((w \\<^sub>p w') \ [hd ws] \ tl ws) \ \ \\<^sub>p f((w \\<^sub>p w') \ [hd ws'] \ tl ws') \ \ = + f(w \\<^sub>p w') \ (f ([hd ws] \ tl ws) \ \ \\<^sub>p f([hd ws'] \ tl ws') \ \)" + unfolding morph using lcp_ext_left by auto + thus ?thesis + unfolding w w' bin_lcp_neq_hd[OF \hd ws \ hd ws'\, folded rassoc morph]. +qed + +lemma per_comp: + assumes "r

r" + shows "r \ f w \ \" + using assms +proof- + obtain n where "r

@n" "0 < n" + using per_root_powE[OF assms]. + have "f w \ \ \p f w \ f w \<^sup>@ (n - 1) \ \" + using bin_lcp_pref_all[of "w\<^sup>@(n-1)"] + unfolding pref_cancel_conv pow_morph. + with ruler[OF pref_ext[OF sprefD1[OF \r

@n\], of \], of "f w \ \"] + show ?thesis + unfolding prefix_comparable_def pow_pos[OF \0 < n\] rassoc. +qed + +end + +subsection \More translations\ + + +lemma bin_code_morph_iff': "binary_code_morphism f \ morphism f \ f [a] \ f [1-a] \ f [1-a] \ f [a]" +proof + assume "binary_code_morphism f" + hence "morphism f" + by (simp add: binary_code_morphism_def code_morphism_def) + have "f [a] \ f [1-a] \ f [1-a] \ f [a]" + using \binary_code_morphism f\ binary_code_morphism.non_comm_morph by auto + thus "morphism f \ f [a] \ f [1-a] \ f [1-a] \ f [a]" + using \morphism f\ by blast +next + assume "morphism f \ f [a] \ f [1-a] \ f [1-a] \ f [a]" + hence "morphism f" and "f [a] \ f [1-a] \ f [1-a] \ f [a]" by force+ + from binary_code_morphism.intro[OF binary_morphism.bin_code_morphismI[OF binary_morphism.intro], OF this] + show "binary_code_morphism f". + qed + +lemma bin_code_morph_iff: "binary_code_morphism (bin_morph_of x y) \ x \ y \ y \ x" + unfolding bin_code_morph_iff'[of "bin_morph_of x y" bina, unfolded binA_simps bin_morph_ofD] + using bin_morph_of_morph by blast + +lemma bin_noner_morph_iff: "nonerasing_morphism (bin_morph_of x y) \ x \ \ \ y \ \" +proof + show "x \ \ \ y \ \ \ 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) \ x \ \ \ y \ \" + using nonerasing_morphism.nemp_to_nemp[of "bin_morph_of x y", of "[bina]"] + nonerasing_morphism.nemp_to_nemp[of "bin_morph_of x y", of "[binb]"] + unfolding bin_morph_of_def by simp_all +qed + +lemma morph_bin_morph_of: "morphism f \ bin_morph_of (f \) (f \) = f" +proof + show "morphism f \ bin_morph_of (f \) (f \) = 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) + + + + + + + + + + + + + + + + + lemma two_bin_code_morphs_nonerasing_morphs: "binary_code_morphism g \ binary_code_morphism h \ 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 "Marked binary morphism" + +lemma marked_binary_morphI: assumes "morphism f" and "f [a :: binA] \ \" and "f [1-a] \ \" and "hd (f [a]) \ hd (f [1-a])" + shows "marked_morphism f" +proof (unfold_locales) + have "f [b] \ \" for b + by (rule bin_swap_exhaust[of b a]) (use assms in force)+ + thus "w = \" if "f w = \" for w + using morphism.noner_sings_conv[OF \morphism f\] that by blast + show "c = b" if "hd (f\<^sup>\ c) = hd (f\<^sup>\ b)" for c b + proof (rule ccontr) + assume "c \ b" + have "hd (f [c]) \ hd (f [b])" + by (rule binA_neq_cases_swap[OF \c \ b\, of a]) + (use \hd (f [a]) \ hd (f [1-a])\ in fastforce)+ + thus False + using that[unfolded core_def] by contradiction + qed +qed (simp add: morphism.morph[OF assms(1)]) + +locale marked_binary_morphism = marked_morphism "f :: binA list \ 'a list" for f + +begin + +lemma bin_marked: "hd (f \) \ hd (f \)" + using marked_morph[of bina binb] by blast + +lemma bin_marked_sing: "hd (f [a]) \ 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: "\ = \" + unfolding bin_lcp_def +proof (rule lcp_distinct_hd) + show "hd (f \ \ f \) \ hd (f \ \ f \)" + unfolding hd_append if_not_P[OF sing_to_nemp] + using bin_marked. +qed + +lemma bin_marked': "(f \)!0 \ (f \)!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: "r \ s \ f (r \ z1) \\<^sub>p f (s \ z2) = f (r \\<^sub>p s)" + using lcp_ext_right marked_morph_lcp[of "r \ z1" "s \ z2"] by metis + + + + + +end + +lemma bin_marked_preimg_hd: + assumes "marked_binary_morphism (f :: binA list \ 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 = (\ w. \\\<^sup>>(f w \ \))" + +lemma marked_version_conjugates: "\ \ f\<^sub>m w = f w \ \" + unfolding marked_version_def using lq_pref[OF bin_lcp_pref_all, of w]. + +lemma marked_eq_conv: "f w = f w' \ f\<^sub>m w = f\<^sub>m w'" + using cancel[of \ "f\<^sub>m w" "f\<^sub>m w'"] unfolding marked_version_conjugates cancel_right. + +lemma marked_marked: assumes "marked_morphism f" shows "f\<^sub>m = f" + using marked_version_conjugates[unfolded emp_simps \marked_morphism f\[unfolded marked_lcp_conv]] + by blast + +lemma marked_version_all_nemp: "w \ \ \ f\<^sub>m w \ \" + unfolding marked_version_def using bin_lcp_pref_all nonerasing conjug_emp_emp marked_version_def by blast + +lemma marked_version_binary_code_morph: "binary_code_morphism f\<^sub>m" + unfolding bin_code_morph_iff' morphism_def +proof (unfold_locales) + have "f (u\v) \ \ = (f u \ \) \ \\\<^sup>>(f v \ \)" for u v + unfolding rassoc morph cancel lq_pref[OF bin_lcp_pref_all[of v]].. + thus "\u v. f\<^sub>m (u \ v) = f\<^sub>m u \ 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 + +interpretation mv_bcm: binary_code_morphism f\<^sub>m + using marked_version_binary_code_morph . + +lemma marked_lcs: "bin_lcs (f\<^sub>m \) (f\<^sub>m \) = \ \ \" + 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 (\ \ \)" "f\<^sub>m (\ \ \)" "f\<^sub>m (\ \ \) \\<^sub>s f\<^sub>m (\ \ \) = \ \ f\<^sub>m (\ \ \) \\<^sub>s \ \ f\<^sub>m (\ \ \)" \ \], unfold mv_bcm.morph) + (use mv_bcm.bin_not_comp_suf in argo, simp) + +lemma bin_lcp_shift: assumes "\<^bold>|\\<^bold>| < \<^bold>|f w\<^bold>|" shows "(f w)!\<^bold>|\\<^bold>| = hd (f\<^sub>m w)" +proof- + have "w \ \" + using assms emp_to_emp by fastforce + hence "f\<^sub>m w \ \" + using marked_version_all_nemp by blast + show ?thesis + using pref_index[of "f w" "\\ f\<^sub>m w" "\<^bold>|\\<^bold>|", OF prefI[of "f w" \ " \ \ f\<^sub>m w", OF marked_version_conjugates[of w, symmetric]], OF assms] + unfolding nth_append_length_plus[of \ "f\<^sub>m w" 0, unfolded add_0_right] hd_conv_nth[of "f\<^sub>m w", symmetric, OF \f\<^sub>m w \ \\]. +qed + +lemma mismatch_fst: "hd (f\<^sub>m \) = c\<^sub>0" +proof- + have "(f [bina,binb])!\<^bold>|\\<^bold>| = hd (f\<^sub>m [bina,binb])" + using bin_lcp_shift[of "[bina,binb]", unfolded pop_hd[of bina \] lenmorph, OF bin_lcp_short] + unfolding pop_hd[of bina \]. + from this[unfolded mv_bcm.pop_hd[of bina \, unfolded not_Cons_self2[of bina \]] hd_append2[OF mv_bcm.bin_fst_nemp, of "f\<^sub>m \"], symmetric] + show ?thesis + unfolding bin_mismatch_def hd_word[of bina \] morph. +qed + +lemma mismatch_snd: "hd (f\<^sub>m \) = c\<^sub>1" +proof- + have "(f [binb,bina])!\<^bold>|\\<^bold>| = hd (f\<^sub>m [binb,bina])" + using bin_lcp_shift[of "[binb,bina]", unfolded pop_hd[of binb \] lenmorph, OF bin_lcp_short[unfolded add.commute[of "\<^bold>|f \\<^bold>|" "\<^bold>|f \\<^bold>|"]]] + unfolding pop_hd[of binb \]. + from this[unfolded mv_bcm.pop_hd[of binb \, unfolded not_Cons_self2[of binb \]] hd_append2[OF mv_bcm.bin_snd_nemp, of "f\<^sub>m \"],symmetric] + show ?thesis + unfolding bin_mismatch_def hd_word[of binb \] morph bin_lcp_sym[of "f \"]. +qed + +lemma marked_hd_neq: "hd (f\<^sub>m [a]) \ hd (f\<^sub>m [1-a])" (is "?P (a :: binA)") + by (rule bin_induct[of ?P, unfolded binA_simps]) + (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 "\ 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 bin_code_pref_morph: "f u \ \ \p f w \ \ \ u \p w" + unfolding marked_version_conjugates[symmetric] pref_cancel_conv + using mv_mbm.pref_free_morph. + +lemma mismatch_pref0: "[c\<^sub>0] \p f\<^sub>m \" + using mv_bcm.sing_to_nemp[THEN hd_pref, of bina] unfolding mismatch_fst. + +lemma mismatch_pref1: "[c\<^sub>1] \p f\<^sub>m \" + 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 \ "f\<^sub>m w", unfolded lenmorph[of "f w" \, folded marked_version_conjugates[of w]],symmetric, + unfolded add.commute[of "\<^bold>|f w\<^bold>|" "\<^bold>|\\<^bold>|"]]]. + +lemma bin_code_lcp: "(f r \ \) \\<^sub>p (f s \ \) = f (r \\<^sub>p s) \ \" + by (metis lcp_ext_left marked_version_conjugates mv_mbm.marked_morph_lcp) + +lemma not_comp_lcp: assumes "\ r \ s" + shows "f (r \\<^sub>p s) \ \ = f r \ f (r \ s) \\<^sub>p f s \ f (r \ s)" +proof- + let ?r' = "(r \\<^sub>p s)\\<^sup>>r" + let ?s' = "(r \\<^sub>p s)\\<^sup>>s" + from lcp_mismatch_lq[OF \\ r \ s\] + have "?r' \ \" and "?s' \ \" and "hd ?r' \ hd ?s'". + have "\ f ((r \\<^sub>p s) \ [hd ?r'] \ tl ?r') \ \ \ f ((r \\<^sub>p s) \ [hd ?s'] \ tl ?s') \ \" + using bin_mismatch_swap_not_comp + unfolding morph prefix_comparable_def rassoc pref_cancel_conv + \hd ?r' \ hd ?s'\[symmetric, unfolded bin_neq_iff, symmetric]. + hence "\ f r \ \ \ f s \ \" + unfolding hd_tl[OF \?r' \ \\] hd_tl[OF \?s' \ \\] lcp_lq. + have pref: "f w \ \ \p f w \ f (r \ s)" for w + unfolding pref_cancel_conv + using append_prefixD[OF not_comp_bin_lcp_pref, OF \\ r \ s\] by blast + from prefE[OF pref[of r], unfolded rassoc] + obtain gr' where gr': "f r \ f (r \ s) = f r \ \ \ gr'". + from prefE[OF pref[of s], unfolded rassoc] + obtain gs' where gs': "f s \ f (r \ s) = f s \ \ \ gs'". + thus "f (r \\<^sub>p s) \ \ = f r \ f (r \ s) \\<^sub>p f s \ f (r \ s)" + unfolding bin_code_lcp[symmetric, of r s] prefix_def using \\ f r \ \ \ f s \ \\ + lcp_ext_right[of "f r \ \" "f s \ \" _ gr' gs', unfolded rassoc, folded gr' gs'] by argo +qed + +lemma bin_morph_pref_conv: "f u \ \ \p f v \ \ \ u \p v" +proof + assume "u \p v" + from this[unfolded prefix_def] + obtain z where "v = u \ z" by blast + show "f u \ \ \p f v \ \" + unfolding arg_cong[OF \v = u \ z\, of f, unfolded morph] rassoc pref_cancel_conv using bin_lcp_pref_all. +next + assume "f u \ \ \p f v \ \" + then show "u \p v" + unfolding marked_version_conjugates[symmetric] prefix_comparable_def pref_cancel_conv + using mv_mbm.pref_free_morph by meson +qed + +lemma bin_morph_compare_conv: "f u \ \ \ f v \ \ \ u \ v" + using bin_morph_pref_conv unfolding prefix_comparable_def by auto + +lemma code_lcp': "\ r \ s \ \ \p f z \ \ \p f z' \ f (r \ z) \\<^sub>p f (s \ z') = f (r \\<^sub>p s) \ \" +proof- + assume "\ \p f z" "\ \p f z'" "\ r \ s" + hence eqs: "f (r \ z) = (f r \ \) \ (\\\<^sup>>f z)" "f (s \ z') = (f s \ \) \ (\\\<^sup>>f z')" + unfolding rassoc by (metis lq_pref morph)+ + show ?thesis + using bin_morph_compare_conv \\ r \ s\ bin_code_lcp lcp_ext_right unfolding eqs + by metis +qed + +lemma non_comm_im_lcp: assumes "u \ v \ v \ u" + shows "f (u \ v) \\<^sub>p f (v \ u) = f (u \ v \\<^sub>p v \ u) \ \" +proof- + have "\ f (u \ v) \ f (v \ u)" + using assms comm_comp_eq[of "f u" "f v", folded morph, THEN code_morph_code] by blast + from lcp_ext_right_conv[OF this, of \ \, unfolded bin_code_lcp, symmetric] + show ?thesis. +qed + +end + +\ \Obtaining one morphism marked from two general morphisms by shift (conjugation)\ + +locale binary_code_morphism_shift = binary_code_morphism + + fixes \' + assumes shift_pref: "\' \p \" + +begin + +definition shifted_f where "shifted_f = (\ w. \'\\<^sup>>(f w \ \'))" + +lemma shift_pref_all: "\' \p f w \ \'" +proof- + have "\' \ \'\\<^sup>>\ \p f w \ \' \ \'\\<^sup>>\" + unfolding lq_pref[OF shift_pref] rassoc using bin_lcp_pref_all. + thus ?thesis + using pref_keeps_per_root by blast +qed + +sublocale shifted: binary_code_morphism shifted_f +proof- + have morph: "f (u\v) \ \' = (f u \ \') \ \'\\<^sup>>(f v \ \')" for u v + unfolding rassoc morph cancel lq_pref[OF shift_pref_all].. + then interpret morphism shifted_f + unfolding shifted_f_def morphism_def + using lq_reassoc[OF shift_pref_all] by presburger + have "inj shifted_f" + unfolding inj_on_def shifted_f_def using lq_pref[OF shift_pref_all] + using cancel_right code_morph_code by metis + then show "binary_code_morphism shifted_f" + by unfold_locales +qed + +lemma shifted_lcp: "\' \ shifted.bin_code_lcp = \" + unfolding bin_lcp_def shifted_f_def lcp_ext_left[symmetric] + unfolding lassoc lq_pref[OF shift_pref_all] + unfolding rassoc lq_pref[OF shift_pref_all] + using lcp_ext_right_conv[OF bin_not_comp, unfolded rassoc]. + +lemma "\' = \ \ shifted_f = f\<^sub>m" + unfolding shifted_f_def marked_version_def by fast + +end + section "Two binary code morphisms" -locale two_binary_code_morphisms = two_binary_morphisms + - g: binary_code_morphism g + - h: binary_code_morphism h +locale two_binary_code_morphisms = + g: binary_code_morphism g + + h: binary_code_morphism h + for g h :: "binA list \ 'a list" begin notation h.bin_code_lcp ("\\<^sub>h") notation g.bin_code_lcp ("\\<^sub>g") -notation "g.marked_version" ("g\<^sub>m") -notation "h.marked_version" ("h\<^sub>m") +notation "g.marked_version" ("g\<^sub>m") +notation "h.marked_version" ("h\<^sub>m") +sublocale gm: marked_binary_morphism g\<^sub>m + by (simp add: g.marked_version_marked_morph marked_binary_morphism.intro) + +sublocale hm: marked_binary_morphism h\<^sub>m + by (simp add: h.marked_version_marked_morph marked_binary_morphism.intro) + +sublocale two_binary_morphisms g h.. + +sublocale marked: two_marked_morphisms g\<^sub>m h\<^sub>m.. + +(*NB: properties of g\<^sub>m and h\<^sub>m are available in the namespace gm and hm, not marked.g. and marked.h. + It would be possible to get their properties of marked morphisms through marked.g. and marked.h. + but not their properties of marked binary morphisms, since + + sublocale marked: two_binary_marked_morphisms g\<^sub>m h\<^sub>m.. + + would loop. + + See, for illustration, the mixed solution: + +------------------- 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 + interpret marked_binary_morphism h\<^sub>m + by (simp add: h.marked_version_marked_morph marked_binary_morphism.intro) + show "two_marked_morphisms g\<^sub>m h\<^sub>m".. qed +------------------- + +instead of + +------------------- +sublocale hm: marked_binary_morphism h\<^sub>m + by (simp add: h.marked_version_marked_morph marked_binary_morphism.intro) + +sublocale marked: two_marked_morphisms g\<^sub>m h\<^sub>m.. +------------------- + +and then + +------------------- +find_theorems name: code_morph_code +-------------------- +*) 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 +lemma marked_two_binary_code_morphisms: "two_binary_code_morphisms g\<^sub>m h\<^sub>m" + using g.marked_version_binary_code_morph h.marked_version_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 + 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\Each successful overflow has a unique minimal successful continuation\ lemma min_completionE: assumes "z \ g\<^sub>m r = z' \ h\<^sub>m s" - obtains p q where "z \ g\<^sub>m p = z' \ h\<^sub>m q" and + obtains p q where "z \ g\<^sub>m p = z' \ h\<^sub>m q" and "\ r s. z \ g\<^sub>m r = z' \ h\<^sub>m s \ p \p r \ q \p s" proof- interpret swap: two_binary_code_morphisms h g by unfold_locales define P where "P = (\ m. \ p q. z \ g\<^sub>m p = z' \ h\<^sub>m q \ \<^bold>|p\<^bold>| = m)" have "P \<^bold>|r\<^bold>|" using assms P_def - by blast + by blast obtain n where ndef: "n = (LEAST m. P m)" - by simp + by simp then obtain p q where "z \ g\<^sub>m p = z' \ h\<^sub>m q" "\<^bold>|p\<^bold>| = n" using \P \<^bold>|r\<^bold>|\ using LeastI P_def by metis - have "p \p r' \ q \p s'" if "z \ g\<^sub>m r' = z' \ h\<^sub>m s'" for r' s' - proof - have "z \ g\<^sub>m (p \\<^sub>p r') = z' \ h\<^sub>m (q \\<^sub>p s')" + have "p \p r' \ q \p s'" if "z \ g\<^sub>m r' = z' \ h\<^sub>m s'" for r' s' + proof + have "z \ g\<^sub>m (p \\<^sub>p r') = z' \ h\<^sub>m (q \\<^sub>p s')" using \z \ g\<^sub>m p = z' \ h\<^sub>m q\ \z \ g\<^sub>m r' = z' \ h\<^sub>m s'\ marked.unique_continuation by blast thus "p \p r'" - using P_def le_antisym \\<^bold>|p\<^bold>| = n\ lcp_len' ndef not_less_Least + using P_def le_antisym \\<^bold>|p\<^bold>| = n\ lcp_len' ndef not_less_Least by metis from this[folded lcp_pref_conv] have "h\<^sub>m q = h\<^sub>m (q \\<^sub>p s')" - using \z \ g\<^sub>m (p \\<^sub>p r') = z' \ h\<^sub>m (q \\<^sub>p s')\ \z \ g\<^sub>m p = z' \ h\<^sub>m q\ - by force - thus "q \p s'" - using marked.h.code_morph_code lcp_pref_conv by metis + using \z \ g\<^sub>m (p \\<^sub>p r') = z' \ h\<^sub>m (q \\<^sub>p s')\ \z \ g\<^sub>m p = z' \ h\<^sub>m q\ + by force + thus "q \p s'" + using hm.code_morph_code lcp_pref_conv by metis qed thus thesis - using \z \ g\<^sub>m p = z' \ h\<^sub>m q\ that by blast + using \z \ g\<^sub>m p = z' \ h\<^sub>m q\ that by blast qed lemma two_equals: assumes "g r = h r" and "g s = h s" and "\ r \ s" shows "g (r \\<^sub>p s) \ \\<^sub>g = h (r \\<^sub>p s) \ \\<^sub>h" - unfolding g.not_comp_lcp[OF \\ r \ s\] h.not_comp_lcp[OF \\ r \ s\] g.morph h.morph assms.. + unfolding g.not_comp_lcp[OF \\ r \ s\] h.not_comp_lcp[OF \\ r \ s\] g.morph h.morph assms.. lemma solution_sing_len_diff: assumes "g \ h" and "g s = h s" and "set s = binUNIV" shows "\<^bold>|g [c]\<^bold>| \ \<^bold>|h [c]\<^bold>|" proof (rule solution_sing_len_cases[OF \set s = binUNIV\ \g s = h s\ \g \ h\]) 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>| \ \<^bold>|h [c]\<^bold>|" + show "\<^bold>|g [c]\<^bold>| \ \<^bold>|h [c]\<^bold>|" by (rule bin_swap_exhaust[of c a]) (use less in force)+ qed lemma alphas_pref: assumes "\<^bold>|\\<^sub>h\<^bold>| \ \<^bold>|\\<^sub>g\<^bold>|" and "g r =\<^sub>m h s" shows "\\<^sub>h \p \\<^sub>g" proof- - have "h s \ \" - using h.nemp_to_nemp min_coinD'[OF \g r =\<^sub>m h s\] by force + have "s \ \" and "r \ \" + using min_coinD'[OF \g r =\<^sub>m h s\] by force+ from - root_ruler[OF h.bin_lcp_pref_all[of s] g.bin_lcp_pref_all[of r, folded min_coinD[OF \g r =\<^sub>m h s\, symmetric]] this] + root_ruler[OF h.bin_lcp_spref_all[OF \s \ \\] g.bin_lcp_spref_all[OF \r \ \\, unfolded min_coinD[OF \g r =\<^sub>m h s\]]] show "\\<^sub>h \p \\<^sub>g" unfolding prefix_comparable_def using ruler_le[OF self_pref _ assms(1)] by blast qed +end + +locale binary_codes_coincidence = two_binary_code_morphisms + + assumes alphas_len: "\<^bold>|\\<^sub>h\<^bold>| \ \<^bold>|\\<^sub>g\<^bold>|" and + coin_ex: "\ r s. g r =\<^sub>m h s" +begin + +lemma alphas_pref: "\\<^sub>h \p \\<^sub>g" + using alphas_pref[OF alphas_len] coin_ex by force + +definition \ where "\ \ \\<^sub>h\\<^sup>>\\<^sub>g" +definition critical_overflow ("\") where "critical_overflow \ \\<^sub>g\<^sup><\\\<^sub>h" + +lemma lcp_diff: "\\<^sub>h \ \ = \\<^sub>g" + unfolding \_def lq_pref using lq_pref[OF alphas_pref]. + +lemma solution_marked_version_conv: "g r = h s \ \ \ g\<^sub>m r = h\<^sub>m s \ \ " + unfolding cancel[of \\<^sub>h "\ \ g\<^sub>m r" "h\<^sub>m s \ \", symmetric] + unfolding lassoc lcp_diff h.marked_version_conjugates g.marked_version_conjugates + unfolding rassoc lcp_diff cancel_right.. + +end + +locale binary_code_coincidence_sym = two_binary_code_morphisms + + assumes + coin_ex: "\ r s. g r =\<^sub>m h s" +begin + +lemma coinE: obtains u v where "g u =\<^sub>m h v" and "h v =\<^sub>m g u" + using coin_ex code.min_coin_prefE[OF min_solD[of _ g h]] min_coin_sym by metis + +definition \' where "\' = (if \<^bold>|\\<^sub>g\<^bold>| \ \<^bold>|\\<^sub>h\<^bold>| then \\<^sub>g else \\<^sub>h)" +definition g' where "g' = (if \<^bold>|\\<^sub>g\<^bold>| \ \<^bold>|\\<^sub>h\<^bold>| then (\ w. \'\\<^sup>>(g w \ \')) else (\ w. \'\\<^sup>>(h w \ \')))" +definition h' where "h' = (if \<^bold>|\\<^sub>g\<^bold>| \ \<^bold>|\\<^sub>h\<^bold>| then (\ w. \'\\<^sup>>(h w \ \')) else (\ w. \'\\<^sup>>(g w \ \')))" + +lemma shift_pref_fst: "\' \p \\<^sub>g" + unfolding \'_def +proof (cases "\<^bold>|\\<^sub>g\<^bold>| \ \<^bold>|\\<^sub>h\<^bold>|", simp) + show "\ \<^bold>|\\<^sub>g\<^bold>| \ \<^bold>|\\<^sub>h\<^bold>| \ (if \<^bold>|\\<^sub>g\<^bold>| \ \<^bold>|\\<^sub>h\<^bold>| then \\<^sub>g else \\<^sub>h) \p \\<^sub>g" + using alphas_pref coinE by fastforce +qed + +interpretation gshift: binary_code_morphism_shift g \' + using shift_pref_fst by unfold_locales + +interpretation swap: two_binary_code_morphisms h g + by (simp add: swap_two_binary_code_morphisms) + +lemma shift_pref_snd: "\' \p \\<^sub>h" + unfolding \'_def +proof (cases "\ \<^bold>|\\<^sub>g\<^bold>| \ \<^bold>|\\<^sub>h\<^bold>|", simp_all) + show "\<^bold>|\\<^sub>g\<^bold>| \ \<^bold>|\\<^sub>h\<^bold>| \ \\<^sub>g \p \\<^sub>h" + using swap.alphas_pref[OF _ coinE] by blast +qed + +interpretation hshift: binary_code_morphism_shift h \' + using shift_pref_snd by unfold_locales + +lemma shifted_eq_conv:"g r = h s \ g' r = h' s" + oops + +lemma shifted_eq_conv:"g r = h r \ g' r = h' r" +proof- + have "g r = h r \ \'\\<^sup>>(g r \ \') = \'\\<^sup>>(h r \ \')" + using cancel_right lq_pref gshift.shift_pref_all hshift.shift_pref_all by metis + thus "g r = h r \ g' r = h' r" + unfolding g'_def h'_def + by (cases "\<^bold>|\\<^sub>g\<^bold>| \ \<^bold>|\\<^sub>h\<^bold>|", presburger) + fastforce +qed + +lemma shifted_eq_conv':"g = h \ g' = h'" + using shifted_eq_conv by fastforce + +interpretation shifted_g: binary_code_morphism "(\ w. \'\\<^sup>>(g w \ \'))" + using gshift.shifted.binary_code_morphism_axioms[unfolded gshift.shifted_f_def]. + +interpretation shifted_h: binary_code_morphism "(\ w. \'\\<^sup>>(h w \ \'))" + using hshift.shifted.binary_code_morphism_axioms[unfolded hshift.shifted_f_def]. + +lemma shifted_min_sol_conv: "r \ g =\<^sub>M h \ r \ g' =\<^sub>M h'" + unfolding min_sol_def using shifted_eq_conv by blast + +lemma shifted_not_triv: "g = h \ g' = h'" + using shifted_eq_conv by fastforce + +sublocale shifted: two_binary_code_morphisms g' h' +proof- + interpret g': binary_code_morphism g' + unfolding g'_def using shifted_g.binary_code_morphism_axioms shifted_h.binary_code_morphism_axioms by presburger + interpret h': binary_code_morphism h' + unfolding h'_def using shifted_g.binary_code_morphism_axioms shifted_h.binary_code_morphism_axioms by presburger + show "two_binary_code_morphisms g' h'".. +qed + +lemma shifted_fst_lcp_emp: "shifted.g.bin_code_lcp = \" + unfolding bin_lcp_def +proof (cases "\<^bold>|\\<^sub>g\<^bold>| \ \<^bold>|\\<^sub>h\<^bold>|") + assume "\<^bold>|\\<^sub>g\<^bold>| \ \<^bold>|\\<^sub>h\<^bold>|" + hence *: "\' = \\<^sub>g" "g' = (\ w. \'\\<^sup>>(g w \ \'))" + unfolding \'_def g'_def by simp_all + have "g\<^sub>m \ \ g\<^sub>m \ \\<^sub>p g\<^sub>m \ \ g\<^sub>m \ = \" + using gm.marked_lcp_emp unfolding bin_lcp_def. + thus "g' \ \ g' \ \\<^sub>p g' \ \ g' \ = \" + unfolding * g.marked_version_def. +next + assume "\ \<^bold>|\\<^sub>g\<^bold>| \ \<^bold>|\\<^sub>h\<^bold>|" + hence c: "\' = \\<^sub>h" "g' = (\ w. \'\\<^sup>>(h w \ \'))" + unfolding \'_def g'_def by simp_all + have "h\<^sub>m \ \ h\<^sub>m \ \\<^sub>p h\<^sub>m \ \ h\<^sub>m \ = \" + using hm.marked_lcp_emp unfolding bin_lcp_def. + thus "g' \ \ g' \ \\<^sub>p g' \ \ g' \ = \" + unfolding c h.marked_version_def. +qed + +lemma shifted_alphas: assumes le: "\<^bold>|\\<^sub>g\<^bold>| \ \<^bold>|\\<^sub>h\<^bold>|" + shows "\' \ shifted.g.bin_code_lcp = \\<^sub>g" and "\' \ shifted.h.bin_code_lcp = \\<^sub>h" +proof- + have c: "\' = \\<^sub>g" "g' = (\ w. \'\\<^sup>>(g w \ \'))" "h' = (\ w. \'\\<^sup>>(h w \ \'))" + using le unfolding \'_def g'_def h'_def by simp_all + interpret binary_codes_coincidence h g + proof + show "\r s. h r =\<^sub>m g s" + using coin_ex[unfolded min_coin_sym_iff[of g]] by blast + qed fact + show "\' \ shifted.g.bin_code_lcp = \\<^sub>g" + unfolding c + unfolding bin_lcp_def[of "g' \", unfolded c] lcp_ext_left[symmetric] + unfolding lassoc lq_pref[OF g.bin_lcp_pref_all] + unfolding rassoc lq_pref[OF g.bin_lcp_pref_all] + unfolding lcp_ext_right_conv[OF g.non_comp_morph[of bina], unfolded binA_simps rassoc] + unfolding bin_lcp_def.. + from pref_prod_pref[OF pref_trans[OF alphas_pref h.bin_lcp_pref_all] alphas_pref] + have pref_all: "\\<^sub>g \p h w \ \\<^sub>g" for w. + show "\' \ shifted.h.bin_code_lcp = \\<^sub>h" + unfolding c + unfolding bin_lcp_def[of "h' \", unfolded c] lcp_ext_left[symmetric] + unfolding lassoc lq_pref[OF pref_all] + unfolding rassoc lq_pref[OF pref_all] + unfolding lcp_ext_right_conv[OF h.non_comp_morph[of bina], unfolded binA_simps rassoc] + unfolding bin_lcp_def.. +qed + +interpretation swapped: binary_code_coincidence_sym h g +proof + show "\r s. h r =\<^sub>m g s" + using coin_ex[unfolded min_coin_sym_iff[of g]] by blast +qed + +lemma eq_len_eq_conv: "\\<^sub>g = \\<^sub>h \ \<^bold>|\\<^sub>g\<^bold>| = \<^bold>|\\<^sub>h\<^bold>|" +proof + show "\\<^sub>g = \\<^sub>h" if "\<^bold>|\\<^sub>g\<^bold>| = \<^bold>|\\<^sub>h\<^bold>|" + using swap.alphas_pref[OF eq_imp_le[OF that]] alphas_pref[OF eq_imp_le[OF that[symmetric]]] + using coinE[of "\\<^sub>g = \\<^sub>h"] by fastforce +qed simp + +lemma shift_swapped: "swapped.\' = \'" + unfolding \'_def swapped.\'_def using eq_len_eq_conv by fastforce + +lemma morphs_swapped: assumes "\<^bold>|\\<^sub>g\<^bold>| \ \<^bold>|\\<^sub>h\<^bold>|" shows "swapped.g' = g'" "swapped.h' = h'" + unfolding g'_def swapped.g'_def h'_def swapped.h'_def shift_swapped using assms by fastforce+ + +lemma morphs_swapped': assumes "\<^bold>|\\<^sub>g\<^bold>| = \<^bold>|\\<^sub>h\<^bold>|" shows "swapped.g' = h'" "swapped.h' = g'" + unfolding g'_def swapped.g'_def h'_def swapped.h'_def shift_swapped using assms by fastforce+ + +lemma shifted_lcp_len_eq: "\<^bold>|shifted.g.bin_code_lcp\<^bold>| = \<^bold>|shifted.h.bin_code_lcp\<^bold>| \ \<^bold>|\\<^sub>g\<^bold>| = \<^bold>|\\<^sub>h\<^bold>|" and + shifted_lcp_len_le: "\<^bold>|shifted.g.bin_code_lcp\<^bold>| \ \<^bold>|shifted.h.bin_code_lcp\<^bold>|" + unfolding atomize_conj +proof (cases) + assume le: "\<^bold>|\\<^sub>g\<^bold>| \ \<^bold>|\\<^sub>h\<^bold>|" + note shifted_alphas[OF this] + from lenarg[OF this(1)] lenarg[OF this(2)] + show "(\<^bold>|shifted.g.bin_code_lcp\<^bold>| = \<^bold>|shifted.h.bin_code_lcp\<^bold>| \ \<^bold>|\\<^sub>g\<^bold>| = \<^bold>|\\<^sub>h\<^bold>|) \ \<^bold>|shifted.g.bin_code_lcp\<^bold>| \ \<^bold>|shifted.h.bin_code_lcp\<^bold>|" + unfolding lenmorph using le by fastforce+ +next + assume "\ \<^bold>|\\<^sub>g\<^bold>| \ \<^bold>|\\<^sub>h\<^bold>|" + hence le: "\<^bold>|\\<^sub>h\<^bold>| \ \<^bold>|\\<^sub>g\<^bold>|" by fastforce + note swapped.shifted_alphas[OF this] + note lens = lenarg[OF this(1)] lenarg[OF this(2)] + show "(\<^bold>|shifted.g.bin_code_lcp\<^bold>| = \<^bold>|shifted.h.bin_code_lcp\<^bold>| \ \<^bold>|\\<^sub>g\<^bold>| = \<^bold>|\\<^sub>h\<^bold>|) \ \<^bold>|shifted.g.bin_code_lcp\<^bold>| \ \<^bold>|shifted.h.bin_code_lcp\<^bold>|" + proof (cases) + assume eq: "\<^bold>|\\<^sub>g\<^bold>| = \<^bold>|\\<^sub>h\<^bold>|" + show "(\<^bold>|shifted.g.bin_code_lcp\<^bold>| = \<^bold>|shifted.h.bin_code_lcp\<^bold>| \ \<^bold>|\\<^sub>g\<^bold>| = \<^bold>|\\<^sub>h\<^bold>|) \ \<^bold>|shifted.g.bin_code_lcp\<^bold>| \ \<^bold>|shifted.h.bin_code_lcp\<^bold>|" + using lens eq unfolding shift_swapped lenmorph bin_lcp_def morphs_swapped'[OF eq] by linarith+ + next + assume neq: "\<^bold>|\\<^sub>g\<^bold>| \ \<^bold>|\\<^sub>h\<^bold>|" + from lens + show "(\<^bold>|shifted.g.bin_code_lcp\<^bold>| = \<^bold>|shifted.h.bin_code_lcp\<^bold>| \ \<^bold>|\\<^sub>g\<^bold>| = \<^bold>|\\<^sub>h\<^bold>|) \ \<^bold>|shifted.g.bin_code_lcp\<^bold>| \ \<^bold>|shifted.h.bin_code_lcp\<^bold>|" + using le unfolding shift_swapped lenmorph bin_lcp_def morphs_swapped[OF neq] by fastforce+ + qed +qed + + end + + + + + + + + + +locale two_marked_binary_morphisms = two_marked_morphisms g h + for g h :: "binA list \ 'a list" +begin + +sublocale two_binary_code_morphisms g h .. + +lemma not_comm_im: assumes "g \ h" and "g s = h s" and "s \ \" + and "hd s = a" and "set s = binUNIV" +shows "g[a] \ h [a] \ h[a] \ g[a]" +proof (rule notI) + assume comm: "g[a] \ h [a] = h[a] \ g[a]" + from hd_im_comm_eq[OF \g s = h s\ \s \ \\] comm + have "g [a] = h [a]" + unfolding core_def \hd s = a\ by blast + thus False + using len_ims_sing_neq[OF \g s = h s\ \g \ h\ \set s = binUNIV\] by metis +qed + +lemma sol_set_not_com_hd: + assumes + morphs_neq: "g \ h" and + sol: "g s = h s" and + sol_set: "set s = binUNIV" + shows "g ([hd s]) \ h ([hd s]) \ h ([hd s]) \ g ([hd s])" +proof + assume comm: "g [hd s] \ h [hd s] = h [hd s] \ g [hd s]" + obtain n s' where s: "[hd s]\<^sup>@Suc n \ [1 - hd s] \ s' = s" + using bin_distinct_letter[OF sol_set]. + have "[hd s] \<^sup>@ Suc n \ [1 - hd s] \ s' \ \" by blast + from hd_im_comm_eq[OF _ this] + have "g [hd s] = h [hd s]" + unfolding core_def s comm using sol by blast + thus False + using len_ims_sing_neq[OF sol \g \ h\ sol_set, of "hd s"] by argo +qed + +sublocale g: marked_binary_morphism g + using g.marked_marked g.marked_morphism_axioms gm.marked_binary_morphism_axioms by auto + +sublocale h: marked_binary_morphism h + using h.marked_marked h.marked_morphism_axioms hm.marked_binary_morphism_axioms by auto + +sublocale revs: two_binary_code_morphisms "rev_map g" "rev_map h" + using revs_two_binary_code_morphisms. end section \Two marked binary morphisms with blocks\ -locale two_binary_marked_morphisms = two_marked_morphisms g h - for g h :: "binA list \ '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 + + + +locale two_binary_marked_blocks = two_marked_binary_morphisms + assumes both_blocks: "\ 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]. + +sublocale sucs: two_marked_binary_morphisms suc_fst suc_snd + using sucs_marked_morphs[OF both_blocks, folded two_marked_binary_morphisms_def]. + +sublocale sucs_enc: two_marked_binary_morphisms suc_fst' suc_snd' + using encoded_sucs[OF both_blocks, folded two_marked_binary_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" + 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" + 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] \f suc_fst ([a] \ [1-a])" proof- have *: "suc_fst ([a] \ [1 - a]) = [a] \ tl (suc_fst [a]) \ [1-a] \ 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 + (blast+) +qed lemma blocks_all_letters_snd: "[b] \f suc_snd ([a] \ [1-a])" proof- have *: "suc_snd ([a] \ [1 - a]) = [hd (suc_snd [a])] \ tl (suc_snd [a]) \ [hd (suc_snd [1-a])] \ 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 + 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 + proof (cases rule: neq_exhaust[OF sucs.h.bin_marked_sing, of b a]) + assume b: "b = hd (suc_snd [a])" + show ?thesis + unfolding b * by blast + next + assume b: "b = hd (suc_snd [1-a])" + show ?thesis + unfolding b * by blast + qed +qed lemma lcs_suf_blocks_fst: "g.bin_code_lcs \s g (suc_fst ([a] \ [1-a]))" - using revs.g.bin_lcp_pref''[reversed] g.bin_lcp_pref'' blocks_all_letters_fst by simp + 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 \s h (suc_snd ([a] \ [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 \s h.bin_code_lcs \ h sucs.h.bin_code_lcs" +lemma lcs_fst_suf_snd: "g.bin_code_lcs \s h.bin_code_lcs \ h sucs.h.bin_code_lcs" proof- have "g.bin_code_lcs \s g (suc_fst [a] \ suc_fst [1-a])" for a using lcs_suf_blocks_fst[of a] - unfolding binsimp sucs.g.morph. - have "g.bin_code_lcs \s g (suc_fst \ \ suc_fst \)" and "g.bin_code_lcs \s g (suc_fst \ \ suc_fst \)" - using lcs_suf_blocks_fst[of bin0] lcs_suf_blocks_fst[of bin1] - unfolding binsimp sucs.g.morph. - hence "g.bin_code_lcs \s h (suc_snd \ \ suc_snd \)" and "g.bin_code_lcs \s h (suc_snd \ \ suc_snd \)" + unfolding binA_simps sucs.g.morph. + have "g.bin_code_lcs \s g (suc_fst \ \ suc_fst \)" and "g.bin_code_lcs \s g (suc_fst \ \ suc_fst \)" + using lcs_suf_blocks_fst[of bina] lcs_suf_blocks_fst[of binb] + unfolding binA_simps sucs.g.morph. + hence "g.bin_code_lcs \s h (suc_snd \ \ suc_snd \)" and "g.bin_code_lcs \s h (suc_snd \ \ suc_snd \)" 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 \s h.bin_code_lcs \ h (suc_snd \ \ suc_snd \)" and "g.bin_code_lcs \s h.bin_code_lcs \ h (suc_snd \ \ suc_snd \)". - hence "g.bin_code_lcs \s h.bin_code_lcs \ h (suc_snd \ \ suc_snd \) \\<^sub>s h.bin_code_lcs \ h (suc_snd \ \ suc_snd \)" - using suf_lcs_iff by blast + have "g.bin_code_lcs \s h.bin_code_lcs \ h (suc_snd \ \ suc_snd \)" and "g.bin_code_lcs \s h.bin_code_lcs \ h (suc_snd \ \ suc_snd \)". + hence "g.bin_code_lcs \s h.bin_code_lcs \ h (suc_snd \ \ suc_snd \) \\<^sub>s h.bin_code_lcs \ h (suc_snd \ \ suc_snd \)" + using suf_lcs_iff by blast thus "g.bin_code_lcs \s h.bin_code_lcs \ 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 \\<^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 + 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 +section \Binary primitivity preserving morphism given by a pair of words\ + +definition bin_prim :: "'a list \ 'a list \ bool" + where "bin_prim x y \ primitivity_preserving_morphism (bin_morph_of x y)" + +lemma bin_prim_code: + assumes "bin_prim x y" + shows "x \ y \ y \ x" +proof - + have "inj (bin_morph_of x y)" + using \bin_prim x y\ primitivity_preserving_morphism.code_morph + by (simp add: bin_prim_def) + then have "(bin_morph_of x y) (\ \ \) \ (bin_morph_of x y) (\ \ \)" + by (blast dest: injD) + then show "x \ y \ y \ x" + by (simp add: bin_morph_of_def) +qed + +subsection \Translating to to list concatenation\ + +lemma bin_concat_prim_pres_noner1: + assumes "x \ y" + and prim_pres: "\ ws. ws \ lists {x,y} \ 2 \ \<^bold>|ws\<^bold>| \ primitive ws \ primitive (concat ws)" + shows "x \ \" +proof + assume "x = \" + with \x \ y\ have "y \ \" + by blast + have "primitive [x, y, y]" + using prim_abk[OF \x \ y\, of 2] by simp + with \x \ y\ have "primitive (concat [x, y, y])" + by (intro prim_pres) simp_all + then show False + by (simp add: \x = \\ eq_append_not_prim) +qed + +lemma bin_concat_prim_pres_noner: + assumes "x \ y" + and prim_pres: "\ ws. ws \ lists {x,y} \ 2 \ \<^bold>|ws\<^bold>| \ primitive ws \ primitive (concat ws)" + shows "nonerasing_morphism (bin_morph_of x y)" +proof (intro morphism.nonerI bin_morph_of_morph) + fix a + have "x \ \" and "y \ \" + using \x \ y\ prim_pres + by (fact bin_concat_prim_pres_noner1, intro bin_concat_prim_pres_noner1) + (unfold insert_commute[of x y] eq_commute[of x y]) + then show "(bin_morph_of x y)\<^sup>\ a \ \" + by (simp add: bin_morph_of_def core_def) +qed + +lemma bin_prim_concat_prim_pres_conv: + assumes "x \ y" + shows "bin_prim x y \ (\ws \ lists {x,y}. 2 \ \<^bold>|ws\<^bold>| \ primitive ws \ primitive (concat ws))" + (is "_ \ ?condition") +proof - + define f where "f = (\a. (if a = bina then x else y))" + have "inj f" + using \x \ y\ + by (intro linorder_injI) (simp add: less_finite_2_def f_def) + moreover have "f ` UNIV = {x, y}" + by (simp add: f_def insert_commute) + ultimately have "bij_betw f UNIV {x, y}" + unfolding bij_betw_def.. + then have bij: "bij_betw (map f) (lists UNIV) (lists {x, y})" + by (fact bij_lists) + have concat_map_f: "concat (map f w) = bin_morph_of x y w" for w + by (simp add: bin_morph_of_def f_def) + have "?condition \ nonerasing_morphism (bin_morph_of x y)" + by (simp add: \x \ y\ bin_concat_prim_pres_noner) + then show "bin_prim x y \ ?condition" + unfolding bin_prim_def primitivity_preserving_morphism_def primitivity_preserving_morphism_axioms_def + unfolding bij_betw_ball[OF bij] prim_map_iff[OF \inj f\] concat_map_f + by auto +qed + +lemma bin_prim_concat_prim_pres: + assumes "bin_prim x y" + shows "ws \ lists {x, y} \ 2 \ \<^bold>|ws\<^bold>| \ primitive ws \ primitive (concat ws)" + using bin_prim_code[OF \bin_prim x y\] \bin_prim x y\ bin_prim_concat_prim_pres_conv[of x y] + by (cases "x = y") blast+ + +lemma bin_prim_altdef1: + "bin_prim x y \ + (x \ y) \ (\ws \ lists {x,y}. 2 \ \<^bold>|ws\<^bold>| \ primitive ws \ primitive (concat ws))" + using bin_prim_code[of x y] bin_prim_concat_prim_pres_conv[of x y] + by blast + +lemma bin_prim_altdef2: + "bin_prim x y \ + (x \ y \ y \ x) \ (\ws \ lists {x,y}. 2 \ \<^bold>|ws\<^bold>| \ primitive ws \ primitive (concat ws))" + using bin_prim_code[of x y] bin_prim_concat_prim_pres_conv[of x y] + by blast + +subsection \Basic properties of @{term bin_prim}\ + +lemma bin_prim_irrefl: "\ bin_prim x x" + using bin_prim_code by blast + +lemma bin_prim_symm [sym]: "bin_prim x y \ bin_prim y x" + using bin_prim_concat_prim_pres_conv[of x y] bin_prim_concat_prim_pres_conv[of y x] + unfolding eq_commute[of y x] insert_commute[of y x] + by blast + +lemma bin_prim_commutes: "bin_prim x y \ bin_prim y x" + by (blast intro: bin_prim_symm) + + end diff --git a/thys/Combinatorics_Words/Border_Array.thy b/thys/Combinatorics_Words/Border_Array.thy --- a/thys/Combinatorics_Words/Border_Array.thy +++ b/thys/Combinatorics_Words/Border_Array.thy @@ -1,567 +1,579 @@ (* Title: Border Array - File: CoW.Border_Array + File: Combinatorics_Words.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 \Auxiliary lemmas on suffix and border extension\ -lemma border_ConsD: assumes "b#x \b a#w" - shows "a = b" and - "x \ \ \ x \b w" and +lemma border_ConsD: assumes "b#x \b a#w" + shows "a = b" and + "x \ \ \ x \b w" and border_ConsD_neq: "x \ w" and border_ConsD_pref: "x \p w" and border_ConsD_suf: "x \s w" proof- show "a = b" using borderD_pref[OF assms] by force show "x \ w" and "x \p w" and "x \s w" using borderD_neq[OF assms, unfolded \a = b\] borderD_pref[OF assms, unfolded Cons_prefix_Cons] suffix_ConsD2[OF borderD_suf[OF assms]] by force+ thus "x \ \ \ x \b w" unfolding border_def by blast qed lemma ext_suf_Cons: "Suc i + \<^bold>|u\<^bold>| = \<^bold>|w\<^bold>| \ u \s w \ (w!i)#u \s (w!i)#w" proof- assume "Suc i + \<^bold>|u\<^bold>| = \<^bold>|w\<^bold>|" and "u \s w" hence "u = drop (Suc i) w" - unfolding suf_def using \Suc i + \<^bold>|u\<^bold>| = \<^bold>|w\<^bold>|\ by auto + unfolding suffix_def using \Suc i + \<^bold>|u\<^bold>| = \<^bold>|w\<^bold>|\ by auto have "i < \<^bold>|w\<^bold>|" using \Suc i + \<^bold>|u\<^bold>| = \<^bold>|w\<^bold>|\ by auto from id_take_nth_drop[OF this, folded \u = drop (Suc i) w\] show "w ! i # u \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) \s drop (Suc i) w" and "w ! i = w ! (\<^bold>|w\<^bold>| - Suc k)" shows "take (Suc k) (drop i w) \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 \Suc (k + i) < \<^bold>|w\<^bold>|\ by (simp add: Suc_diff_Suc) have "\<^bold>|take k (drop (Suc i) w)\<^bold>| = k" using \Suc (k + i) < \<^bold>|w\<^bold>|\ 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 \\<^bold>|take k (drop (Suc i) w)\<^bold>| = k\ \Suc (\<^bold>|w\<^bold>| - Suc i - Suc k) = \<^bold>|w\<^bold>| - Suc(i+k)\ using \Suc (k + i) < \<^bold>|w\<^bold>|\ by simp hence "\<^bold>|drop (Suc (\<^bold>|w\<^bold>| - Suc i - k)) (drop i w)\<^bold>| = k" using \i < \<^bold>|w\<^bold>|\ by fastforce have "\<^bold>|w\<^bold>| - Suc i - k < \<^bold>|drop i w\<^bold>|" by (metis Suc_diff_Suc \i < \<^bold>|w\<^bold>|\ diff_less_Suc length_drop) have "(drop i w)!(\<^bold>|w\<^bold>| - Suc i - k) = w ! i" using \Suc (k + i) < \<^bold>|w\<^bold>|\ \w ! i = w ! (\<^bold>|w\<^bold>| - Suc k)\ by auto have "take (Suc k) (drop i w) = w!i#take k (drop (Suc i) w)" using Cons_nth_drop_Suc[OF \i < \<^bold>|w\<^bold>|\] 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 \\<^bold>|take k (drop (Suc i) w)\<^bold>| = k\ \take k (drop (Suc i) w) \s drop (Suc i) w\ suf_drop_conv length_drop by metis with id_take_nth_drop[OF \\<^bold>|w\<^bold>| - Suc i - k < \<^bold>|drop i w\<^bold>|\] show ?thesis unfolding \(drop i w)!(\<^bold>|w\<^bold>| - Suc i - k) = w ! i\ \take (Suc k) (drop i w) = w!i#take k (drop (Suc i) w)\ - unfolding suf_def by auto + unfolding suffix_def by auto qed lemma ext_border_Cons: "Suc i + \<^bold>|u\<^bold>| = \<^bold>|w\<^bold>| \ u \b w \ (w!i)#u \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 \b (a#w)" shows "\<^bold>|v\<^bold>| \ Suc \<^bold>|u\<^bold>|" proof- have "v \ \" using \v \b (a#w)\ by simp then obtain v' where "v = a#v'" using borderD_pref[OF \v \b (a#w)\, unfolded prefix_Cons] by blast show "\<^bold>|v\<^bold>| \ Suc \<^bold>|u\<^bold>|" - proof (cases "v' = \", simp add: \v = a#v'\) + proof (cases "v' = \") assume "v' \ \" have "w \ \" using borderedI[OF \v \b (a#w)\] sing_not_bordered[of a] by blast have "v' \b w" using border_ConsD(2)[OF \v \b (a#w)\[unfolded \v = a # v'\] \v' \ \\]. thus "\<^bold>|v\<^bold>| \ Suc \<^bold>|u\<^bold>|" unfolding \v = a # v'\ length_Cons Suc_le_mono using \max_borderP u w\[unfolded max_borderP_def] prefix_length_le by blast - qed + qed (simp add: \v = a#v'\) qed section \Computing the Border Array\ text\The computation is a special case of the Knuth-Morris-Pratt algorithm.\ text\ \<^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) + 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; +\<^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 +\<^item> if bord was 0 and the comparison failed, the word is unbordered \ fun KMP_arr :: "'a list \ nat list \ nat \ nat \ nat list" - and KMP_bord :: "'a list \ nat list \ nat \ nat \ nat" - and KMP_pos :: "'a list \ nat list \ nat \ nat \ 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 + where "KMP_arr _ arr _ 0 = arr" | + "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 (if (arr!(\<^bold>|w\<^bold>| - (Suc i) - bord)) < bord \ \always True, for sake of termination\ + then arr else undefined#arr \ \else: dummy termination condition\ - ) - ) - )" | - "KMP_bord w arr bord (Suc i) = - (if w!i = w!(\<^bold>|w\<^bold>| - (Suc bord)) + ) + ) + )" + +fun KMP_bord :: "'a list \ nat list \ nat \ nat \ nat" + where "KMP_bord _ _ bord 0 = bord" | + "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 \ \else: dummy termination condition\ - ) - ) - )" | - "KMP_pos w arr bord (Suc i) = - (if w!i = w!(\<^bold>|w\<^bold>| - (Suc bord)) + else (if (arr!(\<^bold>|w\<^bold>| - (Suc i) - bord)) < bord \ \always True, for sake of termination\ + then arr!(\<^bold>|w\<^bold>| - (Suc i) - bord) + else 0 \ \dummy termination condition\ + ) + ) + )" + +fun KMP_pos :: "'a list \ nat list \ nat \ nat \ nat" + where + "KMP_pos _ _ _ 0 = 0" | + "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 (if (arr!(\<^bold>|w\<^bold>| - (Suc i) - bord)) < bord \ \always True, for sake of termination\ + then Suc i else i \ \else: dummy termination condition\ - ) - ) - )" + ) + ) + )" + +thm prod_cases + nat.exhaust + prod.exhaust + prod_cases3 function KMP :: "'a list \ nat list \ nat \ nat \ 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))" + "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 +termination by (relation "measures [\(_, _ , compar, pos). pos,\(_, _ , 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 "\ 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 + by (induct w arr bord pos rule: KMP.induct, auto) 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,5,3,5,5::nat] [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 \Verification of the computation\ definition KMP_valid :: "'a list \ nat list \ nat \ nat \ bool" where "KMP_valid w arr bord pos = (\<^bold>|arr\<^bold>| + pos = \<^bold>|w\<^bold>| \ - \ \bord is the length of a border of (drop pos w), or 0\ - pos + bord < \<^bold>|w\<^bold>| \ + \ \bord is the length of a border of (drop pos w), or 0\ + pos + bord < \<^bold>|w\<^bold>| \ take bord (drop pos w) \p (drop pos w) \ - take bord (drop pos w) \s (drop pos w) \ + take bord (drop pos w) \s (drop pos w) \ \ \... and no longer border can be extended\ - (\ v. v \b w!(pos - 1)#(drop pos w) \ \<^bold>|v\<^bold>| \ Suc bord) \ - \ \the array gives maximal border lengths of corresponding suffixes\ + (\ v. v \b w!(pos - 1)#(drop pos w) \ \<^bold>|v\<^bold>| \ Suc bord) \ + \ \the array gives maximal border lengths of corresponding suffixes\ (\ k < \<^bold>|arr\<^bold>|. max_borderP (take (arr!k) (drop (pos + k) w)) (drop (pos + k) w)) )" lemma " KMP_valid w arr bord pos \ w \ \" 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 \ \" shows "KMP_valid w [0] 0 (\<^bold>|w\<^bold>|-1)" -proof (unfold KMP_valid_def, intro conjI) +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 \w \ \\ by simp show "take 0 (drop (\<^bold>|w\<^bold>| - 1) w) \p drop (\<^bold>|w\<^bold>| - 1) w" by simp show "take 0 (drop (\<^bold>|w\<^bold>| - 1) w) \s drop (\<^bold>|w\<^bold>| - 1) w" by simp show "\v. v \b w ! (\<^bold>|w\<^bold>| - 1 - 1) # drop (\<^bold>|w\<^bold>| - 1) w \ \<^bold>|v\<^bold>| \ Suc 0" proof (rule allI, rule impI) fix v assume b: "v \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 \\<^bold>|[0]\<^bold>| + (\<^bold>|w\<^bold>| - 1) = \<^bold>|w\<^bold>|\ by auto from border_len(3)[OF b, unfolded this] show "\<^bold>|v\<^bold>| \ Suc 0" using border_len(3)[OF b] by simp qed have "\<^bold>|w\<^bold>| - Suc 0 = \<^bold>|butlast w\<^bold>|" by simp + have all: "\v. v \b [last w] \ v \p \" + by (meson borderedI sing_not_bordered) have "butlast w \ [last w] = w" by (simp add: assms) hence last: "drop (\<^bold>|w\<^bold>| - Suc 0) w = [last w]" - unfolding \\<^bold>|w\<^bold>| - Suc 0 = \<^bold>|butlast w\<^bold>|\ using drop_pref by metis - show "\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 "\v. v \b [last w] \ v \p \" - by (meson borderedI sing_not_bordered) - thus "\ \p [last w] \ \ \s [last w] \ (\ = [last w] \ [last w] = \) \ (\v. v \b [last w] \ v \p \)" - by simp - qed + unfolding \\<^bold>|w\<^bold>| - Suc 0 = \<^bold>|butlast w\<^bold>|\ using drop_pref by metis + hence "max_borderP \ (drop (\<^bold>|w\<^bold>| - Suc 0) w)" + unfolding max_borderP_def using all by simp + thus "\k<\<^bold>|[0]\<^bold>|. max_borderP (take ([0] ! k) (drop (\<^bold>|w\<^bold>| - 1 + k) w)) (drop (\<^bold>|w\<^bold>| - 1 + k) w)" + by simp qed -lemma KMP_valid_step: assumes "KMP_valid w arr bord (Suc i)" +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- \ \Consequences of the assumption\ have all_k: "\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) \p drop (Suc i) w" and bord_suf: "take bord (drop (Suc i) w) \s drop (Suc i) w" and up_bord: "\ v. v \b w!i#(drop (Suc i) w) \ \<^bold>|v\<^bold>| \ Suc bord" and all_k_neq0: "\ k. k < \<^bold>|arr\<^bold>| \ take (arr ! k) (drop (Suc i + k) w) = drop (Suc i + k) w \ drop (Suc i + k) w = \" and all_k_pref: "\ k. k < \<^bold>|arr\<^bold>| \ take (arr ! k) (drop (Suc i + k) w) \p drop (Suc i + k) w" and all_k_suf: "\ k. k < \<^bold>|arr\<^bold>| \ take (arr ! k) (drop (Suc i + k) w) \s drop (Suc i + k) w" and all_k_v: "\ k v. k < \<^bold>|arr\<^bold>| \ v \b drop (Suc i + k) w \ v \p take (arr ! k) (drop (Suc i + k) w)" - using assms[unfolded KMP_valid_def max_borderP_def diff_Suc_1] by blast+ + using assms[unfolded KMP_valid_def max_borderP_def diff_Suc_1] by blast+ have all_k_neq: "\ k. k < \<^bold>|arr\<^bold>| \ take (arr ! k) (drop (Suc i + k) w) \ drop (Suc i + k) w" using \Suc i + bord < \<^bold>|w\<^bold>|\ \\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|\ all_k_neq0 - add.commute add_le_imp_le_left drop_all_iff le_antisym less_imp_le_nat less_not_refl2 by metis + add.commute add_le_imp_le_left drop_all_iff le_antisym less_imp_le_nat less_not_refl2 by metis - have "w \ \" + have "w \ \" using \\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|\ by auto have "Suc i < \<^bold>|w\<^bold>|" using \Suc i + bord < \<^bold>|w\<^bold>|\ by simp have pop_i: "drop i w = (w!i)# (drop (Suc i) w)" by (simp add: Cons_nth_drop_Suc Suc_lessD \Suc i < \<^bold>|w\<^bold>|\) have "drop (Suc i) w \ \" - using \Suc i < \<^bold>|w\<^bold>|\ by fastforce + using \Suc i < \<^bold>|w\<^bold>|\ by fastforce have "Suc i + (\<^bold>|w\<^bold>| - Suc i - bord) = \<^bold>|w\<^bold>| - bord" unfolding diff_right_commute[of _ _ bord] using \Suc i + bord < \<^bold>|w\<^bold>|\ 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)") + proof (cases "w ! i = w ! (\<^bold>|w\<^bold>| - Suc bord)") assume match: "w ! i = w ! (\<^bold>|w\<^bold>| - Suc bord)" \ \The current candidate is extendable\ 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 \\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|\ by auto show "i + Suc bord < \<^bold>|w\<^bold>|" using \Suc i + bord < \<^bold>|w\<^bold>|\ by auto show "take (Suc bord) (drop i w) \p drop i w" using take_is_prefix by auto show "take (Suc bord) (drop i w) \s drop i w" using \take bord (drop (Suc i) w) \s drop (Suc i) w\ ext_suf_Cons_take_drop match by blast \ \The new border array is correct\ show all_k_new: "\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) + 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" \ \old entries are valid:\ thus ?thesis using all_k by (metis Suc_less_eq \k < \<^bold>|Suc bord # arr\<^bold>|\ add.right_neutral add_Suc_shift gr0_implies_Suc list.size(4) nth_Cons_Suc) - next - assume "\ 0 < k" hence "k = 0" by simp + next + assume "\ 0 < k" hence "k = 0" by simp show ?thesis \ \the extended border is maximal:\ - proof (simp add: \k = 0\, unfold max_borderP_def, intro conjI) - show "take (Suc bord) (drop i w) = drop i w \ drop i w = \" + unfolding max_borderP_def \k = 0\ + proof (intro conjI) + show "take ((Suc bord # arr) ! 0) (drop (i + 0) w) = drop (i + 0) w \ drop (i + 0) w = \" using \i + Suc bord < \<^bold>|w\<^bold>|\ by fastforce - show "take (Suc bord) (drop i w) \p drop i w" - using \take (Suc bord) (drop i w) \p drop i w\ by blast - show "take (Suc bord) (drop i w) \s drop i w" by fact - show "\v. v \b drop i w \ v \p take (Suc bord) (drop i w)" + show "take ((Suc bord # arr) ! 0) (drop (i + 0) w) \p drop (i + 0) w" + using \take (Suc bord) (drop i w) \p drop i w\ by auto + show "take ((Suc bord # arr) ! 0) (drop (i + 0) w) \s drop (i + 0) w" + by simp fact + show "\v. v \b drop (i + 0) w \ v \p take ((Suc bord # arr) ! 0) (drop (i + 0) w)" proof (rule allI, rule impI) - fix v assume "v \b drop i w" + fix v assume "v \b drop (i + 0) w" hence "v \b drop i w" by simp from borderD_pref[OF this] up_bord[OF this[unfolded pop_i]] - (* have "v \p drop i w". *) - show "v \p take (Suc bord) (drop i w)" + show "v \p take ((Suc bord # arr) ! 0) (drop (i + 0) w)" unfolding prefix_def by force qed qed qed qed \ \the extended border is the longest candidate:\ 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 "\v. v \b w ! (i - 1) # drop i w \ \<^bold>|v\<^bold>| \ Suc (Suc bord)" - using nat_le_linear take_all take_len list.discI pop_i by metis + using nat_le_linear take_all take_len list.discI pop_i by metis qed - next + next assume mismatch: "w ! i \ w ! (\<^bold>|w\<^bold>| - Suc bord)" \ \The current candidate is not extendable\ show ?thesis proof (cases "bord = 0") assume "bord \ 0" \ \Recursion: try the maximal border of the current candidate...\ let ?k = "\<^bold>|w\<^bold>| - Suc i - bord" and ?w' = "drop (Suc i) w" have "?k < \<^bold>|arr\<^bold>|" - using \Suc i + bord < \<^bold>|w\<^bold>|\ \\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|\ \bord \ 0\ by linarith - from all_k_neq[OF this] + using \Suc i + bord < \<^bold>|w\<^bold>|\ \\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|\ \bord \ 0\ by linarith + from all_k_neq[OF this] have "arr ! ?k < bord" \ \... which is stored in the array, and is shorter\ by (simp add: \take (arr ! ?k) (drop (Suc i + ?k) w) \ drop (Suc i + ?k) w\ \Suc i + ?k = \<^bold>|w\<^bold>| - bord\ \Suc i + bord < \<^bold>|w\<^bold>|\ 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 \bord \ 0\] if_P[OF \arr ! ?k < bord\] diff_Suc_1, intro conjI) show "\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|" using \\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|\ by auto show "Suc i + arr ! ?k < \<^bold>|w\<^bold>|" using \Suc i + bord < \<^bold>|w\<^bold>|\ \arr ! ?k < bord\ by linarith - show "take (arr ! ?k) (drop (Suc i) w) \p drop (Suc i) w" + show "take (arr ! ?k) (drop (Suc i) w) \p drop (Suc i) w" using take_is_prefix by blast \ \Next goal: the new border is a suffix\ have "?old_suf \s ?w'" by (meson \Suc i + bord < \<^bold>|w\<^bold>|\ le_suf_drop less_diff_conv nat_less_le) have "\<^bold>|?old_pref\<^bold>| = bord" - using \Suc i + bord < \<^bold>|w\<^bold>|\ take_len len_after_drop nat_less_le by blast + using \Suc i + bord < \<^bold>|w\<^bold>|\ take_len len_after_drop nat_less_le by blast also have "... = \<^bold>|?old_suf\<^bold>|" - using \Suc i + bord < \<^bold>|w\<^bold>|\ by simp + using \Suc i + bord < \<^bold>|w\<^bold>|\ by simp ultimately have eq1: "?old_pref = ?old_suf" \ \bord defines a border\ - using \take bord (drop (Suc i) w) \s drop (Suc i) w\ \drop (\<^bold>|w\<^bold>| - bord) w \s drop (Suc i) w\ suf_ruler_eq_len by metis + using \take bord (drop (Suc i) w) \s drop (Suc i) w\ \drop (\<^bold>|w\<^bold>| - bord) w \s drop (Suc i) w\ suf_ruler_eq_len by metis have "\<^bold>|?new_pref\<^bold>| = arr!?k" using take_len \Suc i + bord < \<^bold>|w\<^bold>|\ \arr ! ?k < bord\ diff_diff_left by force have "take (arr ! ?k) ?old_suf \p ?old_pref" using take_is_prefix \?old_pref = ?old_suf\ by metis from pref_take[OF pref_trans[OF this take_is_prefix], unfolded \\<^bold>|?new_pref\<^bold>| = arr!?k\, symmetric] - have "take (arr ! ?k) ?old_suf = take (arr ! ?k) ?w'" + have "take (arr ! ?k) ?old_suf = take (arr ! ?k) ?w'" using take_len \arr ! ?k < bord\ \bord = \<^bold>|drop (\<^bold>|w\<^bold>| - bord) w\<^bold>|\ less_imp_le_nat by metis from all_k_suf[OF \?k < \<^bold>|arr\<^bold>|\, unfolded \Suc i + ?k = \<^bold>|w\<^bold>| - bord\] this have "take (arr ! ?k) ?w' \s ?old_suf" by simp \ \The new prefix is a suffix of the old suffix\ - with \?old_pref \s ?w'\[unfolded \?old_pref = ?old_suf\] + with \?old_pref \s ?w'\[unfolded \?old_pref = ?old_suf\] show "take (arr ! ?k) ?w' \s ?w'" using suf_trans by blast \ \Key facts about borders of the w'\ have "?old_pref \ \" using \bord \ 0\ \\<^bold>|?old_pref\<^bold>| = bord\ by force moreover have "?old_pref \ ?w'" using \Suc i + bord < \<^bold>|w\<^bold>|\ - by (intro lenarg_not, unfold length_drop \\<^bold>|take bord ?w'\<^bold>| = bord\, linarith) + by (intro lenarg_not, unfold length_drop \\<^bold>|take bord ?w'\<^bold>| = bord\, linarith) ultimately have "?old_pref \b ?w'" \ \bord is the length of a border\ - by (intro borderI[OF bord_pref bord_suf]) - + by (intro borderI[OF bord_pref bord_suf]) + \ \We want to prove that the new border is the longest candidate\ show "\v. v \b w !i # ?w' \ \<^bold>|v\<^bold>| \ Suc (arr ! ?k)" proof (rule allI,rule impI) have extendable: "w ! i # v' \b w ! i # ?w' \ v' \ \ \ \<^bold>|v'\<^bold>| \ arr ! ?k" for v' \ \First consider a border of w', which is extendable\ - proof- - assume "w!i # v' \b w!i # ?w'" and "v' \ \" + proof- + assume "w!i # v' \b w!i # ?w'" and "v' \ \" from suf_trans[OF borderD_suf[OF \w!i # v' \b w ! i # ?w'\, folded pop_i] suffix_drop] have "w!i # v' \s w". from this[unfolded suf_drop_conv, THEN nth_via_drop] mismatch have "\<^bold>|w!i # v'\<^bold>| \ Suc bord" by force with up_bord[OF \w!i # v' \b w ! i # ?w'\] have "\<^bold>|v'\<^bold>| < bord" \ \It is shorter than the old candidate border\ by simp - from border_ConsD(2)[OF \w!i # v' \b w ! i # ?w'\ \v' \ \\] + from border_ConsD(2)[OF \w!i # v' \b w ! i # ?w'\ \v' \ \\] have "v' \b ?w'". from borders_compare[OF \?old_pref \b ?w'\ this, unfolded \\<^bold>|?old_pref\<^bold>| = bord\, unfolded \?old_pref = ?old_suf\, OF \\<^bold>|v'\<^bold>| < bord\] have "v' \b ?old_suf". \ \... and therefore its border\ from prefix_length_le[OF max_borderP_D_max[OF all_k[rule_format, OF \?k < \<^bold>|arr\<^bold>|\], unfolded \Suc i + ?k = \<^bold>|w\<^bold>| - bord\, OF this]] show "\<^bold>|v'\<^bold>| \ arr!?k" \ \... and hence short\ - using len_take1[of "arr!?k", of w] by simp + using len_take1[of "arr!?k", of w] by simp qed - fix v assume "v \b w!i # ?w'" \ \Now consider a border of the extended word\ + fix v assume "v \b w!i # ?w'" \ \Now consider a border of the extended word\ show "\<^bold>|v\<^bold>| \ Suc (arr ! ?k)" - proof (cases "\<^bold>|v\<^bold>| \ Suc 0", simp, drule not_le_imp_less) - assume "Suc 0 < \<^bold>|v\<^bold>|" - from hd_tl_longE[OF this] + proof (cases "\<^bold>|v\<^bold>| \ Suc 0") + assume "\ \<^bold>|v\<^bold>| \ Suc 0" hence "Suc 0 < \<^bold>|v\<^bold>|" by simp + from hd_tl_longE[OF this] obtain a v' where "v = a#v'" and "v' \ \" by blast with borderD_pref[OF \v \b w!i # ?w'\, unfolded prefix_Cons] - have "v = w!i#v'" + have "v = w!i#v'" by simp from extendable[OF \v \b w!i # ?w'\[unfolded \v = w!i#v'\] \v' \ \\] show ?thesis - by (simp add: \v = a # v'\) - qed + by (simp add: \v = a # v'\) + qed simp qed show " \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" \ \End of recursion.\ - show ?thesis + show ?thesis proof (unfold KMP_valid_def KMP_arr.simps KMP_bord.simps KMP_pos.simps if_not_P[OF mismatch] if_P[OF \bord = 0\], intro conjI) show "\<^bold>|0 # arr\<^bold>| + i = \<^bold>|w\<^bold>|" - using \\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|\ by auto + using \\<^bold>|arr\<^bold>| + Suc i = \<^bold>|w\<^bold>|\ by auto show "i + 0 < \<^bold>|w\<^bold>|" by (simp add: Suc_lessD \Suc i < \<^bold>|w\<^bold>|\) show "take 0 (drop i w) \p drop i w" by simp show "take 0 (drop i w) \s drop i w" - using ext_suf_Cons_take_drop by simp + using ext_suf_Cons_take_drop by simp \ \The extension is unbordered\ have "max_borderP \ (drop i w)" proof(rule ccontr) assume "\ max_borderP \ (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 \bord = 0\] have "t = \" by simp from max_borderP_border[OF \max_borderP (a#t) (drop i w)\[unfolded this] list.simps(3)] have "[a] \b drop i w". from borderD_pref[OF this] have "w!i = a" - by (simp add: pop_i) + by (simp add: pop_i) moreover have "w!(\<^bold>|w\<^bold>| - 1) = a" - using borderD_suf[OF \[a] \b drop i w\] nth_via_drop sing_len suf_drop_conv suf_share_take suffix_drop suffix_length_le by metis - ultimately show False + using borderD_suf[OF \[a] \b drop i w\] nth_via_drop sing_len suf_drop_conv suf_share_take suffix_drop suffix_length_le by metis + ultimately show False using mismatch[unfolded \bord = 0\] by simp qed thus "\v. v \b w ! (i - 1) # drop i w \ \<^bold>|v\<^bold>| \ Suc 0" by (metis border_add_Cons_len list.size(3)) \ \The array is valid: old values from assumption, the first 0 since the extension is unbordered\ show "\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 \k < \<^bold>|0 # arr\<^bold>|\ add.right_neutral add_Suc_shift gr0_implies_Suc list.size(4) nth_Cons_Suc) - next + next assume "\ 0 < k" hence "k = 0" by simp thus ?thesis - using \max_borderP \ (drop i w)\ by auto + using \max_borderP \ (drop i w)\ by auto qed qed qed qed qed qed -lemma KMP_valid_max: "\ k. KMP_valid w arr bord pos \ k < \<^bold>|w\<^bold>| \ max_borderP (take ((KMP w arr bord pos)!k) (drop k w)) (drop k w)" -proof (induct - rule: KMP.induct[of "\ w arr bord pos. -(\ k. KMP_valid w arr bord pos \ k < \<^bold>|w\<^bold>| \ 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 +lemma KMP_valid_max: assumes "KMP_valid w arr bord pos" "k < \<^bold>|w\<^bold>|" + shows "max_borderP (take ((KMP w arr bord pos)!k) (drop k w)) (drop k w)" + using assms +proof (induct w arr bord pos arbitrary: k rule: KMP.induct) case (2 w arr bord i) - then show ?case - unfolding KMP.simps using KMP_valid_step by blast -qed + then show ?case + unfolding KMP.simps using KMP_valid_step by blast +qed (simp add: KMP_valid_def) section \Border array\ fun border_array :: "'a list \ nat list" where - "border_array \ = \" + "border_array \ = \" | "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 \ \<^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 \ \" and "k < \<^bold>|rev w\<^bold>|" using \Suc k \ \<^bold>|w\<^bold>|\ by auto hence "w = hd w#tl w" - by simp + 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))". + 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 \rev w \ \\] \m < \<^bold>|rev w\<^bold>|\] 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 \m < \<^bold>|rev w\<^bold>|\ drop_all_iff leD max_border_nemp_neq nat_le_linear take_all take_len) - thus ?thesis + thus ?thesis using m_def by (metis Suc_diff_Suc \k < \<^bold>|rev w\<^bold>|\ \m < \<^bold>|rev w\<^bold>|\ 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 = \") assume "w = \" thus "max_border w = take ((border_array w)!(\<^bold>|w\<^bold>|-1)) w" using max_bord_take take_Nil by metis next assume "w \ \" - hence "Suc (\<^bold>|w\<^bold>| - 1) \ \<^bold>|w\<^bold>|" by simp + hence "Suc (\<^bold>|w\<^bold>| - 1) \ \<^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: \w \ \\) 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 "primitive [0,1,0::nat]" -value "border_array [5,4::nat,5,3,5,5,5,4,5]" +value "border_array [5,4,5,3,5,5,5,4,5::nat]" -value "primitive [5,4::nat,5,3,5,5,5,4,5]" +value "primitive [5,4,5,3,5,5,5,4,5::nat]" -value "primitive [5,4::nat,5,3,5,5,5,4,5]" +value "primitive [5,4,5,3,5,5,5,4,5::nat]" 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 "border_array [0,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::nat]" value[nbe] "border_array \" -value "border_array [1,0::nat,1,0,1,1,0,0]" +value "border_array [1,0,1,0,1,1,0,0::nat]" -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 "max_border [1,0,1,0,1,1,0,0,1,0,1,1,0,1,0,1,1,0,0,1,0,1,1,0,1,0,1,1,0,0,1,0,1,0,0,1::nat]" + +thm max_border_comp \ \code for @{term max_border}, based on @{term border_array}\ value "bordered [1,0::nat,1,0,1,1,0,1]" +value "\ [1::nat,0,1,0,1,1,0,1]" + +thm min_per_root_take \ \code for @{term \}, based on @{term max_border}\ + value "\<^bold>|\ [1::nat,0,1,0,1,1,0,1]\<^bold>|" +value "\ [1::nat,0,1,1,0,1,1,0,1]" + +thm primroot_code \ \code for @{term \}, based on @{term \}\ + +value "\ [1::nat,0,1,1,0,1,1,0]" + + +value[nbe] "\ \" end diff --git a/thys/Combinatorics_Words/CoWAll.thy b/thys/Combinatorics_Words/CoWAll.thy deleted file mode 100644 --- a/thys/Combinatorics_Words/CoWAll.thy +++ /dev/null @@ -1,13 +0,0 @@ -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,6271 +1,7087 @@ (* 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 "HOL-Eisbach.Eisbach_Tools" begin chapter "Basics of Combinatorics on Words" text\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>\"Lo83" and "Lo2" and "Lo3"\ as another reference for Combinatorics on Words. +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. \ section "Definitions and notations" text\First, we introduce elementary definitions and notations.\ text\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.\ notation append (infixr "\" 65) lemmas rassoc = append_assoc lemmas lassoc = append_assoc[symmetric] text\We add a common notation for the length of a given word $|w|$.\ notation length ("\<^bold>|_\<^bold>|") \ \note that it's bold |\ notation (latex output) length ("\<^latex>\\\ensuremath{\\left| \_\<^latex>\\\right|}\") -notation longest_common_prefix ("_ \\<^sub>p _" [61,62] 64) \ \provided by - -Sublist.thy\ +notation longest_common_prefix (infixr "\\<^sub>p" 61) \ \provided by Sublist.thy\ subsection \Empty and nonempty word\ text\As the word of length zero @{term Nil} or @{term "[]"} will be used often, we adopt its frequent notation $\varepsilon $ in this formalization.\ notation Nil ("\") -abbreviation drop_emp :: "'a list set \ 'a list set" ( "_\<^sub>+" [1000] ) where - "drop_emp S \ S - {\}" - -lemmas clean_emp = append_Nil2 append_Nil list.map(1) + +named_theorems emp_simps +lemmas [emp_simps] = append_Nil2 append_Nil list.map(1) list.size(3) subsection \Prefix\ text\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. \ - notation prefix (infixl "\p" 50) notation (latex output) prefix ("\\<^sub>p") -(* lemmas [simp] = prefix_def *) lemmas prefI'[intro] = prefixI lemma prefI[intro]: "p \ s = w \ p \p w" by auto lemma prefD: "u \p v \ \ z. v = u \ z" unfolding prefix_def. definition prefix_comparable :: "'a list \ 'a list \ bool" (infixl "\" 50) - where [simp]: "(prefix_comparable u v) \ u \p v \ v \p u" + where "(prefix_comparable u v) \ u \p v \ v \p u" lemma pref_compI1: "u \p v \ u \ v" unfolding prefix_comparable_def.. lemma pref_compI2: "v \p u \ u \ v" unfolding prefix_comparable_def.. lemma pref_compE [elim]: assumes "u \ v" obtains "u \p v" | "v \p u" using assms unfolding prefix_comparable_def.. lemma pref_compI[intro]: "u \p v \ v \p u \ u \ v" + unfolding prefix_comparable_def by simp -lemma prefs_comp_comp: "p1 \p v1 \ p2 \p v2 \ v1 \ v2 \ p1 \ p2" - unfolding prefix_comparable_def using prefix_order.trans prefix_same_cases by metis definition nonempty_prefix (infixl "\np" 50) where nonempty_prefix_def[simp]: "u \np v \ u \ \ \ u \p v" notation (latex output) nonempty_prefix ("\\<^bsub>np\<^esub>" 50) lemma npI[intro]: "u \ \ \ u \p v \ u \np v" by auto lemma npI'[intro]: "u \ \ \ (\ z. u \ z = v) \ u \np v" by auto lemma npD: "u \np v \ u \p v" by simp lemma npD': "u \np v \ u \ \" by simp notation strict_prefix (infixl "p") lemmas [simp] = strict_prefix_def +interpretation lcp: semilattice_order "(\\<^sub>p)" prefix strict_prefix +proof + fix a b c :: "'a list" + show "(a \\<^sub>p b) \\<^sub>p c = a \\<^sub>p b \\<^sub>p c" + by (rule prefix_order.antisym) + (meson longest_common_prefix_max_prefix longest_common_prefix_prefix1 longest_common_prefix_prefix2 prefix_order.trans)+ + show "a \\<^sub>p b = b \\<^sub>p a" + by (simp add: longest_common_prefix_max_prefix longest_common_prefix_prefix1 longest_common_prefix_prefix2 prefix_order.antisym) + show "a \\<^sub>p a = a" + by (simp add: longest_common_prefix_max_prefix longest_common_prefix_prefix1 prefix_order.eq_iff) + show "a \p b = (a = a \\<^sub>p b)" + by (metis longest_common_prefix_max_prefix longest_common_prefix_prefix1 longest_common_prefix_prefix2 prefix_order.dual_order.eq_iff) + thus "(a

\<^sub>p b \ a \ b)" + by simp +qed + +lemmas sprefI = strict_prefixI + lemma sprefI1[intro]: "v = u \ z \ z \ \ \ u

z = v \ z \ \ \ u

p v \ length u < length v \ u

u \p v \ u \ v" + by force + +lemma sprefI2[intro]: "u \p v \ \<^bold>|u\<^bold>| < \<^bold>|v\<^bold>| \ u

u \p v \ u \ v" by auto -lemmas sprefD1[elim] = prefix_order.strict_implies_order and - sprefD2[elim] = prefix_order.less_imp_neq - -lemma sprefE [elim]: assumes "u

z = v" and "z \ \" +lemmas sprefD1[dest] = prefix_order.strict_implies_order and + sprefD2 = prefix_order.less_imp_neq + +lemmas sprefE[elim?] = strict_prefixE + +lemma spref_exE[elim?]: assumes "u

z = v" and "z \ \" using assms unfolding strict_prefix_def prefix_def by blast subsection \Suffix\ notation suffix (infixl "\s" 50) notation (latex output) suffix ("\\<^sub>s") -lemmas suf_def = suffix_def and - pref_def = prefix_def lemma sufI[intro]: "p \ s = w \ s \s w" - by (auto simp add: suf_def) + by (auto simp add: suffix_def) lemma sufD[elim]: "u \s v \ \ z. z \ u = v" - by (auto simp add: suf_def) + by (auto simp add: suffix_def) notation strict_suffix (infixl "s") lemmas [simp] = strict_suffix_def lemmas [intro] = suffix_order.le_neq_trans +lemmas ssufI = suffix_order.le_neq_trans + lemma ssufI1[intro]: "u \ v = w \ u \ \ \ v s v \ length u < length v \ u (u \s v \ u \ v \ thesis) \ thesis" by auto lemma ssufI3[intro]: "u \ v = w \ u \np w \ v u \s v \ u \ v" by auto lemmas ssufD1[elim] = suffix_order.strict_implies_order and ssufD2[elim] = suffix_order.less_imp_neq definition suffix_comparable :: "'a list \ 'a list \ bool" (infixl "\\<^sub>s" 50) where "(suffix_comparable u v) \ (rev u) \ (rev v)" +lemma suf_compI1[intro]: "u \s v \ u \\<^sub>s v" + by (simp add: pref_compI suffix_comparable_def suffix_to_prefix) + +lemma suf_compI2[intro]: "v \s u \ u \\<^sub>s v" + by (simp add: pref_compI suffix_comparable_def suffix_to_prefix) + definition nonempty_suffix (infixl "\ns" 60) where nonempty_suffix_def[simp]: "u \ns v \ u \ \ \ u \s v" notation (latex output) nonempty_suffix ("\\<^bsub>ns\<^esub>" 50) lemma nsI[intro]: "u \ \ \ u \s v \ u \ns v" by auto lemma nsI'[intro]: "u \ \ \ (\ z. z \ u = v) \ u \ns v" by blast lemma nsD: "u \ns v \ u \s v" by simp lemma nsD': "u \ns v \ u \ \" by simp subsection \Factor\ text\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).\ notation sublist (infixl "\f" 50) notation (latex output) sublist ("\\<^sub>f") lemmas fac_def = sublist_def notation strict_sublist (infixl "f\<^esub>") lemmas strict_factor_def[simp] = strict_sublist_def definition nonempty_factor (infixl "\nf" 60) where nonempty_factor_def[simp]: "u \nf v \ u \ \ \ (\ p s. p\u\s = v)" notation (latex output) nonempty_factor ("\\<^bsub>nf\<^esub>") lemmas facI = sublist_appendI lemma facI': "a \ u \ b = w \ u \f w" by auto lemma facE[elim]: assumes "u \f v" obtains p s where "v = p \ u \ s" using assms unfolding fac_def by blast lemma facE'[elim]: assumes "u \f v" obtains p s where "p \ u \ s = v" using assms unfolding fac_def by blast section "Various elementary lemmas" lemmas drop_all_iff = drop_eq_Nil \ \backward compatibility with Isabelle 2021\ lemma exE2: "\ x y. P x y \ (\ x y. P x y \ thesis) \ thesis" by auto lemmas concat_morph = concat_append lemmas cancel = same_append_eq and cancel_right = append_same_eq lemmas disjI = verit_and_neg(3) lemma rev_in_conv: "rev u \ A \ u \ 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)" +lemma inj_on_map_lists: assumes "inj_on f A" + shows "inj_on (map f) (lists A)" proof - fix xs ys + fix xs ys assume "xs \ lists A" and "ys \ lists A" and "map f xs = map f ys" have "x = y" if "x \ set xs" and "y \ set ys" and "f x = f y" for x y using in_listsD[OF \xs \ lists A\, rule_format, OF \x \ set xs\] in_listsD[OF \ys \ lists A\, rule_format, OF \y \ set ys\] \inj_on f A\[unfolded inj_on_def, rule_format, OF _ _ \f x = f y\] by blast from list.inj_map_strong[OF this \map f xs = map f ys\] show "xs = ys". qed lemma bij_lists: "bij_betw f X Y \ bij_betw (map f) (lists X) (lists Y)" - unfolding bij_betw_def using inj_on_map_lists lists_image by metis + unfolding bij_betw_def using inj_on_map_lists lists_image by metis lemma concat_sing': "concat [r] = r" by simp lemma concat_sing: assumes "s = [a]" shows "concat s = a" using concat_sing' unfolding \s = [a]\. lemma rev_sing: "rev [x] = [x]" by simp lemma hd_word: "a#ws = [a] \ ws" by simp +lemma pref_singE: assumes "p \p [a]" obtains "p = \" | "p = [a]" + using assms unfolding prefix_Cons by fastforce + lemma map_hd: "map f (a#v) = [f a] \ (map f v)" by simp lemma hd_tl: "w \ \ \ [hd w] \ tl w = w" by simp lemma hd_tlE: assumes "w \ \" 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' \ \" 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' \ \" and "hd w = a" and "tl w = w'" using assms by auto from that[OF \w = a#w'\ this] show thesis. qed lemma hd_pref: "w \ \ \ [hd w] \p w" using hd_tl by blast lemma add_nth: assumes "n < \<^bold>|w\<^bold>|" shows "(take n w) \ [w!n] \p w" using take_is_prefix[of "Suc n" w, unfolded take_Suc_conv_app_nth[OF assms]]. lemma hd_pref': assumes "w \ \" shows "[w!0] \p w" - using hd_pref[OF \w \ \\, folded hd_conv_nth[OF \w \ \\, symmetric]]. + using hd_pref[OF \w \ \\, folded hd_conv_nth[OF \w \ \\, symmetric]]. lemma sub_lists_mono: "A \ B \ x \ lists A \ x \ lists B" by auto lemma lists_hd_in_set[simp]: "us \ \ \ us \ lists Q \ hd us \ Q" by fastforce +lemma lists_last_in_set[simp]: "us \ \ \ us \ lists Q \ last us \ Q" + by fastforce + lemma replicate_in_lists: "replicate k z \ lists {z}" by (induction k) auto lemma tl_in_lists: assumes "us \ lists A" shows "tl us \ 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 \ \" proof assume "tl us = \" from assms have "us \ \" and "\<^bold>|us\<^bold>| = Suc \<^bold>|tl us\<^bold>|" and "\<^bold>|us\<^bold>| \ Suc 0" by auto thus False using \tl us = \\ by simp qed lemma tl_set: "x \ set (tl a) \ x \ set a" using list.sel(2) list.set_sel(2) by metis lemma drop_take_inv: "n \ \<^bold>|u\<^bold>| \ drop n (take n u \ w) = w" by simp lemma split_list_long: assumes "1 < \<^bold>|us\<^bold>|" and "u \ set us" obtains xs ys where "us = xs \ [u] \ ys" and "xs\ys\\" proof- obtain xs ys where "us = xs \ [u] \ ys" using split_list_first[OF \u \ set us\] by auto hence "xs\ys\\" using \1 < \<^bold>|us\<^bold>|\ by auto from that[OF \us = xs \ [u] \ ys\ this] show thesis. qed lemma flatten_lists: "G \ lists B \ xs \ lists G \ concat xs \ lists B" by (induct xs, simp_all add: subset_iff) lemma concat_map_sing_ident: "concat (map (\ x. [x]) xs) = xs" by auto lemma hd_concat_tl: assumes "ws \ \" shows "hd ws \ concat (tl ws) = concat ws" using concat.simps(2)[of "hd ws" "tl ws", unfolded list.collapse[OF \ws \ \\], symmetric]. lemma concat_butlast_last: assumes "ws \ \" shows "concat (butlast ws) \ last ws = concat ws" using concat_morph[of "butlast ws" "[last ws]", unfolded concat_sing' append_butlast_last_id[OF \ws \ \\], symmetric]. lemma spref_butlast_pref: assumes "u \p v" and "u \ v" shows "u \p butlast v" - using butlast_append prefixE[OF \u \p v\] \u \ v\ append_Nil2 prefixI by metis + using butlast_append prefixE[OF \u \p v\] \u \ v\ append_Nil2 prefixI by metis lemma last_concat: "xs \ \ \ last xs \ \ \ last (concat xs) = last (last xs)" using concat_butlast_last last_appendR by metis lemma concat_last_suf: "ws \ \ \ last ws \s concat ws" using concat_butlast_last by blast lemma concat_hd_pref: "ws \ \ \ hd ws \p concat ws" using hd_concat_tl by blast lemma set_nemp_concat_nemp: assumes "ws \ \" and "\ \ set ws" shows "concat ws \ \" using \\ \ set ws\ last_in_set[OF \ws \ \\] concat_butlast_last[OF \ws \ \\] by fastforce lemmas takedrop = append_take_drop_id lemma suf_drop_conv: "u \s w \ 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 \ rev v = rev v \ rev u \ u \ v = v \ u" unfolding rev_append[symmetric] rev_is_rev_conv eq_ac(1)[of "u \ v"] by blast lemma rev_induct2: "\ P [] []; \x xs. P (xs\[x]) []; \y ys. P [] (ys\[y]); \x xs y ys. P xs ys \ P (xs\[x]) (ys\[y]) \ \ P xs ys" proof (induct xs arbitrary: ys rule: rev_induct) case Nil then show ?case using rev_induct[of "P \"] 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}" +lemma fin_bin: "finite {x,y}" by simp -lemma rev_rev_image_eq: "rev ` rev ` X = X" +lemma rev_rev_image_eq [reversal_rule]: "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" +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 \ u \ lists A \ 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 = \ \ thesis) \ (u = [hd u] \ thesis) \ (u = [hd u, hd (tl u)] \ tl (tl u) \ thesis) \ 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 +lemma same_sing_pref: "u \ [a] \p v \ u \ [b] \p v \ a = b" + using prefix_same_cases by fastforce + +lemma compow_Suc: "(f^^(Suc k)) w = f ((f^^k) w)" + by simp + +lemma compow_Suc': "(f^^(Suc k)) w = (f^^k) (f w)" + by (simp add: funpow_swap1) + subsection \General facts\ lemma two_elem_sub: "x \ A \ y \ A \ {x,y} \ A" - by simp + by simp thm fun.inj_map[THEN injD] lemma inj_comp: assumes "inj (f :: 'a list \ 'b list)" shows "(g w = h w \ (f \ g) w = (f \ h) w)" - by (rule, simp) (use injD[OF assms] in fastforce) - + by (rule iffI, simp) (use injD[OF assms] in fastforce) + lemma inj_comp_eq: assumes "inj (f :: 'a list \ 'b list)" shows "(g = h \ f \ g = f \ h)" by (rule, fast) (use fun.inj_map[OF assms, unfolded inj_on_def] in fast) lemma two_elem_cases[elim!]: assumes "u \ {x, y}" obtains (fst) "u = x" | (snd) "u = y" using assms by blast lemma two_elem_cases2[elim]: assumes "u \ {x, y}" "v \ {x,y}" "u \ v" shows "(u = x \ v = y \ thesis) \ (u = y \ v = x \ thesis) \ thesis" - using assms by blast + using assms by blast lemma two_elemP: "u \ {x, y} \ P x \ P y \ P u" by blast lemma pairs_extensional: "(\ r s. P r s \ (\ a b. Q a b \ r = fa a \ s = fb b)) \ {(r,s). P r s} = {(fa a, fb b) | a b. Q a b}" by auto lemma pairs_extensional': "(\ r s. P r s \ (\ t. Q t \ r = fa t \ s = fb t)) \ {(r,s). P r s} = {(fa t, fb t) | t. Q t}" by auto lemma doubleton_subset_cases: assumes "A \ {x,y}" obtains "A = {}" | "A = {x}" | "A = {y}" | "A = {x,y}" using assms by blast subsection \Map injective function\ lemma map_pref_conv [reversal_rule]: assumes "inj f" shows "map f u \p map f v \ u \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 \inj f\] list.map_id.. lemma map_suf_conv [reversal_rule]: assumes "inj f" shows "map f u \s map f v \ u \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 \inj f\] list.map_id.. lemma map_fac_conv [reversal_rule]: assumes "inj f" shows "map f u \f map f v \ u \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 \inj f\] list.map_id.. lemma map_lcp_conv: assumes "inj f" shows "(map f xs) \\<^sub>p (map f ys) = map f (xs \\<^sub>p ys)" -proof (induct xs ys rule: list_induct2', simp, simp, simp) +proof (induct xs ys rule: list_induct2') case (4 x xs y ys) then show ?case proof (cases "x = y") - assume "x = y" - thus ?case + assume "x = y" + thus ?case using "4.hyps" by simp next assume "x \ y" - hence "f x \ f y" + hence "f x \ f y" using inj_eq[OF \inj f\] by simp - thus ?case using \x \ y\ by simp + thus ?case using \x \ y\ by simp qed -qed +qed simp_all subsection \Orderings on lists: prefix, suffix, factor\ lemmas self_pref = prefix_order.refl and pref_antisym = prefix_order.antisym and pref_trans = prefix_order.trans and + spref_trans = prefix_order.less_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 \ S \ u \ \ \ u \ S\<^sub>+" - by simp - -lemma nel_drop_emp: "u \ \ \ u \ S \ u \ S\<^sub>+" +lemma nemp_elem_setI[intro]: "u \ S \ u \ \ \ u \ S - {\}" by simp -lemma drop_emp_nel: assumes "u \ S\<^sub>+" shows "u \ \" and "u \ S" - using assms by simp+ - -lemma emp_concat_emp: "us \ lists S\<^sub>+ \ concat us = \ \ us = \" + +lemma emp_concat_emp: "us \ lists (S - {\}) \ concat us = \ \ us = \" using DiffD2 by auto -lemma take_nemp: "w \ \ \ n \ 0 \ take n w \ \" +lemma take_nemp: "w \ \ \ 0 < n \ take n w \ \" by simp lemma pref_nemp [intro]: "u \ \ \ u \ v \ \" unfolding append_is_Nil_conv by simp lemma suf_nemp [intro]: "v \ \ \ u \ v \ \" unfolding append_is_Nil_conv by simp lemma pref_of_emp: "u \ v = \ \ u = \" using append_is_Nil_conv by simp lemma suf_of_emp: "u \ v = \ \ v = \" using append_is_Nil_conv by simp -lemma nemp_comm [intro]: "(u \ \ \ v \ \ \ u \ v = v \ u) \ u \ v = v \ u" +lemma nemp_comm: "(u \ \ \ v \ \ \ u \ v \ u \ v = v \ u) \ u \ v = v \ u" + by force + +lemma non_triv_comm [intro]: "(u \ \ \ v \ \ \ u \ v \ u \ v = v \ u) \ u \ v = v \ u" by force lemma split_list': "a \ set ws \ \p s. ws = p \ [a] \ s" using split_list by fastforce lemma split_listE: assumes "a \ set w" obtains p s where "w = p \ [a] \ s" using exE2[OF split_list'[OF assms]]. -subsection \Counting letters\ - -lemma count_list_append: "count_list (x\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) +subsection \Counting letters\ + +declare count_list_rev [reversal_rule] 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\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 \ {a,b,c}"}. + all possibilites for @{term "x"} in a premise such as @{term "x \ {a,b,c}"}. See the demonstrations below.\ method set_inspection = ( - (unfold insert_iff), + (unfold insert_iff), (elim disjE emptyE), (simp_all only: singleton_iff refl True_implies_equals) ) lemma "u \ {x,y} \ P u" apply(set_inspection) oops lemma "\u. u \ {x,y} \ u = x \ u = y" by(set_inspection, simp_all) section "Length and its properties" lemmas lenarg = arg_cong[of _ _ length] and lenmorph = length_append lemma lenarg_not: "\<^bold>|u\<^bold>| \ \<^bold>|v\<^bold>| \ u \ v" using size_neq_size_imp_neq. lemma len_less_neq: "\<^bold>|u\<^bold>| < \<^bold>|v\<^bold>| \ u \ v" by blast lemmas len_nemp_conv = length_greater_0_conv lemma npos_len: "\<^bold>|u\<^bold>| \ 0 \ u = \" by simp -lemma nemp_pos_len: "w \ \ \ 0 < \<^bold>|w\<^bold>|" +lemma nemp_pos_len: "w \ \ \ 0 < \<^bold>|w\<^bold>|" by blast lemma nemp_le_len: "r \ \ \ 1 \ \<^bold>|r\<^bold>|" by (simp add: leI) lemma swap_len: "\<^bold>|u \ v\<^bold>| = \<^bold>|v \ u\<^bold>|" by simp lemma len_after_drop: "p + q \ \<^bold>|w\<^bold>| \ q \ \<^bold>|drop p w\<^bold>|" by simp lemma short_take_append: "n \ \<^bold>|u\<^bold>|\ take n (u \ v) = take n u" by simp lemma sing_word: "\<^bold>|us\<^bold>| = 1 \ [hd us] = us" by (cases us) simp+ lemma sing_word_concat: assumes "\<^bold>|us\<^bold>| = 1" shows "[concat us] = us" unfolding concat_sing[OF sing_word[OF \\<^bold>|us\<^bold>| = 1\, symmetric]] using sing_word[OF \\<^bold>|us\<^bold>| = 1\]. lemma len_one_concat_in: "ws \ lists A \ \<^bold>|ws\<^bold>| = 1 \ concat ws \ A" using Cons_in_lists_iff sing_word_concat by metis -lemma nonsing_concat_len: "\<^bold>|us\<^bold>| \ 1 \ concat us \ \ \ 1 < \<^bold>|us\<^bold>|" - using nat_neq_iff by fastforce +lemma concat_nemp: "concat us \ \ \ us \ \" + using concat.simps(1) by blast lemma sing_len: "\<^bold>|[a]\<^bold>| = 1" by simp lemmas pref_len = prefix_length_le and suf_len = suffix_length_le +lemmas spref_len = prefix_length_less and + ssuf_len = suffix_length_less + lemma pref_len': "\<^bold>|u\<^bold>| \ \<^bold>|u \ z\<^bold>|" by auto lemma suf_len': "\<^bold>|u\<^bold>| \ \<^bold>|z \ u\<^bold>|" by auto lemma fac_len: "u \f v \ \<^bold>|u\<^bold>| \ \<^bold>|v\<^bold>|" by auto lemma fac_len': "\<^bold>|w\<^bold>| \ \<^bold>|u \ w \ v\<^bold>|" by simp lemma fac_len_eq: "u \f v \ \<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \ u = v" unfolding fac_def using lenmorph npos_len by fastforce thm length_take lemma len_take1: "\<^bold>|take p w\<^bold>| \ p" by simp lemma len_take2: "\<^bold>|take p w\<^bold>| \ \<^bold>|w\<^bold>|" by simp lemma drop_len: "\<^bold>|u \ w\<^bold>| \ \<^bold>|u \ v \ w\<^bold>|" by simp lemma drop_pref: "drop \<^bold>|u\<^bold>| (u \ w) = w" by simp lemma take_len: "p \ \<^bold>|w\<^bold>| \ \<^bold>|take p w\<^bold>| = p" - using min_absorb2[of p "\<^bold>|w\<^bold>|", folded length_take[of p w]]. + using min_absorb2[of p "\<^bold>|w\<^bold>|", folded length_take[of p w]]. lemma conj_len: "p \ x = x \ s \ \<^bold>|p\<^bold>| = \<^bold>|s\<^bold>|" using lenmorph[of p x] lenmorph[of x s] add.commute add_left_imp_eq by auto lemma take_nemp_len: "u \ \ \ r \ \ \ take \<^bold>|r\<^bold>| u \ \" by simp lemma nemp_len: "u \ \ \ \<^bold>|u\<^bold>| \ 0" by simp -lemma emp_len: "w = \ \ \<^bold>|w\<^bold>| = 0" +lemma emp_len: "w = \ \ \<^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: "\ \ set ws \ \<^bold>|ws\<^bold>| \ \<^bold>|concat ws\<^bold>|" -proof (induct ws, simp) +proof (induct ws) case (Cons a ws) hence "1 \ \<^bold>|a\<^bold>|" using list.set_intros(1)[of a ws] nemp_le_len[of a] by blast then show ?case unfolding concat.simps(2) unfolding lenmorph hd_word[of a ws] sing_len using Cons.hyps Cons.prems by simp -qed +qed simp lemma eq_len_iff: assumes eq: "x \ y = u \ v" shows "\<^bold>|x\<^bold>| \ \<^bold>|u\<^bold>| \ \<^bold>|v\<^bold>| \ \<^bold>|y\<^bold>|" using lenarg[OF eq] unfolding lenmorph by auto lemma eq_len_iff_less: assumes eq: "x \ y = u \ v" shows "\<^bold>|x\<^bold>| < \<^bold>|u\<^bold>| \ \<^bold>|v\<^bold>| < \<^bold>|y\<^bold>|" using lenarg[OF eq] unfolding lenmorph by auto -lemma Suc_len_nemp: "\<^bold>|w\<^bold>| = Suc n \ w \ \" +lemma Suc_len_nemp: "\<^bold>|w\<^bold>| = Suc n \ w \ \" by force lemma same_sufix_nil: assumes "z \ u \p u" shows "z = \" - using prefix_length_le[OF assms] unfolding lenmorph by simp + using prefix_length_le[OF assms] unfolding lenmorph by simp lemma count_list_gr_0_iff: "0 < count_list u a \ a \ set u" by (intro iffI, use count_notin[folded not_gr0, of a u] in blast) (induction u, auto) +lemma mid_fac_ex: assumes "2 \ \<^bold>|w\<^bold>|" + shows "w = [hd w]\(butlast (tl w))\[last w]" + using long_list_tl[OF \2 \ \<^bold>|w\<^bold>|\[folded One_less_Two_le_iff]] append_butlast_last_id[of "tl w"] len_nemp_conv[of w] + by (simp add: last_tl tl_Nil) + section "List inspection method" -text\In this section we define a proof method, named list\_inspection, which splits the goal into subgoals which enumerate possibilities +text\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 \ w \ lists {x,y,z}"} or @{term "\<^bold>|w\<^bold>| \ 2 \ w \ 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.\ context begin text\First, we define an elementary lemma used for unfolding the premise. Since it is very specific, we keep it private.\ private lemma hd_tl_len_list_iff: "\<^bold>|w\<^bold>| = Suc n \ w \ lists A \ hd w \ A \ w = hd w # tl w \ \<^bold>|tl w\<^bold>| = n \ tl w \ lists A" (is "?L = ?R") proof show "?L \ ?R" proof (elim conjE) assume "\<^bold>|w\<^bold>| = Suc n" and "w \ lists A" - note Suc_len_nemp[OF \\<^bold>|w\<^bold>| = Suc n\] + note Suc_len_nemp[OF \\<^bold>|w\<^bold>| = Suc n\] from lists_hd_in_set[OF \w \ \\ \w \ lists A\] list.collapse[OF \w \ \\] tl_in_lists[OF \w \ lists A\] show "hd w \ A \ w = hd w # tl w \ \<^bold>|tl w\<^bold>| = n \ tl w \ lists A" using \\<^bold>|w\<^bold>| = Suc n\ by simp qed -next +next show "?R \ ?L" using Cons_in_lists_iff[of "hd w" "tl w"] length_Cons[of "hd w" "tl w"] by presburger qed text\We define a list of lemmas used for the main unfolding step.\ private lemmas len_list_word_dec = numeral_nat hd_tl_len_list_iff insert_iff empty_iff simp_thms length_0_conv text\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.\ method list_inspection = ( ((match premises in len[thin]: "\<^bold>|w\<^bold>| \ k" and list[thin]: "w \ lists A" for w k A \ \insert conjI[OF len list]\)+)?, - (unfold numeral_nat le_Suc_eq le_0_eq), \ \unfold numeral and e.g. @{term "k \ 2"}\ + (unfold numeral_nat le_Suc_eq le_0_eq), \ \unfold numeral and e.g. @{term "k \ 2"}\ (unfold conj_ac(1)[of "w \ lists A" "\<^bold>|w\<^bold>| \ k" for w A k] - conj_disj_distribR[where ?R = "w \ lists A" for w A])?, + conj_disj_distribR[where ?R = "w \ lists A" for w A])?, ((match premises in len[thin]: "\<^bold>|w\<^bold>| = k" and list[thin]: "w \ lists A" for w k A \ \insert conjI[OF len list]\)+)?, \ \transform into the conjuction such as @{term "length w = 2 \ w \ lists {x,y,z}"}\ (unfold conj_ac(1)[of "w \ lists A" "\<^bold>|w\<^bold>| = k" for w A k] len_list_word_dec), \ \unfold w\ (elim disjE conjE), \ \split into all cases\ (simp_all only: singleton_iff lists.Nil list.sel refl True_implies_equals)?, \ \replace w everywhere\ (simp_all only: empty_iff lists.Nil bool_simps)? \ \solve simple cases\ ) subsubsection "List inspection demonstrations" text\The required premise in the form of conjuction. First, inequality bound on the length, second, equality bound.\ -lemma "\<^bold>|w\<^bold>| \ 2 \ w \ lists {x,y,z} \ P w" - apply(list_inspection) - oops - lemma "\<^bold>|w\<^bold>| = 2 \ w \ lists {x,y,z} \ P w" apply(list_inspection) oops -text\The required premise in of 2 separate assumptions.\ - -lemma "w \p w \ \<^bold>|w\<^bold>| \ 2 \ w \ lists {a,b} \ hd w = a \ w \ \ \ w = [a, b] \ w = [a, a] \ w = [a]" - by list_inspection - -lemma "w \p w \ \<^bold>|w\<^bold>| = 2 \ w \ lists {a,b} \ hd w = a \ w = [a, b] \ w = [a, a]" +text\The required premise as 2 separate assumptions.\ +lemma "\<^bold>|w\<^bold>| \ 2 \ w \ lists {x,y,z} \ P w" + apply(list_inspection) + oops + + +lemma "w \p w \ \<^bold>|w\<^bold>| \ 2 \ w \ lists {a,b} \ hd w = a \ w \ \ \ w = [a, b] \ w = [a, a] \ w = [a]" by list_inspection -lemma "w \p w \ \<^bold>|w\<^bold>| = 2 \ w \ lists {a,b} \ hd w = a \ w = [a, b] \ w = [a, a]" +lemma "w \p w \ \<^bold>|w\<^bold>| = 2 \ w \ lists {a,b} \ hd w = a \ w = [a, b] \ w = [a, a]" by list_inspection -lemma "w \p w \ w \ lists {a,b} \ \<^bold>|w\<^bold>| = 2 \ hd w = a \ w = [a, b] \ w = [a, a]" +lemma "w \p w \ \<^bold>|w\<^bold>| = 2 \ w \ lists {a,b} \ hd w = a \ w = [a, b] \ w = [a, a]" by list_inspection -end (* end list inspection unnamed context *) - +lemma "w \p w \ w \ lists {a,b} \ \<^bold>|w\<^bold>| = 2 \ hd w = a \ w = [a, b] \ w = [a, a]" + by list_inspection + +end section "Prefix and prefix comparability properties" lemmas pref_emp = prefix_bot.extremum_uniqueI lemma triv_pref: "r \p r \ s" using prefI[OF refl]. lemma triv_spref: "s \ \ \ r

s" by simp lemma pref_cancel: "z \ u \p z \ v \ u \p v" by simp lemma pref_cancel': "u \p v \ z \ u \p z \ v" by simp +lemma spref_cancel: "z \ u

v \ u

z \ u

v" + by simp + lemmas pref_cancel_conv = same_prefix_prefix and suf_cancel_conv = same_suffix_suffix \ \provided by Sublist.thy\ lemma pref_cancel_hd_conv: "a # u \p a # v \ u \p v" by simp lemma spref_cancel_conv: "z \ x

y \ x

[a] \ u \p v" by (auto simp only: strict_prefix_def prefix_snoc) simp -lemmas pref_ext = prefix_prefix \ \provided by Sublist.thy\ - -lemmas pref_extD = append_prefixD +lemma spref_two_lettersE: assumes "p

" | "p = [a]" + using assms pref_singE[of p a thesis] + unfolding hd_word[of a "[b]"] spref_snoc_iff by fastforce + +lemmas pref_ext[intro] = prefix_prefix \ \provided by Sublist.thy\ + +lemmas pref_extD = append_prefixD and + suf_extD = suffix_appendD lemma spref_extD: "x \ y

x

r

v" by force lemma pref_ext_nemp: "r \p u \ v \ \ \ r

v" by auto lemma pref_take: "p \p w \ take \<^bold>|p\<^bold>| w = p" unfolding prefix_def by force lemma pref_take_conv: "take (\<^bold>|r\<^bold>|) w = r \ r \p w" using pref_take[of r w] take_is_prefix[of "\<^bold>|r\<^bold>|" w] by argo lemma le_suf_drop: assumes "i \ j" shows "drop j w \s drop i w" using suffix_drop[of "j - i" "drop i w", unfolded drop_drop le_add_diff_inverse2[OF \i \ j\]]. lemma spref_take: "p

take \<^bold>|p\<^bold>| w = p" - by fastforce - -lemma pref_same_len: "u \p v \ \<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \ u = v" - by (fastforce simp add: prefix_def) + by (elim spref_exE) force + +lemma pref_same_len: "u \p v \ \<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \ u = v" + by (fastforce elim: prefixE) + +lemma pref_same_len': "u \ z \p v \ w \ \<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \ u = v" + by (fastforce elim: prefixE) lemma pref_comp_eq: "u \ v \ \<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \ u = v" using pref_same_len by fastforce lemma ruler_eq_len: "u \p w \ v \p w \ \<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \ u = v" by (fastforce simp add: prefix_def) lemma pref_prod_eq: "u \p v \ z \ \<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \ 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 \ v \p v \ u \ u \ v = v \ u" - using pref_comm_eq self_pref by metis + using pref_comm_eq self_pref by metis lemma add_nth_pref: assumes "u

[w!\<^bold>|u\<^bold>|] \p w" using add_nth[OF prefix_length_less[OF \u

], unfolded spref_take[OF \u

]]. lemma index_pref: "\<^bold>|u\<^bold>| \ \<^bold>|w\<^bold>| \ (\ i < \<^bold>|u\<^bold>|. u!i = w!i) \ u \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 \p w" "i < \<^bold>|u\<^bold>|" shows "u!i = w!i" using nth_take[OF \i < \<^bold>|u\<^bold>|\, of w, unfolded pref_take[OF \u \p w\]]. lemma pref_drop: "u \p v \ drop p u \p drop p v" using prefI[OF sym[OF drop_append]] unfolding prefix_def by blast subsection "Prefix comparability" lemma pref_comp_sym[sym]: "u \ v \ v \ u" by blast +lemma not_pref_comp_sym[sym]: "\ u \ v \ \ v \ u" + by blast + +lemma pref_comp_sym_iff: "u \ v \ v \ 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_eq: "u \ x = v \ y \ u \p v \ v \p u" by (metis prefI prefix_same_cases) lemma ruler_eq': "u \ x = v \ y \ u \p v \ v

p v \ u' \p v' \ v \ v' \ u \ u'" unfolding prefix_comparable_def using disjE[OF _ ruler[OF pref_trans] ruler[OF _ pref_trans]]. lemma ruler_pref': "w \p v\z \ w \p v \ v \p w" using ruler by blast lemma ruler_pref'': "w \p v\z \ w \ v" unfolding prefix_comparable_def using ruler_pref'. lemma pref_cancel_right: assumes "u \ z \p v \ z" shows "u \p v" proof- have "\<^bold>|u\<^bold>| \ \<^bold>|v\<^bold>|" using prefix_length_le[OF assms] by force - from ruler_le[of u "v \ z" v, OF pref_extD[OF assms] triv_pref this] + from ruler_le[of u "v \ z" v, OF pref_extD[OF assms] triv_pref this] show "u \p v". qed lemma pref_prod_pref_short: "u \p z \ w \ v \p w \ \<^bold>|u\<^bold>| \ \<^bold>|z \ v\<^bold>| \ u \p z \ v" using ruler_le[OF _ pref_cancel']. lemma pref_prod_pref: "u \p z \ w \ u \p w \ u \p z \ u" using pref_prod_pref_short[OF _ _ suf_len']. lemma pref_prod_pref': assumes "u \p z\u\w" shows "u \p z\u" using pref_prod_pref[of u z "u \ w", OF \u \p z\u\w\ triv_pref]. lemma pref_prod_long: "u \p v \ w \ \<^bold>|v\<^bold>| \ \<^bold>|u\<^bold>| \ v \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 \p v \ w" and "\<^bold>|v\<^bold>| < \<^bold>|u\<^bold>|" shows "v

u \p v \ w\ less_imp_le[OF \\<^bold>|v\<^bold>| < \<^bold>|u\<^bold>|\]] \\<^bold>|v\<^bold>| < \<^bold>|u\<^bold>|\]. -lemma pref_keeps_root: "u \p r \ u \ v \p u \ v \p r \ v" +lemma pref_keeps_per_root: "u \p r \ u \ v \p u \ v \p r \ v" using pref_prod_pref[of v r u] pref_trans[of v u "r\u"] by blast +lemma pref_keeps_per_root': "u

u \ v \p u \ v

v" + using pref_keeps_per_root by auto + +lemma per_root_pref_sing: "w

w \ u \ [a] \p w \ u \ [a] \p r \ u" + using append_assoc pref_keeps_per_root' spref_snoc_iff by metis + lemma pref_prolong: "w \p z \ r \ r \p s \ w \p z \ s" using pref_trans[OF _ pref_cancel']. +lemma spref__pref_prolong: "w

r \ r \p s \ w

s" + using prefix_order.less_le_trans[OF _ pref_cancel']. + +lemma pref_spref_prolong: "w \p z \ r \ r

w

s" + using prefix_order.le_less_trans[OF _ spref_cancel']. + +lemma spref_spref_prolong: "w

r \ r

w

s" + using prefix_order.less_trans[OF _ spref_cancel']. + lemmas pref_shorten = pref_trans[OF pref_cancel'] lemma pref_prolong': "u \p w \ z \ v \ u \p z \ u \p w \ v \ u" using ruler_le[OF _ pref_cancel' le_trans[OF suf_len' suf_len']]. lemma pref_prolong_per_root: "u \p r \ s \ s \p r \ s \ u \p r \ u" - using pref_prolong[of u r s "r \ s", THEN pref_prod_pref]. + using pref_prolong[of u r s "r \ s", THEN pref_prod_pref]. thm pref_compE lemma pref_prolong_comp: "u \p w \ z \ v \ u \ z \ u \p w \ v \ u" using pref_prolong' pref_prolong by (elim pref_compE) lemma pref_prod_le[intro]: "u \p v \ w \ \<^bold>|u\<^bold>| \ \<^bold>|v\<^bold>| \ u \p v" using ruler_le[OF _ triv_pref]. +lemma prod_pref_prod_le: "u\v \p x\y \ \<^bold>|u\<^bold>| \ \<^bold>|x\<^bold>| \ u \p x" + using pref_prod_le[OF append_prefixD]. + lemma pref_prod_less: "u \p v \ w \ \<^bold>|u\<^bold>| < \<^bold>|v\<^bold>| \ u

y = u \ v \ \<^bold>|x\<^bold>| \ \<^bold>|u\<^bold>| \ x \p u" +lemma eq_le_pref[elim]: "x \ y = u \ v \ \<^bold>|x\<^bold>| \ \<^bold>|u\<^bold>| \ x \p u" using pref_prod_le[OF prefI]. lemma eq_less_pref: "x \ y = u \ v \ \<^bold>|x\<^bold>| < \<^bold>|u\<^bold>| \ x

y = u \ v" shows "\<^bold>|x\<^bold>| \ \<^bold>|u\<^bold>| \ v \s y" - using eq_le_pref[reversed, folded suffix_to_prefix, OF \x \ y = u \ v\[symmetric]] - unfolding eq_len_iff[OF \x \ y = u \ v\]. - lemma eq_less_suf: assumes "x \ y = u \ v" shows "\<^bold>|x\<^bold>| < \<^bold>|u\<^bold>| \ v x \ y = u \ v\[symmetric]] unfolding eq_len_iff_less[OF \x \ y = u \ v\]. lemma pref_prod_cancel: assumes "u \p p\w\q" and "\<^bold>|p\<^bold>| \ \<^bold>|u\<^bold>|" and "\<^bold>|u\<^bold>| \ \<^bold>|p\w\<^bold>|" obtains r where "p \ r = u" and "r \p w" proof- obtain r where [symmetric]: "u = p \ r" using pref_prod_long[OF \u \p p\w\q\ \\<^bold>|p\<^bold>| \ \<^bold>|u\<^bold>|\].. moreover have "r \p w" using pref_prod_le[OF \u \p p\w\q\[unfolded lassoc] \\<^bold>|u\<^bold>| \ \<^bold>|p\w\<^bold>|\] unfolding \p \ r = u\[symmetric] by simp ultimately show thesis.. qed lemma pref_prod_cancel': assumes "u \p p\w\q" and "\<^bold>|p\<^bold>| < \<^bold>|u\<^bold>|" and "\<^bold>|u\<^bold>| \ \<^bold>|p\w\<^bold>|" obtains r where "p \ r = u" and "r \p w" and "r \ \" proof- obtain r where "p \ r = u" and "r \p w" using pref_prod_cancel[OF \u \p p\w\q\ less_imp_le[OF \\<^bold>|p\<^bold>| < \<^bold>|u\<^bold>|\] \\<^bold>|u\<^bold>| \ \<^bold>|p\w\<^bold>|\]. moreover have "r \ \" using \p \ r = u\ less_imp_neq[OF \\<^bold>|p\<^bold>| < \<^bold>|u\<^bold>|\] by fastforce ultimately show thesis.. qed lemma non_comp_parallel: "\ u \ v \ u \ v" unfolding prefix_comparable_def parallel_def de_Morgan_disj.. lemma comp_refl: "u \ u" + unfolding prefix_comparable_def by simp lemma incomp_cancel: "\ p\u \ p\v \ \ u \ v" + unfolding prefix_comparable_def by simp lemma comm_ruler: "r \ s \p w1 \ s \ r \p w2 \ w1 \ w2 \ r \ s = s \ r" using pref_comp_eq[OF ruler_comp swap_len]. lemma comm_comp_eq: "r \ s \ s \ r \ r \ s = s \ r" using comm_ruler by blast lemma pref_share_take: "u \p v \ q \ \<^bold>|u\<^bold>| \ take q u = take q v" by (auto simp add: prefix_def) lemma pref_prod_longer: "u \p z \ w \ v \p w \ \<^bold>|z \ v\<^bold>| \ \<^bold>|u\<^bold>| \ z \ v \p u" using ruler_le[OF pref_cancel']. lemma pref_comp_not_pref: "u \ v \ \ v \p u \ u

v \ \ u

v \p u" using contrapos_np[OF _ pref_comp_not_pref]. lemma hd_prod: "u \ \ \ (u \ v)!0 = u!0" by (cases u) (blast, simp) lemma distinct_first: assumes "w \ \" "z \ \" "w!0 \ z!0" shows "w \ w' \ z \ z'" using hd_prod[of w w', OF \w \ \\] hd_prod[of z z', OF \z \ \\] \w!0 \ z!0\ by auto lemmas last_no_split = prefix_snoc lemma last_no_split': "u

w \p u \ [a] \ w = u \ [a]" unfolding prefix_order.less_le_not_le last_no_split by blast lemma comp_shorter: "v \ w \ \<^bold>|v\<^bold>| \ \<^bold>|w\<^bold>| \ v \p w" + unfolding prefix_comparable_def by (auto simp add: prefix_def) +lemma comp_shorter_conv: "\<^bold>|u\<^bold>| \ \<^bold>|v\<^bold>| \ u \ v \ u \p v" + using comp_shorter by auto + lemma pref_comp_len_trans: "w \p v \ u \ v \ \<^bold>|w\<^bold>| \ \<^bold>|u\<^bold>| \ w \p u" using ruler_le pref_trans by (elim pref_compE) lemma comp_cancel: "z \ w1 \ z \ w2 \ w1 \ w2" + unfolding prefix_comparable_def using pref_cancel by auto lemma emp_pref: "\ \p u" by simp lemma emp_spref: "u \ \ \ \

p v \ \<^bold>|v\<^bold>| \ \<^bold>|u\<^bold>| \ u = v" by (auto simp add: prefix_def) lemma not_comp_ext: "\ w1 \ w2 \ \ w1 \ z \ w2 \ z'" using contrapos_nn[OF _ ruler_comp[OF triv_pref triv_pref]]. lemma mismatch_incopm: "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \ x \ y \ \ u \ [x] \ v \ [y]" by (auto simp add: prefix_def) lemma comp_prefs_comp: "u \ z \ v \ w \ u \ v" using ruler_comp[OF triv_pref triv_pref]. lemma comp_hd_eq: "u \ v \ u \ \ \ v \ \ \ hd u = hd v" + unfolding prefix_comparable_def by (auto simp add: prefix_def) lemma pref_hd_eq': "p \p u \ p \p v \ p \ \ \ hd u = hd v" by (auto simp add: prefix_def) lemma pref_hd_eq: "u \p v \ u \ \ \ hd u = hd v" by (auto simp add: prefix_def) -lemma sing_pref_hd: "[a] \p v \ hd v = a" +lemma sing_pref_hd: "[a] \p v \ hd v = a" by (auto simp add: prefix_def) lemma suf_last_eq: "p \s u \ p \s v \ p \ \ \ last u = last v" - by (auto simp add: suf_def) + by (auto simp add: suffix_def) lemma comp_hd_eq': "u \ r \ v \ s \ u \ \ \ v \ \ \ hd u = hd v" - using comp_hd_eq[OF comp_prefs_comp]. +using comp_hd_eq[OF comp_prefs_comp]. subsection \Minimal and maximal prefix with a given property\ lemma le_take_pref: assumes "k \ n" shows "take k ws \p take n ws" using take_add[of k "(n-k)" ws, unfolded le_add_diff_inverse[OF \k \ n\]] by force lemma min_pref: assumes "u \p w" and "P u" obtains v where "v \p w" and "P v" and "\ y. y \p w \ P y \ v \p y" using assms proof(induction "\<^bold>|u\<^bold>|" arbitrary: u rule: less_induct) case (less u') then show ?case proof (cases "\ y. y \p w \ P y \ u' \p y", blast) assume "\ (\y. y \p w \ P y \ u' \p y)" then obtain x where "x \p w" and "P x" and " \ u' \p x" by blast have "\<^bold>|x\<^bold>| < \<^bold>|u'\<^bold>|" using prefix_length_less[OF pref_comp_not_pref[OF ruler'[OF \x \p w\ \u' \p w\]\ \ u' \p x\]]. from less.hyps[OF this _ \x \p w\ \P x\] 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 "\ n. P (take n w)" "\<^bold>|u\<^bold>|", unfolded pref_take[OF \u \p w\], OF \P u\] *) - (* have "P v" *) - (* unfolding v_def. *) - (* have "v \p y" if "y \p w" and "P y" for y *) - (* proof- *) - (* have "P (take \<^bold>|y\<^bold>| w)" *) - (* unfolding pref_take[OF \y \p w\] by fact *) - (* from le_take_pref[OF Least_le[of "\ n. P (take n w)" "\<^bold>|y\<^bold>|", unfolded pref_take[OF \y \p w\], OF \P y\], of w, folded v_def] *) - (* show "v \p y" *) - (* unfolding pref_take[OF \y \p w\]. *) - (* qed *) - (* from that[OF _ \P v\ this, unfolded v_def, OF take_is_prefix] *) - (* show thesis. *) -(* qed *) lemma min_pref': assumes "u \p w" and "P u" obtains v where "v \p w" and "P v" and "\ y. y \p v \ P y \ y = v" proof- from min_pref[of _ _ P, OF assms] obtain v where "v \p w" and "P v" and min: "\y. y \p w \ P y \ v \p y" by blast - have "y = v" if "y \p v" and "P y" for y + have "y = v" if "y \p v" and "P y" for y using min[OF pref_trans[OF \y \p v\ \v \p w\] \P y\] \y \p v\ by force from that[OF \v \p w\ \P v\ this] show thesis. qed lemma max_pref: assumes "u \p w" and "P u" obtains v where "v \p w" and "P v" and "\ y. y \p w \ P y \ y \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 "\ y. y \p w \ P y \ y \p u'", blast) + proof (cases "\ y. y \p w \ P y \ y \p u'", blast) assume "\ (\y. y \p w \ P y \ y \p u')" then obtain x where "x \p w" and "P x" and "\ x \p u'" and "u' \ w" by blast from ruler'[OF \x \p w\ \u' \p w\] have "\<^bold>|u'\<^bold>| < \<^bold>|x\<^bold>|" using comp_shorter[OF \x \ u'\] \\ x \p u'\ by fastforce hence "\<^bold>|w\<^bold>| - \<^bold>|x\<^bold>| < \<^bold>|w\<^bold>| - \<^bold>|u'\<^bold>|" using \x \p w\ \u' \ w\ diff_less_mono2 leI[THEN long_pref[OF \u' \p w\]] by blast from less.hyps[OF this _ \x \p w\ \P x\] that show thesis by blast qed qed section "Suffix and suffix comparability properties" lemmas suf_emp = suffix_bot.extremum_uniqueI lemma triv_suf: "u \s v \ u" - by (simp add: suf_def) + by (simp add: suffix_def) lemma emp_ssuf: "u \ \ \ \ v \s w\v \ u \s w" by simp lemma suf_cancel': "u \s w \ u\v \s w\v" by simp lemma ssuf_cancel_conv: "x \ z z \ x Straightforward relations of suffix and prefix follow.\ lemmas suf_rev_pref_iff = suffix_to_prefix \ \provided by Sublist.thy\ lemmas ssuf_rev_pref_iff = strict_suffix_to_prefix \ \provided by Sublist.thy\ lemma pref_rev_suf_iff: "u \p v \ rev u \s rev v" using suffix_to_prefix[of "rev u" "rev v"] unfolding rev_rev_ident by blast lemma spref_rev_suf_iff: "s

rev s ns w \ rev s \np rev w" unfolding nonempty_prefix_def nonempty_suffix_def suffix_to_prefix by fast lemma npref_rev_suf_iff: "s \np w \ rev s \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 + prefE = prefixE and + ssuf_exE = spref_exE[reversed] + +lemmas suf_prod_long_ext = pref_prod_long_ext[reversed] lemmas suf_prolong_per_root = pref_prolong_per_root[reversed] lemmas suf_ext = suffix_appendI \ \provided by Sublist.thy\ 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] and strict_suffixE' = strict_prefixE'[reversed] and ssuf_tl_suf = spref_butlast_pref[reversed] lemma ssuf_Cons_iff [simp]: "u u \s v" - by (auto simp only: strict_suffix_def suffix_Cons) (simp add: suf_def) + by (auto simp only: strict_suffix_def suffix_Cons) (simp add: suffix_def) lemma ssuf_induct [case_names ssuf]: assumes "\u. (\v. v P v) \ P u" shows "P u" proof (induction u rule: list.induct[of "\u. \v. v \s u \ P v", rule_format, OF _ _ triv_suf], use assms suffix_bot.extremum_strict in blast) -qed (metis assms ssuf_Cons_iff suffix_Cons) +qed (metis assms ssuf_Cons_iff suffix_Cons) subsection "Suffix comparability" +lemma eq_le_suf[elim]: assumes "x \ y = u \ v" "\<^bold>|x\<^bold>| \ \<^bold>|u\<^bold>|" shows "v \s y" + using eq_le_pref[reversed, OF assms(1)[symmetric]] + lenarg[OF \x \ y = u \ v\, unfolded lenmorph] \\<^bold>|x\<^bold>| \ \<^bold>|u\<^bold>|\ by linarith + +lemmas eq_le_suf'[elim] = eq_le_pref[reversed] + +lemma eq_le_suf''[elim]: assumes "v \ u = y \ x" "\<^bold>|x\<^bold>| \ \<^bold>|u\<^bold>|" shows "x \s u" + using eq_le_suf'[OF assms(1)[symmetric] assms(2)]. + lemma pref_comp_rev_suf_comp[reversal_rule]: "(rev w) \\<^sub>s (rev v) \ w \ v" unfolding suffix_comparable_def by simp lemma suf_comp_rev_pref_comp[reversal_rule]: "(rev w) \ (rev v) \ w \\<^sub>s v" unfolding suffix_comparable_def by simp lemmas suf_ruler_le = suffix_length_suffix \ \provided by Sublist.thy, same as ruler\_le[reversed]\ lemmas suf_ruler = suffix_same_cases \ \provided by Sublist.thy, same as 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 + ruler_suf' = ruler_pref'[reversed] and ruler_suf'' = ruler_pref''[reversed] and suf_prod_le = pref_prod_le[reversed] and + prod_suf_prod_le = prod_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 + suf_keeps_root = pref_keeps_per_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_cancel = comp_cancel[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] and suf_comp_refl = comp_refl[reversed] -lemma suf_comp_or: "u \\<^sub>s v \ u \s v \ v \s u" +lemma suf_comp_or: "u \\<^sub>s v \ u \s v \ v \s u" unfolding suffix_comparable_def prefix_comparable_def suf_rev_pref_iff.. -lemma comm_comp_eq_conv: "r \ s \ s \ r \ r \ s = s \ r" +lemma comm_comp_eq_conv: "r \ s \ s \ r \ r \ s = s \ r" using pref_comp_eq[OF _ swap_len] comp_refl by metis lemma comm_comp_eq_conv_suf: "r \ s \\<^sub>s s \ r \ r \ s = s \ r" using pref_comp_eq[reversed, OF _ swap_len, of r s] suf_comp_refl[of "r \ s"] by argo lemma suf_comp_last_eq: assumes "u \\<^sub>s v" "u \ \" "v \ \" shows "last u = last v" using comp_hd_eq[reversed, OF assms] unfolding hd_rev hd_rev. lemma suf_comp_last_eq': "r \ u \\<^sub>s s \ v \ u \ \ \ v \ \ \ last u = last v" using comp_sufs_comp suf_comp_last_eq by blast section "Left and Right Quotient" text\A useful function of left quotient is given. Note that the function is sometimes undefined.\ definition left_quotient:: "'a list \ 'a list \ 'a list" ("(_\\<^sup>>)(_)" [75,74] 74) - where left_quotient_def[simp]: "left_quotient u v = (if u \p v then (THE z. u \ z = v) else undefined)" + where "left_quotient u v = drop \<^bold>|u\<^bold>| v" notation (latex output) left_quotient ("\<^latex>\\\ensuremath{ {\_ \<^latex>\}^{-1} \\cdot {\ _ \<^latex>\}}\") + text\Analogously, we define the right quotient.\ definition right_quotient :: "'a list \ 'a list \ 'a list" ("(_)(\<^sup><\_) " [76,77] 76) - where right_quotient_def[simp]: "right_quotient u v = rev ((rev v)\\<^sup>>(rev u))" + where "right_quotient u v = rev ((rev v)\\<^sup>>(rev u))" notation (latex output) right_quotient ("\<^latex>\\\ensuremath{ {\_ \<^latex>\} \\cdot {\ _ \<^latex>\}^{-1}}\") +lemmas lq_def = left_quotient_def and + rq_def = right_quotient_def + text\Priorities of these operations are as follows:\ lemma "u\<^sup><\v\<^sup><\w = (u\<^sup><\v)\<^sup><\w" by simp lemma "u\\<^sup>>v\\<^sup>>w = u\\<^sup>>(v\\<^sup>>w)" by simp lemma "u\\<^sup>>v\<^sup><\w = u\\<^sup>>(v\<^sup><\w)" by simp lemma "r \ u\\<^sup>>w\<^sup><\v \ s = r \ (u\\<^sup>>w\<^sup><\v) \ s" by simp - lemma rq_rev_lq[reversal_rule]: "(rev v)\<^sup><\(rev u) = rev (u\\<^sup>>v)" + unfolding right_quotient_def by simp lemma lq_rev_rq[reversal_rule]: "(rev v)\\<^sup>>rev u = rev (u\<^sup><\v)" + unfolding right_quotient_def by simp subsection \Left Quotient\ lemma lqI: "u \ z = v \ u\\<^sup>>v = z" - by auto + unfolding left_quotient_def + by force lemma lq_triv[simp]: "u\\<^sup>>(u \ z) = z" using lqI[OF refl]. lemma lq_triv'[simp]: "u \ u\\<^sup>>(u \ z) = u \z" by simp lemma append_lq: assumes "u\v \p w" shows "(u\v)\\<^sup>>w = v\\<^sup>>(u\\<^sup>>w)" - using lq_triv[of "u\v"] lq_triv[of "v"] lq_triv[of "u" "v\_"] assms[unfolded pref_def] - by force + using lq_triv[of "u\v"] lq_triv[of "v"] lq_triv[of "u" "v\_"] assms[unfolded prefix_def] + by force lemma lq_self[simp]: "u\\<^sup>>u = \" - by auto + unfolding left_quotient_def + by simp lemma lq_emp[simp]: "\\\<^sup>>u = u" - by auto + unfolding left_quotient_def + by simp lemma lq_pref[simp]: "u \p v \ u \ (u\\<^sup>>v) = v" - by (auto simp add: prefix_def) + unfolding left_quotient_def prefix_def + by fastforce + +lemma lq_pref_conv: "\<^bold>|u\<^bold>| \ \<^bold>|v\<^bold>| \ u \p v \ u \ u\\<^sup>>v = v" + using lq_pref by blast + +lemma lq_len: "\<^bold>|u\\<^sup>>v\<^bold>| = \<^bold>|v\<^bold>| - \<^bold>|u\<^bold>|" + unfolding left_quotient_def using length_drop. lemmas lcp_lq = lq_pref[OF longest_common_prefix_prefix1] lq_pref[OF longest_common_prefix_prefix2] -lemma lq_pref_cancel: "u \p v \ v \ r = u \ s \ (u\\<^sup>>v) \ r = s" - by (auto simp add: prefix_def) - -lemma lq_the[simp]: "u \p v \ (u\\<^sup>>v) = (THE z. u \ z = v)" - by simp +lemma lq_pref_cancel: "u \p v \ v \ r = u \ s \ (u\\<^sup>>v) \ r = s" + unfolding prefix_def + by force + +lemma lq_the: assumes "u \p v" + shows "(THE z. u \ z = v) = (u\\<^sup>>v)" +proof- + have "u\z = v \ z = (u\\<^sup>>v)" for z + by fastforce + from the_equality[of "\z. u\z=v", OF lq_pref this, OF assms] + show ?thesis. +qed + +lemma lq_same_len: "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \ u\\<^sup>>v = \" + unfolding left_quotient_def by simp + +lemma lq_assoc: "\<^bold>|u\<^bold>| \ \<^bold>|v\<^bold>| \ (u\\<^sup>>v)\\<^sup>>w = v\\<^sup>>(u \ w)" + unfolding left_quotient_def using prefix_length_le by auto + +lemma lq_assoc': "(u \ w)\\<^sup>>v = w\\<^sup>>(u\\<^sup>>v)" + unfolding left_quotient_def lenmorph + by (simp add: add.commute) lemma lq_reassoc: "u \p v \ (u\\<^sup>>v)\w = u\\<^sup>>(v\w)" - by (auto simp add: prefix_def) + unfolding prefix_def + by force lemma lq_trans: "u \p v \ v \p w \ (u\\<^sup>>v) \ (v\\<^sup>>w) = u\\<^sup>>w" - by (auto simp add: prefix_def) + by (simp add: lq_reassoc) lemma lq_rq_reassoc_suf: assumes "u \p z" "u \s w" shows "w\u\\<^sup>>z = w\<^sup><\u \ z" - using rassoc[of "w\<^sup><\u" u "u\\<^sup>>z", unfolded lq_pref[OF \u \p z\] lq_pref[reversed, OF \u \s w\]]. + using rassoc[of "w\<^sup><\u" u "u\\<^sup>>z", unfolded lq_pref[OF \u \p z\] lq_pref[reversed, OF \u \s w\]]. lemma lq_ne: "p \p u\p \ u \ \ \ p\\<^sup>>(u\p) \ \" using lq_pref[of p "u \ p"] by fastforce lemma lq_spref: "u

u\\<^sup>>v \ \" using lq_pref by (auto simp add: prefix_def) lemma lq_suf_suf: "r \p s \ (r\\<^sup>>s) \s s" by (auto simp add: prefix_def) -lemma lq_len: "r \p s \ \<^bold>|r\<^bold>| + \<^bold>|r\\<^sup>>s\<^bold>| = \<^bold>|s\<^bold>|" +lemma lq_short_len: "r \p s \ \<^bold>|r\<^bold>| + \<^bold>|r\\<^sup>>s\<^bold>| = \<^bold>|s\<^bold>|" by (auto simp add: prefix_def) -lemma pref_lq: "u \p v \ v \p w \ u\\<^sup>>v \p u\\<^sup>>w" - by (auto simp add: prefix_def) +lemma pref_lq: "v \p w \ u\\<^sup>>v \p u\\<^sup>>w" + unfolding left_quotient_def prefix_def + using drop_append by blast lemma spref_lq: "u \p v \ v

u\\<^sup>>v

\<^sup>>w" by (auto simp add: prefix_def) lemma pref_gcd_lq: assumes "u \p v" shows "(gcd \<^bold>|u\<^bold>| \<^bold>|u\\<^sup>>v\<^bold>|) = gcd \<^bold>|u\<^bold>| \<^bold>|v\<^bold>|" - using gcd_add2[of "\<^bold>|u\<^bold>|" "\<^bold>|u\\<^sup>>v\<^bold>|", unfolded lq_len[OF assms], symmetric]. + using gcd_add2[of "\<^bold>|u\<^bold>|" "\<^bold>|u\\<^sup>>v\<^bold>|", unfolded lq_short_len[OF assms], symmetric]. lemma conjug_lq: "x \ z = z \ y \ y = z\\<^sup>>(x \ z)" by simp lemma conjug_emp_emp: "p \p u \ p \ p\\<^sup>>(u \ p) = \ \ u = \" using lq_ne by blast -lemma lq_drop: "u \p v \ u\\<^sup>>v = drop \<^bold>|u\<^bold>| v" - by (auto simp add: prefix_def) lemma hd_lq_conv_nth: assumes "u

\<^sup>>v) = v!\<^bold>|u\<^bold>|" - using prefix_length_less[OF assms, THEN hd_drop_conv_nth] unfolding lq_drop[OF sprefD1[OF assms]]. + using prefix_length_less[OF assms, THEN hd_drop_conv_nth] unfolding lq_def. lemma concat_morph_lq: "us \p ws \ concat (us\\<^sup>>ws) = (concat us)\\<^sup>>(concat ws)" by (auto simp add: prefix_def) -lemma lq_code [code]: - "left_quotient \ v = v" - "left_quotient (a#u) \ = 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 \p x \ y \ \<^bold>|x\<^bold>| \ \<^bold>|u\<^bold>| \ x\\<^sup>>u \p y" - using lq_pref[OF pref_prod_long] pref_cancel by metis + +lemma pref_cancel_lq: assumes "u \p x \ y" + shows "x\\<^sup>>u \p y" + using pref_lq[OF \u \p x \ y\, of x, unfolded lq_triv]. lemma pref_cancel_lq_ext: assumes "u \ v \p x \ y" and "\<^bold>|x\<^bold>| \ \<^bold>|u\<^bold>|" shows "x\\<^sup>>u \ v \p y" proof- note pref_prod_long[OF append_prefixD, OF \u \ v \p x \ y\ \\<^bold>|x\<^bold>| \ \<^bold>|u\<^bold>|\] - from pref_cancel_lq[OF \u \ v \p x \ y\] + from pref_cancel_lq[OF \u \ v \p x \ y\] show "x\\<^sup>>u \ v \p y" unfolding lq_reassoc[OF \x \p u\] using \\<^bold>|x\<^bold>| \ \<^bold>|u\<^bold>|\ by force qed lemma pref_cancel_lq_ext': assumes "u \ v \p x \ y" and "\<^bold>|u\<^bold>| \ \<^bold>|x\<^bold>|" shows "v \p u\\<^sup>>x \ y" - using pref_lq[OF triv_pref \u \ v \p x \ y\] + using pref_lq[OF \u \ v \p x \ y\, of u] unfolding lq_triv lq_reassoc[OF pref_prod_le[OF append_prefixD[OF \u \ v \p x \ y\] \\<^bold>|u\<^bold>| \ \<^bold>|x\<^bold>|\]]. lemma empty_lq_eq: "r \p z \ r\\<^sup>>z = \ \ r = z" unfolding prefix_def by force +lemma le_if_then_lq: "\<^bold>|u\<^bold>| \ \<^bold>|v\<^bold>| \ (if \<^bold>|v\<^bold>| \ \<^bold>|u\<^bold>| then v\\<^sup>>u else u\\<^sup>>v) = u\\<^sup>>v" + by (cases "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|", simp_all add: lq_same_len) + +lemma append_comp_lq: "u \ v \ w \ v \ u\\<^sup>>w" +proof (elim pref_compE) + assume "u \ v \p w" + from pref_drop[OF this, of "\<^bold>|u\<^bold>|", unfolded drop_pref] + show "v \ u\\<^sup>>w" + unfolding left_quotient_def by (rule pref_compI1) +next + assume "w \p u \ v" + from pref_drop[OF this, of "\<^bold>|u\<^bold>|", unfolded drop_pref] + show "v \ u\\<^sup>>w" + unfolding left_quotient_def by (rule pref_compI2) +qed + subsection "Right quotient" lemmas rqI = lqI[reversed] and - rq_triv = lq_triv[reversed] and - rq_triv' = lq_triv'[reversed] and - rq_self = lq_self[reversed] and - rq_emp = lq_emp[reversed] and - rq_suf = lq_pref[reversed] and + rq_triv[simp] = lq_triv[reversed] and + rq_triv'[simp] = lq_triv'[reversed] and + rq_self[simp] = lq_self[reversed] and + rq_emp[simp] = lq_emp[reversed] and + rq_suf[simp] = 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] and + rq_take = lq_def[reversed] and empty_rq_eq = empty_lq_eq[reversed] and - append_rq = append_lq[reversed] - + append_rq = append_lq[reversed] and + rq_same_len = lq_same_len[reversed] and + rq_assoc = lq_assoc[reversed] and + rq_assoc' = lq_assoc'[reversed] and + le_if_then_rq = le_if_then_lq[reversed] and + append_comp_rq = append_comp_lq[reversed] subsection \Left and right quotients combined\ lemma pref_lq_rq_id: "p \p w \ w\<^sup><\(p\\<^sup>>w) = p" - by (auto simp add: prefix_def) - + unfolding prefix_def + using rq_triv[of p "p\\<^sup>>w"] by force lemmas suf_rq_lq_id = pref_lq_rq_id[reversed] lemma rev_lq': "r \p s \ rev (r\\<^sup>>s) = (rev s)\<^sup><\(rev r)" - by simp + by (simp add: rq_rev_lq) lemma pref_rq_suf_lq: "s \s u \ r \p (u\<^sup><\s) \ s \s (r\\<^sup>>u)" using lq_reassoc[of r "u\<^sup><\s" s] rq_suf[of s u] triv_suf[of s "r\\<^sup>>u\<^sup><\s"] by presburger lemmas suf_lq_pref_rq = pref_rq_suf_lq[reversed] lemma "w\s = v \ v\<^sup><\s = w" using rqI. lemma lq_rq_assoc: "s \s u \ r \p (u\<^sup><\s) \ (r\\<^sup>>u)\<^sup><\s = r\\<^sup>>(u\<^sup><\s)" using lq_reassoc[of r "u\<^sup><\s" s] rq_suf[of s u] rqI[of "r\\<^sup>>u\<^sup><\s" s "r\\<^sup>>u"] by argo lemmas rq_lq_assoc = lq_rq_assoc[reversed] lemma lq_prod: "u \p v\u \ u \p w \ u\\<^sup>>(v\u)\u\\<^sup>>w = u\\<^sup>>(v\w)" - using lq_reassoc[of u "v \ u" "u\\<^sup>>w"] lq_rq_reassoc_suf[of u w "v \ u", unfolded rq_triv[of v u]] - by (simp add: suf_def) + using lq_reassoc[of u "v \ u" "u\\<^sup>>w"] lq_rq_reassoc_suf[of u w "v \ u", unfolded rq_triv[of v u]] + by (simp add: suffix_def) lemmas rq_prod = lq_prod[reversed] +lemma pref_suf_mid: assumes "p\w\s = p'\v\s'" and "p \p p'" and "s \s s'" + shows "v \f w" +proof- + have "p\w\s = (p \ p\\<^sup>>p') \ v \ (s'\<^sup><\s \ s)" + using \p\w\s = p'\v\s'\ + unfolding lq_pref[OF \p \p p'\] rq_suf[OF \s \s s'\]. + thus ?thesis + by simp +qed + section \Equidivisibility\ text\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. \ - +thm append_eq_conv_conj[folded left_quotient_def] lemma eqd: "x \ y = u \ v \ \<^bold>|x\<^bold>| \ \<^bold>|u\<^bold>| \ \ t. x \ t = u \ t \ v = y" by (simp add: append_eq_conv_conj) lemma eqdE: assumes "x \ y = u \ v" and "\<^bold>|x\<^bold>| \ \<^bold>|u\<^bold>|" obtains t where "x \ t = u" and "t \ v = y" using eqd[OF assms] by blast +lemma eqd_lessE: assumes "x \ y = u \ v" and "\<^bold>|x\<^bold>| < \<^bold>|u\<^bold>|" + obtains t where "x \ t = u" and "t \ v = y" and "t \ \" + using eqdE[OF assms(1) less_imp_le[OF assms(2)]] assms(2) + using append.right_neutral less_not_refl by metis + lemma eqdE': assumes "x \ y = u \ v" and "\<^bold>|v\<^bold>| \ \<^bold>|y\<^bold>|" obtains t where "x \ t = u" and "t \ v = y" 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 \ y = u \ v" shows "x \p u \ v \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 \ y = u \ v" shows "x

v y = u \ v \ \<^bold>|x\<^bold>| \ \<^bold>|u\<^bold>| \ x \ (x\\<^sup>>u) = u \ (x\\<^sup>>u) \ v = y" using eqd lq_triv by blast lemma eqd_pref1: "x \ y = u \ v \ \<^bold>|x\<^bold>| \ \<^bold>|u\<^bold>| \ x \ (x\\<^sup>>u) = u" using eqd_pref by blast lemma eqd_pref2: "x \ y = u \ v \ \<^bold>|x\<^bold>| \ \<^bold>|u\<^bold>| \ (x\\<^sup>>u) \ v = y" using eqd_pref by blast -lemma eqd_eq: "x \ y = u \ v \ \<^bold>|x\<^bold>| = \<^bold>|u\<^bold>| \ x = u \ y = v" - by simp - -lemma pref_equal: "u \p v \ w \ \<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \ u = v" - by (simp add: prefix_def) - -lemma eqd_equal_suf: "x \ y = u \ v \ \<^bold>|y\<^bold>| = \<^bold>|v\<^bold>| \ x = u \ y = v" +lemma eqd_eq: assumes "x \ y = u \ v" "\<^bold>|x\<^bold>| = \<^bold>|u\<^bold>|" shows "x = u" "y = v" + using assms by simp_all + +lemma eqd_eq_suf: "x \ y = u \ v \ \<^bold>|y\<^bold>| = \<^bold>|v\<^bold>| \ x = u \ y = v" by simp lemma eqd_comp: assumes "x \ y = u \ v" shows "x \ u" using le_cases[of "\<^bold>|x\<^bold>|" "\<^bold>|u\<^bold>|" "x \ u"] eqd_pref1[of x y u v, THEN prefI[of x "x\\<^sup>>u" u], OF assms] eqd_pref1[of u v x y, THEN prefI[of u "u\\<^sup>>x" x], OF assms[symmetric]] by auto \ \not equal to eqd\_pref1[reversed]\ lemma eqd_suf1: "x \ y = u \ v \ \<^bold>|x\<^bold>| \ \<^bold>|u\<^bold>| \ (y\<^sup><\v)\v = y" using eqd_pref2 rq_triv by blast \ \not equal to eqd\_pref2[reversed]\ lemma eqd_suf2: assumes "x \ y = u \ v" "\<^bold>|x\<^bold>| \ \<^bold>|u\<^bold>|" shows "x \ (y\<^sup><\v) = u" using rq_reassoc[OF sufI[OF eqd_suf1[OF \x \ y = u \ v\ \\<^bold>|x\<^bold>| \ \<^bold>|u\<^bold>|\]], of x, unfolded \x \ y = u \ v\ rq_triv[of u v]]. \ \ not equal to eqd\_pref[reversed] \ lemma eqd_suf: assumes "x \ y = u \ v" and "\<^bold>|x\<^bold>| \ \<^bold>|u\<^bold>|" shows "(y\<^sup><\v)\v = y \ x \ (y\<^sup><\v) = u" using eqd_suf1[OF assms] eqd_suf2[OF assms] by blast -context -begin -private lemma eqd_exchange_aux: +lemma eqd_exchange_aux: assumes "u \ v = x \ y" and "u \ v' = x \ y'" and "u' \ v = x' \ y" and "\<^bold>|u\<^bold>| \ \<^bold>|x\<^bold>|" - shows "u' \ v' = x' \ y'" + shows "u' \ v' = x' \ y'" using eqd[OF \u \ v = x \ y\ \\<^bold>|u\<^bold>| \ \<^bold>|x\<^bold>|\] eqd[OF \u \ v' = x \ y'\ \\<^bold>|u\<^bold>| \ \<^bold>|x\<^bold>|\] \u' \ v = x' \ y\ by force lemma eqd_exchange: assumes "u \ v = x \ y" and "u \ v' = x \ y'" and "u' \ v = x' \ y" - shows "u' \ v' = x' \ y'" + shows "u' \ v' = x' \ y'" using eqd_exchange_aux[OF assms] eqd_exchange_aux[OF assms[symmetric], symmetric] by force -end + +hide_fact eqd_exchange_aux section \Longest common prefix\ lemmas lcp_simps = longest_common_prefix.simps \ \provided by Sublist.thy\ -lemma lcp_sym: "u \\<^sub>p v = v \\<^sub>p u" - by (induct u v rule: list_induct2') auto +lemmas lcp_sym = lcp.commute \ \provided by Sublist.thy\ lemmas lcp_pref = longest_common_prefix_prefix1 lemmas lcp_pref' = longest_common_prefix_prefix2 lemmas pref_pref_lcp[intro] = longest_common_prefix_max_prefix lemma lcp_pref_ext: "u \p v \ u \p (u \ w) \\<^sub>p (v \ z)" using longest_common_prefix_max_prefix prefix_prefix triv_pref by metis lemma pref_non_pref_lcp_pref: assumes "u \p w" and "\ u \p z" shows "w \\<^sub>p z

u \p w\ lcp_pref, of z, unfolded prefix_comparable_def] with pref_trans[of u "w \\<^sub>p z", OF _ lcp_pref'] \\ u \p z\ show "w \\<^sub>p z

|u \\<^sub>p v\<^bold>|) u = take (\<^bold>|u \\<^sub>p v\<^bold>|) v" unfolding lcp_take lcp_take'.. lemma lcp_pref_conv: "u \\<^sub>p v = u \ u \p v" unfolding prefix_order.eq_iff[of "u \\<^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 \\<^sub>p v = v \ v \p u" using lcp_pref_conv[of v u, unfolded lcp_sym[of v]]. +lemmas lcp_left_idemp[simp] = lcp_pref[folded lcp_pref_conv'] and + lcp_right_idemp[simp] = lcp_pref'[folded lcp_pref_conv] and + lcp_left_idemp'[simp] = lcp_pref'[folded lcp_pref_conv'] and + lcp_right_idemp'[simp] = lcp_pref[folded lcp_pref_conv] + lemma lcp_per_root: "r \ s \\<^sub>p s \ r \p r \ (r \ s \\<^sub>p s \ r)" using pref_prod_pref[OF pref_prolong[OF lcp_pref triv_pref] lcp_pref']. lemma lcp_per_root': "r \ s \\<^sub>p s \ r \p s \ (r \ s \\<^sub>p s \ r)" using lcp_per_root[of s r, unfolded lcp_sym[of "s \ r"]]. lemma pref_lcp_pref: "w \p u \\<^sub>p v \ w \p u" using lcp_pref pref_trans by blast lemma pref_lcp_pref': "w \p u \\<^sub>p v \ w \p v" using pref_lcp_pref[of w v u, unfolded lcp_sym[of v u]]. -lemma lcp_self[simp]: "w \\<^sub>p w = w" - using lcp_pref_conv by blast +lemmas lcp_self = lcp.idem lemma lcp_eq_len: "\<^bold>|u\<^bold>| = \<^bold>|u \\<^sub>p v\<^bold>| \ u = u \\<^sub>p v" using long_pref[OF lcp_pref, of u v] by auto lemma lcp_len: "\<^bold>|u\<^bold>| \ \<^bold>|u \\<^sub>p v\<^bold>| \ u \p v" using long_pref[OF lcp_pref, of u v] unfolding lcp_pref_conv[symmetric]. lemma lcp_len': "\ u \p v \ \<^bold>|u \\<^sub>p v\<^bold>| < \<^bold>|u\<^bold>|" using not_le_imp_less[OF contrapos_nn[OF _ lcp_len]]. lemma incomp_lcp_len: "\ u \ v \ \<^bold>|u \\<^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: "\ r \ r' \ (r \ u) \\<^sub>p (r' \ v) = r \\<^sub>p r'" - by (induct r r' rule: list_induct2', simp+) + unfolding prefix_comparable_def + by (induct r r' rule: list_induct2') simp_all lemma lcp_ext_right [case_names comp non_comp]: obtains "r \ r'" | "(r \ u) \\<^sub>p (r' \ v) = r \\<^sub>p r'" using lcp_ext_right_conv by blast lemma lcp_same_len: "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>| \ u \ v \ u \ w \\<^sub>p v \ w' = u \\<^sub>p v" using pref_comp_eq by (cases rule: lcp_ext_right) (elim notE) lemma lcp_mismatch: "\<^bold>|u \\<^sub>p v\<^bold>| < \<^bold>|u\<^bold>| \ \<^bold>|u \\<^sub>p v\<^bold>| < \<^bold>|v\<^bold>| \ u! \<^bold>|u \\<^sub>p v\<^bold>| \ v! \<^bold>|u \\<^sub>p v\<^bold>|" by (induct u v rule: list_induct2') auto lemma lcp_mismatch': "\ u \ v \ u! \<^bold>|u \\<^sub>p v\<^bold>| \ v! \<^bold>|u \\<^sub>p v\<^bold>|" - using incomp_lcp_len lcp_mismatch unfolding min_less_iff_conj.. + using incomp_lcp_len lcp_mismatch unfolding min_less_iff_conj.. lemma lcp_mismatchE: assumes "\ us \ vs" obtains us' vs' where "(us \\<^sub>p vs) \ us' = us" and "(us \\<^sub>p vs) \ vs' = vs" and "us' \ \" and "vs' \ \" and "hd us' \ hd vs'" proof - obtain us' vs' where us: "(us \\<^sub>p vs) \ us' = us" and vs: "(us \\<^sub>p vs) \ vs' = vs" using prefixE[OF lcp_pref prefixE[OF lcp_pref']] unfolding eq_commute[of "x\y" for x y]. with \\ us \ vs\ have "us' \ \" and "vs' \ \" unfolding prefix_comparable_def lcp_pref_conv[symmetric] lcp_sym[of vs] by fastforce+ hence "us! \<^bold>|us \\<^sub>p vs\<^bold>| = hd us'" and "vs! \<^bold>|us \\<^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 \\ us \ vs\, unfolded this] have "hd us' \ hd vs'". from that[OF us vs \us' \ \\ \vs' \ \\ this] show thesis. qed lemma lcp_mismatch_lq: assumes "\ u \ v" shows - "(u \\<^sub>p v)\\<^sup>>u \ \" and - "(u \\<^sub>p v)\\<^sup>>v \ \" and + "(u \\<^sub>p v)\\<^sup>>u \ \" and + "(u \\<^sub>p v)\\<^sup>>v \ \" and "hd ((u \\<^sub>p v)\\<^sup>>u) \ hd ((u \\<^sub>p v)\\<^sup>>v)" proof- from lcp_mismatchE[OF assms] obtain su sv where "(u \\<^sub>p v) \ su = u" and "(u \\<^sub>p v) \ sv = v" and "su \ \" and "sv \ \" and "hd su \ hd sv". thus "(u \\<^sub>p v)\\<^sup>>u \ \" and "(u \\<^sub>p v)\\<^sup>>v \ \" and "hd ((u \\<^sub>p v)\\<^sup>>u) \ hd ((u \\<^sub>p v)\\<^sup>>v)" using lqI[OF \(u \\<^sub>p v) \ su = u\] lqI[OF \(u \\<^sub>p v) \ sv = v\] by blast+ qed lemma lcp_ext_left: "(z \ u) \\<^sub>p (z \ v) = z \ (u \\<^sub>p v)" by (induct z) auto lemma lcp_first_letters: "u!0 \ v!0 \ u \\<^sub>p v = \" by (induct u v rule: list_induct2') auto lemma lcp_first_mismatch: "a \ b \ w \ [a] \ u \\<^sub>p w \ [b] \ v = w" by (simp add: lcp_ext_left) lemma lcp_first_mismatch': "a \ b \ u \ [a] \\<^sub>p u \ [b] = u" using lcp_first_mismatch[of a b u \ \] by simp lemma lcp_mismatch_eq_len: assumes "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|" "x \ y" shows "u \ [x] \\<^sub>p v \ [y] = u \\<^sub>p v" using lcp_self lcp_first_mismatch'[OF \x \ y\] lcp_same_len[OF \\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|\] by (cases "u = v") auto lemma lcp_first_mismatch_pref: assumes "p \ [a] \p u" and "p \ [b] \p v" and "a \ b" shows "u \\<^sub>p v = p" using assms(1-2) lcp_first_mismatch[OF \a \ b\] unfolding prefix_def rassoc by blast -lemma lcp_rulersE: assumes "r \p s" and "r' \p s'" obtains "r \ r'" | "s \\<^sub>p s' = r \\<^sub>p r'" - by (cases rule: lcp_ext_right[of _ _ _ "r\\<^sup>>s" "r'\\<^sup>>s'"]) (assumption, simp only: assms lq_pref) - -lemma lcp_rulers: "r \p s \ r' \p s' \ (r \ r' \ s \\<^sub>p s' = r \\<^sub>p r')" - by (cases rule: lcp_ext_right[of _ _ _ "r\\<^sup>>s" "r'\\<^sup>>s'"], blast) (meson lcp_rulersE) - -lemma lcp_rulers': "w \p r \ w' \p s \ \ w \ w' \ (r \\<^sub>p s) = w \\<^sub>p w'" - using lcp_rulers by blast - -lemma lcp_pref_monotone: assumes "w \p r" and "w' \p s" shows "w \\<^sub>p w' \p (r \\<^sub>p s)" - by (intro pref_pref_lcp, - intro pref_trans[OF _ \w \p r\], - intro lcp_pref, - intro pref_trans[OF _ \w' \p s\], - intro lcp_pref') - lemma lcp_append_monotone: "u \\<^sub>p x \p (u \ v) \\<^sub>p (x \ y)" - by (simp add: lcp_pref_monotone) + by (simp add: lcp.mono) lemma lcp_distinct_hd: "hd u \ hd v \ u \\<^sub>p v = \" using pref_hd_eq'[OF lcp_pref lcp_pref'] by blast lemma nemp_lcp_distinct_hd: assumes "u \ \" and "v \ \" and "u \\<^sub>p v = \" shows "hd u \ hd v" proof assume "hd u = hd v" - from lcp_ext_left[of "[hd u]" "tl u" "tl v", + from lcp_ext_left[of "[hd u]" "tl u" "tl v", unfolded hd_tl[OF \u \ \\] hd_tl[OF \v \ \\, folded this]] - show False + show False using \u \\<^sub>p v = \\ 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 \ v!i" shows "i = \<^bold>|u \\<^sub>p v\<^bold>|" proof- have u: "take i u \ [u ! i] \ drop (Suc i) u = u" using \i < min \<^bold>|u\<^bold>| \<^bold>|v\<^bold>|\ id_take_nth_drop[of i u] by simp have v: "take i u \ [v ! i] \ drop (Suc i) v = v" using \i < min \<^bold>|u\<^bold>| \<^bold>|v\<^bold>|\ unfolding \take i u = take i v\ using id_take_nth_drop[of i v] by force from lcp_first_mismatch[OF \u!i \ v!i\, of "take i u" "drop (Suc i) u" "drop (Suc i) v", unfolded u v] have "u \\<^sub>p v = take i u". thus ?thesis using \i < min \<^bold>|u\<^bold>| \<^bold>|v\<^bold>|\ by auto qed lemma lcp_prefs: "\<^bold>|u \ w \\<^sub>p v \ w'\<^bold>| < \<^bold>|u\<^bold>| \ \<^bold>|u \ w \\<^sub>p v \ w'\<^bold>| < \<^bold>|v\<^bold>| \ u \\<^sub>p v = u \ w \\<^sub>p v \ w'" by (induct u v rule: list_induct2') auto +lemma lcp_extend_eq: assumes "u \p v" and "u' \p v'" and + "\<^bold>|v \\<^sub>p v'\<^bold>| \ \<^bold>|u\<^bold>|" and "\<^bold>|v \\<^sub>p v'\<^bold>| \ \<^bold>|u'\<^bold>|" + shows "u \\<^sub>p u' = v \\<^sub>p v'" +proof- + consider "\<^bold>|v \\<^sub>p v'\<^bold>| = \<^bold>|u\<^bold>|" | "\<^bold>|v \\<^sub>p v'\<^bold>| = \<^bold>|u'\<^bold>|" | "\<^bold>|v \\<^sub>p v'\<^bold>| < \<^bold>|u\<^bold>| \ \<^bold>|v \\<^sub>p v'\<^bold>| < \<^bold>|u'\<^bold>|" + using assms(3-4) by force + thus ?thesis + proof (cases) + assume "\<^bold>|v \\<^sub>p v'\<^bold>| = \<^bold>|u\<^bold>|" + from ruler_eq_len[OF longest_common_prefix_prefix1 \u \p v\ this] + have "u \p u'" + using prefix_length_prefix[OF longest_common_prefix_prefix2 assms(2,4)] by blast + thus ?thesis + unfolding \v \\<^sub>p v' = u\ lcp_pref_conv. + next + assume "\<^bold>|v \\<^sub>p v'\<^bold>| = \<^bold>|u'\<^bold>|" + from ruler_eq_len[OF longest_common_prefix_prefix2 \u' \p v'\ this] + have "u' \p u" + using prefix_length_prefix[OF longest_common_prefix_prefix1 assms(1,3)] by blast + thus ?thesis + unfolding \v \\<^sub>p v' = u'\ lcp_pref_conv'. + next + assume "\<^bold>|v \\<^sub>p v'\<^bold>| < \<^bold>|u\<^bold>| \ \<^bold>|v \\<^sub>p v'\<^bold>| < \<^bold>|u'\<^bold>|" + thus ?thesis + using lcp_prefs[of u "u\\<^sup>>v" u' "u'\\<^sup>>v'", unfolded lq_pref[OF \u \p v\] lq_pref[OF \u' \p v'\]] + by blast + qed +qed + +lemma long_lcp_same: assumes "\ (u \\<^sub>p v \p w)" shows "u \\<^sub>p w = v \\<^sub>p w" +proof- + have "v \\<^sub>p w \p u" + using ruler[OF lcp_pref' lcp_pref', of u v w] assms unfolding lcp_sym[of v] by force + have "u \\<^sub>p w \p v" + using ruler[OF lcp_pref lcp_pref, of u v w] assms by force + show ?thesis + unfolding prefix_order.eq_iff + using \v \\<^sub>p w \p u\ \u \\<^sub>p w \p v\ by force +qed + +lemma long_lcp_sameE: obtains "u \\<^sub>p v \p w" | "u \\<^sub>p w = v \\<^sub>p w" + using long_lcp_same by blast + +lemma ruler_spref_lcp: assumes "u \\<^sub>p w

\<^sub>p w" + shows "u \\<^sub>p v = u \\<^sub>p w" +proof- + have "\ v \\<^sub>p w \p u" + using prefix_order.leD[of "v \\<^sub>p w" "u \\<^sub>p w"] assms by force + from long_lcp_same[OF this] + show ?thesis + unfolding lcp_sym[of u]. +qed + subsection "Longest common prefix and prefix comparability" - +find_theorems name:ruler lemma lexord_cancel_right: "(u \ z, v \ w) \ lexord r \ \ u \ v \ (u,v) \ lexord r" - by (induction rule: list_induct2', simp+, auto) - -lemma lcp_ruler: "r \ w1 \ r \ w2 \ \ w1 \ w2 \ r \p w1 \\<^sub>p w2" + unfolding prefix_comparable_def + by (induction rule: list_induct2') auto + +lemma lcp_rulersE: assumes "r \p s" and "r' \p s'" obtains "r \ r'" | "s \\<^sub>p s' = r \\<^sub>p r'" + by (cases rule: lcp_ext_right[of _ _ _ "r\\<^sup>>s" "r'\\<^sup>>s'"]) (assumption, simp only: assms lq_pref) + +lemma lcp_rulers: "r \p s \ r' \p s' \ (r \ r' \ s \\<^sub>p s' = r \\<^sub>p r')" + by (cases rule: lcp_ext_right[of _ _ _ "r\\<^sup>>s" "r'\\<^sup>>s'"], blast) (meson lcp_rulersE) + +lemma lcp_rulers': "w \p r \ w' \p s \ \ w \ w' \ (r \\<^sub>p s) = w \\<^sub>p w'" + using lcp_rulers by blast + +lemma lcp_ruler: "r \ w1 \ r \ w2 \ \ w1 \ w2 \ r \p w1 \\<^sub>p w2" unfolding prefix_comparable_def by (meson pref_pref_lcp pref_trans ruler) lemma comp_monotone: "w \ r \ u \p w \ u \ r" - using pref_compI1[OF pref_trans] ruler' by (elim pref_compE) + using pref_compI1[OF pref_trans] ruler' by (elim pref_compE) lemma comp_monotone': "w \ r \ w \\<^sub>p w' \ r" using comp_monotone[OF _ lcp_pref]. -lemma double_ruler: assumes "w \ r" and "w' \ r'" - shows "\ r \ r' \ w \\<^sub>p w' \p r \\<^sub>p r'" - using comp_monotone'[OF \w' \ r'\] unfolding lcp_sym[of w'] - by (rule lcp_ruler[OF comp_monotone'[OF \w \ r\]]) - -lemma pref_lcp_iff: "w \p u \\<^sub>p v \ w \p u \ w \p v" - by (intro iffI conjI longest_common_prefix_max_prefix) - (blast dest: pref_lcp_pref pref_lcp_pref')+ +lemma double_ruler_aux: assumes "w \ r" and "w' \ r'" and "\ r \ r'" and "\<^bold>|w\<^bold>| \ \<^bold>|w'\<^bold>|" + shows "w \\<^sub>p w' = take \<^bold>|w\<^bold>| (r \\<^sub>p r')" +proof- + have pref1: "w \\<^sub>p w' \p r \\<^sub>p r'" + using comp_monotone'[OF \w' \ r'\] lcp_ruler[OF comp_monotone'[OF \w \ r\] _ \\ r \ r'\] + unfolding lcp_sym[of w'] by simp + show ?thesis + proof (cases) + assume "w \ w'" + hence "w \\<^sub>p w' = w" + using \\<^bold>|w\<^bold>| \ \<^bold>|w'\<^bold>|\ + by (simp add: comp_shorter lcp.absorb1) + show ?thesis + using pref_take[OF pref1, symmetric] unfolding \w \\<^sub>p w' = w\. + next + assume "\ w \ w'" + hence pref2: "r \\<^sub>p r' \p w \\<^sub>p w'" + using comp_monotone'[OF \w' \ r'\[symmetric]] lcp_ruler[OF comp_monotone'[OF \w \ r\[symmetric]] _ \\ w \ w'\] + unfolding lcp_sym[of r'] by simp + hence "w \\<^sub>p w' = r \\<^sub>p r'" + using pref1 pref_antisym by blast + then show ?thesis + using lcp_take len_take2 take_all_iff by metis + qed +qed + +lemma double_ruler: assumes "w \ r" and "w' \ r'" and "\ r \ r'" + shows "w \\<^sub>p w' = take (min \<^bold>|w\<^bold>| \<^bold>|w'\<^bold>|) (r \\<^sub>p r')" + by (cases "\<^bold>|w\<^bold>|" "\<^bold>|w'\<^bold>|" rule: le_cases) + (use double_ruler_aux[OF assms] double_ruler_aux[OF assms(2,1) assms(3)[symmetric], unfolded lcp_sym[of r'] lcp_sym[of w']] + in linarith)+ + +hide_fact double_ruler_aux + +lemmas pref_lcp_iff = lcp.bounded_iff lemma pref_comp_ruler: assumes "w \ u \ [x]" and "w \ v \ [y]" and "x \ y" and "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|" shows "w \p u \ w \p v" using double_ruler[OF \w \ u \ [x]\ \w \ v \ [y]\ mismatch_incopm[OF \\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|\ \x \ y\]] - unfolding lcp_self lcp_mismatch_eq_len[OF \\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|\ \x \ y\] pref_lcp_iff. + take_is_prefix lcp_self lcp_mismatch_eq_len[OF \\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|\ \x \ y\] pref_lcp_iff by metis + +lemma comp_per_partes: + shows "(u \ w \ v \ u\\<^sup>>w) \ u \ v \ w" +proof + assume "u \ v \ w" + from comp_monotone[OF _ triv_pref, OF this] append_comp_lq[OF this] + show "u \ w \ v \ u\\<^sup>>w" + by blast +next + assume c2: "u \ w \ v \ u\\<^sup>>w" + hence "u \ v \ u \ u\\<^sup>>w" + unfolding comp_cancel by blast + show "u \ v \ w" + by (rule pref_compE[OF conjunct1[OF c2]], use \u \ v \ u \ u\\<^sup>>w\ in force,blast) +qed + +lemmas scomp_per_partes = comp_per_partes[reversed] + subsection \Longest common suffix\ definition longest_common_suffix ("_ \\<^sub>s _ " [61,62] 64) - where - "longest_common_suffix u v \ rev (rev u \\<^sub>p rev v)" + where + "longest_common_suffix u v \ rev (rev u \\<^sub>p rev v)" lemma lcs_lcp [reversal_rule]: "rev u \\<^sub>p rev v = rev (u \\<^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_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 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 + 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_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 + suf_suf_lcs' = lcp.mono[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 \The first pair of letters on which two words/lists disagree\ function mismatch_pair :: "'a list \ 'a list \ ('a \ 'a)" where "mismatch_pair \ v = (\!0, v!0)" | "mismatch_pair v \ = (v!0, \!0)" | "mismatch_pair (a#u) (b#v) = (if a=b then mismatch_pair u v else (a,b))" - using shuffles.cases by blast+ + using shuffles.cases by blast+ termination by (relation "measure (\ (t,s). length t)", simp_all) text \Alternatively, mismatch pair may be defined using the longest common prefix as follows.\ lemma mismatch_pair_lcp: "mismatch_pair u v = (u!\<^bold>|u\\<^sub>pv\<^bold>|,v!\<^bold>|u\\<^sub>pv\<^bold>|)" -proof(induction u v rule: mismatch_pair.induct, simp+) -qed + by (induction u v rule: mismatch_pair.induct) simp_all text \For incomparable words the pair is out of diagonal.\ lemma incomp_neq: "\ u \ v \ (mismatch_pair u v) \ Id" unfolding mismatch_pair_lcp by (simp add: lcp_mismatch') lemma mismatch_ext_left: "\ u \ v \ mismatch_pair u v = mismatch_pair (p\u) (p\v)" unfolding mismatch_pair_lcp by (simp add: lcp_ext_left) lemma mismatch_ext_right: assumes "\ u \ v" shows "mismatch_pair u v = mismatch_pair (u\z) (v\w)" proof- have less1: "\<^bold>|u \\<^sub>p v\<^bold>| < \<^bold>|u\<^bold>|" and less2: "\<^bold>|v \\<^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: "\ u \ v \ i < min \<^bold>|u\<^bold>| \<^bold>|v\<^bold>| \ take i u = take i v \ u!i \ v!i \ mismatch_pair u v = (u!i,v!i)" unfolding mismatch_pair_lcp using lcp_lenI by blast text \For incomparable words, the mismatch letters work in a similar way as the lexicographic order\ lemma mismatch_lexord: assumes "\ u \ v" and "mismatch_pair u v \ r" shows "(u,v) \ lexord r" unfolding lexord_take_index_conv mismatch_pair_lcp using \mismatch_pair u v \ r\[unfolded mismatch_pair_lcp] incomp_lcp_len[OF assms(1)] lcp_take_eq by blast text \However, the equivalence requires r to be irreflexive. (Due to the definition of lexord which is designed for irreflexive relations.)\ lemma lexord_mismatch: assumes "\ u \ v" and "irrefl r" shows "mismatch_pair u v \ r \ (u,v) \ lexord r" proof assume "(u,v) \ 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) \ r" using \(u,v) \ lexord r\[unfolded lexord_take_index_conv] \\ u \ v\ pref_take_conv by blast have "u!i \ v!i" using \irrefl r\[unfolded irrefl_def] \(u ! i, v ! i) \ r\ by fastforce from \(u ! i, v ! i) \ r\[folded mismatchI[OF \\ u \ v\ \i < min \<^bold>|u\<^bold>| \<^bold>|v\<^bold>|\ \take i u = take i v\ \u!i \ v!i\]] show "mismatch_pair u v \ r". next from mismatch_lexord[OF \\ u \ v\] show "mismatch_pair u v \ r \ (u, v) \ lexord r". qed section "Factor properties" lemmas [simp] = sublist_Cons_right lemma rev_fac[reversal_rule]: "rev u \f rev v \ u \f v" using Sublist.sublist_rev. lemma fac_pref: "u \f v \ \ p. p \ u \p v" by (simp add: prefix_def fac_def) lemma fac_pref_suf: "u \f v \ \ p. p \p v \ u \s p" using sublist_altdef by blast lemma pref_suf_fac: "r \p v \ u \s r \ u \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 \s p \ p \p s \ p = s" using sublist_order.order.eq_iff by blast lemma fac_triv: "p\x\q = x \ p = \" using long_pref[OF prefI suf_len'] unfolding append_self_conv2 rassoc. lemma fac_triv': "p\x\q = x \ q = \" using fac_triv[reversed] unfolding rassoc. lemmas suf_fac = suffix_imp_sublist and pref_fac = prefix_imp_sublist lemma fac_ConsE: assumes "u \f (a#v)" obtains "u \p (a#v)" | "u \f v" using assms unfolding sublist_Cons_right by blast lemmas fac_snocE = fac_ConsE[reversed] lemma fac_elim_suf: assumes "f \f m\s" "\ f \f s" shows "f \f m\(take (\<^bold>|f\<^bold>|-1) s)" using assms proof(induction s rule:rev_induct) case (snoc s ss) have "\ f \f ss" using \\ f \f ss \ [s]\[unfolded sublist_append] by blast show ?case proof(cases) assume "f \f m \ ss" hence "f \f m \ take (\<^bold>|f\<^bold>| - 1) ss" using \\ f \f ss\ snoc.IH by blast then show ?thesis unfolding take_append lassoc using append_assoc sublist_append by metis next assume "\ f \f m \ ss" hence "f \s m \ ss \ [s]" using snoc.prems(1)[unfolded lassoc sublist_snoc, unfolded rassoc] by blast from suf_prod_le[OF this, THEN suffix_imp_sublist] \\ f \f ss \ [s]\ have "\<^bold>|ss \ [s]\<^bold>| < \<^bold>|f\<^bold>|" - by linarith + 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 \f p\m\s" and "\ f \f p" and "\ f \f s" shows "f \f (drop (\<^bold>|p\<^bold>| - (\<^bold>|f\<^bold>| - 1)) p) \ m \ (take (\<^bold>|f\<^bold>|-1) s)" - using fac_elim_suf[OF fac_elim_pref[OF \f \f p\m\s\, unfolded lassoc], unfolded rassoc, OF assms(2-3)]. + using fac_elim_suf[OF fac_elim_pref[OF \f \f p\m\s\, unfolded lassoc], unfolded rassoc, OF assms(2-3)]. lemma fac_ext_pref: "u \f w \ u \f p \ w" - by (meson sublist_append) + by (meson sublist_append) lemma fac_ext_suf: "u \f w \ u \f w \ s" - by (meson sublist_append) + by (meson sublist_append) lemma fac_ext: "u \f w \ u \f p \ w \ s" by (meson fac_ext_pref fac_ext_suf) lemma fac_ext_hd:"u \f w \ u \f a#w" - by (metis sublist_Cons_right) - -lemma card_switch_fac: assumes "2 \ card (set ws)" + by (metis sublist_Cons_right) + +lemma card_switch_fac: assumes "2 \ card (set ws)" obtains c d where "c \ d" and "[c,d] \f ws" - using assms + using assms proof (induct ws, force) case (Cons a ws) - then show ?case + then show ?case proof (cases) assume "2 \ card (set ws)" from Cons.hyps[OF _ this] Cons.prems(1) fac_ext_hd show thesis by metis - next + next assume "\ 2 \ card (set ws)" - have "ws \ \" + have "ws \ \" using \2 \ card (set (a # ws))\ by force - hence "a = hd ws \ set (a # ws) = set ws" - using hd_Cons_tl[OF \ws \ \\] by force + hence "a = hd ws \ set (a # ws) = set ws" + using hd_Cons_tl[OF \ws \ \\] by force hence "a \ hd ws" - using \2 \ card (set (a # ws))\ \\ 2 \ card (set ws)\ by force + using \2 \ card (set (a # ws))\ \\ 2 \ card (set ws)\ by force from Cons.prems(1)[OF this] show thesis using Cons_eq_appendI[OF _ hd_tl[OF \ws \ \\, symmetric]] sublist_append_rightI by blast qed qed +lemma fac_overlap_len: assumes "u \f x \ y \ z" and "\<^bold>|u\<^bold>| \ \<^bold>|y\<^bold>|" + shows "u \f x \ y \ u \f y \ z" +proof- + obtain s p where eq: "x \ y \ z = p \ u \ s" + using \u \f x \ y \ z\ unfolding fac_def by blast + show ?thesis + proof (rule le_cases) + assume "\<^bold>|p\<^bold>| \ \<^bold>|x\<^bold>|" + from add_le_mono[OF this \\<^bold>|u\<^bold>| \ \<^bold>|y\<^bold>|\] + have "\<^bold>|p \ u\<^bold>| \ \<^bold>|x \ y\<^bold>|" + unfolding lenmorph. + from eq_le_pref[OF eq[symmetric, unfolded lassoc] this] + have "u \f x \ y" + using fac_pref by blast + thus ?thesis by blast + next + assume "\<^bold>|x\<^bold>| \ \<^bold>|p\<^bold>|" + from eqd[OF eq this] + show "u \f x \ y \ u \f y \ z" + unfolding fac_def by metis + qed +qed + section "Power and its properties" text\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. \ -declare power.power.simps [code] + +primrec list_power :: "'a list \ nat \ 'a list" (infixr "\<^sup>@" 80) + where + pow_0: "u \<^sup>@ 0 = \" + | pow_Suc: "u \<^sup>@ Suc n = u \ u \<^sup>@ n" + +term power.power + + + + + + + + +context +begin interpretation monoid_mult "\" "append" - by standard simp+ - -notation power (infixr "\<^sup>@" 80) -notation power2 ("(_)\<^sup>@\<^sup>2" 80) + rewrites "power u n = u\<^sup>@n" +proof- + show "class.monoid_mult \ (\)" + by (unfold_locales, simp_all) + show "power.power \ (\) u n = u \<^sup>@ n" + unfolding power.power_def list_power_def by blast +qed + \ \inherited power properties\ -lemmas pow_zero = power.power_0 and +lemma emp_pow_emp[simp]: "r = \ \ r\<^sup>@n = \" + by simp + +lemma pow_pos:"0 < k \ a\<^sup>@k = a \ a\<^sup>@(k-1)" + by (simp add: power_eq_if) + +lemma pow_pos':"0 < k \ a\<^sup>@k = a\<^sup>@(k-1) \ a" + using power_minus_mult by metis + +lemma pow_diff: "k < n \ a\<^sup>@(n - k) = a \ a\<^sup>@(n-k-1)" + by (rule pow_pos) simp + +lemma pow_diff': "k < n \ a\<^sup>@(n - k) = a\<^sup>@(n-k-1) \ a" + by (rule pow_pos') simp + +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_1 = power_one_right and + emp_pow[emp_simps] = power_one and pow_two[simp] = power2_eq_square and pow_Suc = power_Suc and - pow_Suc2 = power_Suc2 and + pow_Suc' = power_Suc2 and pow_comm = power_commutes and add_exps = power_add and - pow_eq_if_list = power_eq_if 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 \) (\) = (\<^sup>@)" - by simp + comm_add_exp = power_commuting_commutes + +lemma pow_rev_emp_conv[reversal_rule]: "power.power (rev \) (\) = (\<^sup>@)" + unfolding power.power_def list_power_def by simp lemma pow_rev_map_rev_emp_conv [reversal_rule]: "power.power (rev (map rev \)) (\) = (\<^sup>@)" - by simp + unfolding power.power_def list_power_def by simp +end + +named_theorems exp_simps +lemmas [exp_simps] = pow_zero pow_one emp_pow + numeral_nat less_eq_Suc_le neq0_conv pow_mult[symmetric] + +named_theorems cow_simps +lemmas [cow_simps] = emp_simps exp_simps \ \more power properties\ 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 \ r\<^sup>@n = \" by simp -lemma emp_pow_emp: "r = \ \ r\<^sup>@n = \" - by simp - -lemma nemp_pow[simp]: "t\<^sup>@m \ \ \ m \ 0" +lemma nemp_pow: "t\<^sup>@m \ \ \ 0 < m" using zero_exp by blast -lemma nemp_pow_SucE: assumes "ws \ \" and "ws = t\<^sup>@k" obtains l where "ws = t\<^sup>@Suc l" - using nemp_pow[OF \ws \ \\[unfolded \ws =t\<^sup>@k\], THEN not0_implies_Suc] \ws = t\<^sup>@k\ by fast - -lemma nemp_exp_pos[intro]: "w \ \ \ r\<^sup>@k = w \ k \ 0" - using nemp_pow by blast +lemma pow_nemp_pos[intro]: assumes "u = t\<^sup>@m" "u \ \" shows "0 < m" + using nemp_pow[OF \u \ \\[unfolded \u = t\<^sup>@m\]]. + + + +lemma nemp_exp_pos[intro]: "w \ \ \ r\<^sup>@k = w \ 0 < k" + using nemp_pow by blast + +lemma nemp_exp_pos'[intro]: "w \ \ \ w = r\<^sup>@k \ 0 < k" + using nemp_pow by blast lemma nemp_pow_nemp[intro]: "t\<^sup>@m \ \ \ t \ \" using emp_pow by auto lemma sing_pow_nth:"i < m \ ([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 \ (v \ u)\<^sup>@n \ v = (u \ v)\<^sup>@(Suc n)" by (induct n) simp+ -lemma pop_pow_one: "m \ 0 \ r\<^sup>@m = r \ r\<^sup>@(m-1)" - using Suc_minus[of m] pow_Suc[of r "m-1"] by presburger - -lemma hd_pow: assumes "n \ 0" shows "hd(u\<^sup>@n) = hd u" - unfolding pop_pow_one[OF \n \ 0\] using hd_append2 by (cases "u = \", simp) +lemma hd_pow: assumes "0 < n" shows "hd(u\<^sup>@n) = hd u" + unfolding pow_pos[OF \0 < n\] using hd_append2 by (cases "u = \", simp_all) lemma pop_pow: "m \ k \u\<^sup>@m \ u\<^sup>@(k-m) = u\<^sup>@k" using le_add_diff_inverse add_exps by metis lemma pop_pow_cancel: "u\<^sup>@k \ v = u\<^sup>@m \ w \ m \ k \ u\<^sup>@(k-m) \ v = w" using lassoc pop_pow[of m k u] same_append_eq[of "u\<^sup>@m" "u\<^sup>@(k-m)\v" w, unfolded lassoc] by argo lemma pows_comm: "t\<^sup>@k \ t\<^sup>@m = t\<^sup>@m \ t\<^sup>@k" unfolding add_exps[symmetric] add.commute[of k].. lemma comm_add_exps: assumes "r \ u = u \ r" shows "r\<^sup>@m \ u\<^sup>@k = u\<^sup>@k \ 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_comm) lemma pows_comp: "x\<^sup>@i \ x\<^sup>@j" - unfolding prefix_comparable_def using ruler_eqE[OF pows_comm, of x i j] by blast + 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_one' = pow_pos[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 pow_set: "set (w\<^sup>@Suc k) = set w" by (induction k, simp_all) lemma eq_pow_exp[simp]: assumes "u \ \" shows "u\<^sup>@k = u\<^sup>@m \ 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 \u \ \\[folded length_0_conv] by blast qed +lemma emp_pow_pos_emp [intro]: assumes "v\<^sup>@j = \" "0 < j" shows "v = \" + using pow_pos[OF \0 < j\, of v, unfolded \v\<^sup>@j = \\] by blast lemma nemp_emp_pow: assumes "u \ \" shows "u\<^sup>@m = \ \ m = 0" using eq_pow_exp[OF assms, of m 0, unfolded pow_zero]. +lemma nemp_pow_nemp_pos_conv: assumes "u \ \" shows "u\<^sup>@m \ \ \ 0 < m" + unfolding nemp_emp_pow[OF assms] by blast + lemma nemp_Suc_pow_nemp: "u \ \ \ u\<^sup>@Suc k \ \" by simp -lemma nonzero_pow_emp: "m \ 0 \ u\<^sup>@m = \ \ u = \" +lemma nonzero_pow_emp: "0 < m \ u\<^sup>@m = \ \ u = \" by (cases "u = \", simp) (use nemp_emp_pow[of u m] in blast) lemma pow_eq_eq: - assumes "u\<^sup>@k = v\<^sup>@k" and "k \ 0" + assumes "u\<^sup>@k = v\<^sup>@k" and "0 < k" shows "u = v" proof- have "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|" - using lenarg[OF \u\<^sup>@k = v\<^sup>@k\, unfolded pow_len] \k \ 0\ by simp + using lenarg[OF \u\<^sup>@k = v\<^sup>@k\, unfolded pow_len] \0 < k\ by simp from eqd_eq[of u "u\<^sup>@(k-1)" v "v\<^sup>@(k-1)", OF _ this] show ?thesis - using \u\<^sup>@k = v\<^sup>@k\ unfolding pop_pow_one[OF \k \ 0\] by blast + using \u\<^sup>@k = v\<^sup>@k\ unfolding pow_pos[OF \0 < k\] by blast qed lemma Suc_pow_eq_eq[elim]: "u\<^sup>@Suc k = v\<^sup>@Suc k \ 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) + +lemma map_pow[simp]: "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" +lemma concat_pow[simp]: "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 = \ \ n = 0" - using nemp_emp_pow[OF list.simps(3), of _ \]. +lemma sing_pow_empty: "[a]\<^sup>@n = \ \ n = 0" + using nemp_emp_pow[OF list.simps(3), of _ \]. lemma sing_pow_lists: "a \ A \ [a]\<^sup>@n \ lists A" by (induct n, auto) -lemma long_power: assumes "r \ \" shows "\<^bold>|x\<^bold>| \ \<^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 \ \ \ \<^bold>|x\<^bold>| < \<^bold>|r\<^sup>@(Suc \<^bold>|x\<^bold>|)\<^bold>|" - unfolding pow_Suc lenmorph by (simp add: long_power add_strict_increasing) - -lemma long_pow_exp: "r \ \ \ m \ \<^bold>|r\<^sup>@m\<^bold>|" +lemma long_pow: "r \ \ \ m \ \<^bold>|r\<^sup>@m\<^bold>|" unfolding pow_len[of r m] using nemp_le_len[of r] by simp -lemma long_pow_ex: assumes "r \ \" obtains n where "m \ \<^bold>|r\<^sup>@n\<^bold>|" and "n \ 0" - using assms long_pow_exp by auto +lemma long_pow_exp': "r \ \ \ m < \<^bold>|r\<^sup>@(Suc m)\<^bold>|" + using Suc_le_lessD long_pow by blast + +lemma long_pow_expE: assumes "r \ \" obtains n where "m \ \<^bold>|r\<^sup>@Suc n\<^bold>|" + using long_pow_exp'[OF \r \ \\] nat_less_le by blast lemma pref_pow_ext: "x \p r\<^sup>@k \ x \p r\<^sup>@Suc k" - using pref_trans[OF _ prefI[OF pow_Suc2[symmetric]]]. + using pref_trans[OF _ prefI[OF pow_Suc'[symmetric]]]. lemma pref_pow_ext': "u \p r\<^sup>@k \ u \p r \ r\<^sup>@k" using pref_pow_ext[unfolded pow_Suc]. lemma pref_pow_root_ext: "x \p r\<^sup>@k \ r \ x \p r\<^sup>@Suc k" by simp lemma pref_prod_root: "u \p r\<^sup>@k \ u \p r \ u" using pref_pow_ext'[THEN pref_prod_pref]. lemma le_exps_pref: "k \ l \ r\<^sup>@k \p r\<^sup>@l" using leI pop_pow[of k l r] by blast lemma pref_exp_le: assumes "u \ \" "u\<^sup>@m \p u\<^sup>@n" shows "m \ n" using mult_cancel_le[OF nemp_len[OF \u \ \\], of m n] prefix_length_le[OF \u\<^sup>@m \p u\<^sup>@n\, unfolded pow_len[of u m] pow_len[of u n]] by blast -lemma sing_exp_pref_iff: assumes "a \ b" +lemma sing_exp_pref_iff: assumes "a \ b" shows "[a]\<^sup>@i \p [a]\<^sup>@k\[b] \ w \ i \ k" proof assume "i \ k" thus "[a]\<^sup>@i \p [a]\<^sup>@k\[b] \ w" using pref_ext[OF le_exps_pref[OF \i \ k\]] by blast next have "\ [a]\<^sup>@i \p [a]\<^sup>@k\[b] \ w" if "\ i \ k" proof (rule notI) assume "[a]\<^sup>@i \p [a]\<^sup>@k\[b] \ w" - hence "k < i" and "i - k \ 0" using \\ i \ k\ by force+ + hence "k < i" and "0 < i - k" using \\ i \ k\ by force+ from pop_pow[OF less_imp_le, OF this(1)] have "[a]\<^sup>@k \ [a]\<^sup>@(i - k) = [a]\<^sup>@i". from \[a]\<^sup>@i \p [a]\<^sup>@k\[b] \ w\[folded this, unfolded pref_cancel_conv - pop_pow_one[OF \i - k \ 0\]] - show False + pow_pos[OF \0 < i - k\]] + show False using \a \ b\ by simp qed thus "[a] \<^sup>@ i \p [a] \<^sup>@ k \ [b] \ w \ i \ 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 = le_exps_pref[reversed] and suf_exp_le = pref_exp_le[reversed] and - sing_exp_suf_iff = sing_exp_pref_iff[reversed] + sing_exp_suf_iff = sing_exp_pref_iff[reversed] lemma comm_common_power: assumes "r \ u = u \ r" shows "r\<^sup>@\<^bold>|u\<^bold>| = u\<^sup>@\<^bold>|r\<^bold>|" using eqd_eq[OF comm_add_exps[OF \r \ u = u \ r\], of "\<^bold>|u\<^bold>|" "\<^bold>|r\<^bold>|"] unfolding pow_len by fastforce lemma one_generated_list_power: "u \ lists {x} \ \k. concat u = x\<^sup>@k" 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) + (use pow_Suc[symmetric, of x] singletonD in metis) lemma pow_lists: assumes "0 < k" shows "u\<^sup>@k \ lists B \ u \ lists B" - unfolding pow_Suc[of u "k-1", unfolded Suc_minus''[OF \0 < k\]] by simp + unfolding pow_Suc[of u "k-1", unfolded Suc_minus_pos[OF \0 < k\]] by simp lemma concat_morph_power: "xs \ lists B \ xs = ts\<^sup>@k \ concat ts\<^sup>@k = concat xs" by (induct k arbitrary: xs ts) simp_all -(* lemma pref_not_idem: "z \ \ \ z \ x \ z \ x\<^sup>@k \ 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 \p r \ u \ u \p r\<^sup>@k \ u" -proof(induct k, simp) +proof(induct k) case (Suc k) show ?case unfolding pow_Suc rassoc using Suc.hyps Suc.prems pref_prolong by blast -qed +qed simp lemmas - (* suf_not_idem = pref_not_idem[reversed] and *) - per_exp_suf = per_exp_pref[reversed] + per_exp_suf = per_exp_pref[reversed] lemma hd_sing_pow: "k \ 0 \ hd ([a]\<^sup>@k) = a" by (induction k) simp+ -(* lemma sing_mismatch_pref: "x \ y \ [y]\<^sup>@k \ [x] \p w \ [y]\<^sup>@l \ [x] \p w \ k = l" *) -(* proof(rule ccontr, induction k l arbitrary: w rule: diff_induct) *) - (* case (1 k) *) - (* then show ?case *) - (* using not0_implies_Suc[OF \k \ 0\] by (auto simp add: prefix_def) *) -(* qed (auto simp add: prefix_def) *) lemma sing_pref_comp_mismatch: assumes "b \ a" and "c \ a" and "[a]\<^sup>@k \ [b] \ [a]\<^sup>@l \ [c]" shows "k = l \ 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 + proof (induction k l rule: diff_induct) + show " b \ a \ c \ a \ [a] \<^sup>@ x \ [b] \ [a] \<^sup>@ 0 \ [c] \ x = 0" for x + by (rule ccontr, elim not0_SucE) fastforce + qed (simp add:prefix_comparable_def)+ + show "b = c" using assms(3) unfolding \k = l\ by auto qed -lemma sing_pref_comp_lcp: assumes "r \ s" and "a \ b" and "a \ c" +lemma sing_pref_comp_lcp: assumes "r \ s" and "a \ b" and "a \ c" shows "[a]\<^sup>@r \ [b] \ u \\<^sub>p [a]\<^sup>@s \ [c] \ v = [a]\<^sup>@(min r s)" proof- have "r \ s \ [a]\<^sup>@r \ [b] \ u \\<^sub>p [a]\<^sup>@s \ [c] \ v = [a]\<^sup>@(min r s)" proof (rule diff_induct[of "\ r s. r \ s \ [a]\<^sup>@r \ [b] \ u \\<^sub>p [a]\<^sup>@s \ [c] \ v = [a]\<^sup>@(min r s)"]) have "[a] \<^sup>@ Suc (x - 1) \ [b] \ u \\<^sub>p [c] \ v = [a] \<^sup>@ min x 0" if "x \ 0" for x - unfolding pow_Suc min_0R clean_pows clean_emp rassoc by (simp add: \a \ c\) + unfolding pow_Suc min_0R exp_simps rassoc by (simp add: \a \ c\) thus "x \ 0 \ [a] \<^sup>@ x \ [b] \ u \\<^sub>p [a] \<^sup>@ 0 \ [c] \ v = [a] \<^sup>@ min x 0" for x by force - show "0 \ Suc y \ [a] \<^sup>@ 0 \ [b] \ u \\<^sub>p [a] \<^sup>@ Suc y \ [c] \ v = [a] \<^sup>@ min 0 (Suc y)" for y - unfolding pow_Suc min_0L clean_pows clean_emp rassoc using \a \ b\ by auto + show "0 \ Suc y \ [a] \<^sup>@ 0 \ [b] \ u \\<^sub>p [a] \<^sup>@ Suc y \ [c] \ v = [a] \<^sup>@ min 0 (Suc y)" for y + unfolding pow_Suc min_0L exp_simps rassoc using \a \ b\ by auto show "x \ y \ [a] \<^sup>@ x \ [b] \ u \\<^sub>p [a] \<^sup>@ y \ [c] \ v = [a] \<^sup>@ min x y \ Suc x \ Suc y \ [a] \<^sup>@ Suc x \ [b] \ u \\<^sub>p [a] \<^sup>@ Suc y \ [c] \ v = [a] \<^sup>@ min (Suc x) (Suc y)" for x y - unfolding pow_Suc rassoc min_Suc_Suc by simp + 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 \ 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 \t\<^sup>@m \ y = t\<^sup>@k\] 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 \t\<^sup>@m \ y = t\<^sup>@k\] le_exps_pref[of k m t]] by presburger lemmas exp_suf_cancel = exp_pref_cancel[reversed] lemma index_pow_mod: "i < \<^bold>|r\<^sup>@k\<^bold>| \ (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>| \ i \ i < \<^bold>|r\<^sup>@l\<^bold>| + \<^bold>|r\<^bold>| \ 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[symmetric]] nth_append le_mod_geq + unfolding aux sym[OF pow_Suc'[symmetric]] nth_append le_mod_geq using aux1[ OF _ Suc.prems[unfolded aux]] - Suc.IH pow_Suc2[symmetric] Suc.prems[unfolded aux] leI[of i "\<^bold>|r \<^sup>@ k\<^bold>|"] by presburger + Suc.IH pow_Suc'[symmetric] Suc.prems[unfolded aux] leI[of i "\<^bold>|r \<^sup>@ k\<^bold>|"] by presburger qed auto lemma sing_pow_len [simp]: "\<^bold>|[r]\<^sup>@l\<^bold>| = l" by (induct l) auto lemma take_sing_pow: "k \ l \ take k ([r]\<^sup>@l) = [r]\<^sup>@k" proof (induct k) case (Suc k) have "k < \<^bold>|[r]\<^sup>@l\<^bold>|" using Suc_le_lessD[OF \Suc k \ l\] unfolding sing_pow_len. from take_Suc_conv_app_nth[OF this] show ?case - unfolding Suc.hyps[OF Suc_leD[OF \Suc k \ l\]] pow_Suc2 + unfolding Suc.hyps[OF Suc_leD[OF \Suc k \ l\]] pow_Suc' unfolding sing_pow_nth[OF Suc_le_lessD[OF \Suc k \ l\]]. qed simp lemma concat_take_sing: assumes "k \ l" shows "concat (take k ([r]\<^sup>@l)) = r\<^sup>@k" - unfolding take_sing_pow[OF \k \ l\] using concat_sing_pow. + unfolding take_sing_pow[OF \k \ l\] using concat_sing_pow. lemma unique_letter_word: assumes "\c. c \ set w \ c = a" shows "w = [a]\<^sup>@\<^bold>|w\<^bold>|" using assms proof (induction w) case (Cons b w) 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) \ 1" shows "[hd u] \<^sup>@ \<^bold>|u\<^bold>| = u" proof (cases "u = \") assume "u \ \" then have "card (set u) = 1" using \card (set u) \ 1\ 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 \u \ \\] 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 "(\ c. c \ set w \ c = a)" obtains k where "w = [a]\<^sup>@k" using unique_letter_word assms by metis lemma unique_letter_wordE''[elim]: assumes "set w \ {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 \ \" using assms by force obtain l where "w = [a]\<^sup>@l" using unique_letter_wordE''[of w a thesis] assms by force - with \w \ \\ have "l \ 0" by simp + with \w \ \\ + have "l \ 0" + by blast show thesis using that[of "l-1"] unfolding \w = [a]\<^sup>@l\ Suc_minus[OF \l \ 0\] by blast qed lemma conjug_pow: "x \ z = z \ y \ x\<^sup>@k \ z = z \ y\<^sup>@k" by (induct k) fastforce+ lemma lq_conjug_pow: assumes "p \p x \ p" shows "p\\<^sup>>(x\<^sup>@k \ p) = (p\\<^sup>>(x \ p))\<^sup>@k" using lqI[OF sym[OF conjug_pow[of x p "p\\<^sup>>(x \ p)", OF sym[OF lq_pref[OF \p \p x \ p\]], of k]]]. lemmas rq_conjug_pow = lq_conjug_pow[reversed] -lemma pow_pref_root_one: assumes "k \ 0" and "r \ \" and "r\<^sup>@k \p r" +lemma pow_pref_root_one: assumes "0 < k" and "r \ \" and "r\<^sup>@k \p r" shows "k = 1" - unfolding eq_pow_exp[OF \r \ \\, of k 1, symmetric] pow_one' - using \r\<^sup>@k \p r\ triv_pref[of r "r\<^sup>@(k-1)", folded pop_pow_one[OF \k \ 0\]] by auto + unfolding eq_pow_exp[OF \r \ \\, of k 1, symmetric] pow_1 + using \r\<^sup>@k \p r\ triv_pref[of r "r\<^sup>@(k-1)", folded pow_pos[OF \0 < k\]] 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)) - + by (induction k, simp, simp) lemma comp_pows_pref: assumes "v \ \" and "(u \ v)\<^sup>@k \ u \p (u \ v)\<^sup>@m" shows "k \ m" using pref_exp_le[OF _ pref_extD[OF assms(2)]] assms(1) by blast lemma comp_pows_pref': assumes "v \ \" and "(u \ v)\<^sup>@k \p (u \ v)\<^sup>@m \ u" shows "k \ m" proof(rule ccontr) assume "\ k \ m" hence "Suc m \ k" by simp - from le_exps_pref[OF this, unfolded pow_Suc2] + from le_exps_pref[OF this, unfolded pow_Suc'] have "(u \ v)\<^sup>@m \ (u \ v) \p (u \ v)\<^sup>@k". from pref_trans[OF this assms(2)] \v \ \\ show False by auto -qed +qed lemma comp_pows_not_pref: "\ (u \ v)\<^sup>@k \ u \p (u \ v)\<^sup>@m \ m \ 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

@m \ k < m" - by (induction k m rule: diff_induct, fastforce, blast, force) + by (induction k m rule: diff_induct) auto + +lemma comp_pows_spref: "u\<^sup>@k

@m \ k < m" + by (induction k m rule: diff_induct) auto lemma comp_pows_spref_ext: "(u \ v)\<^sup>@k \ u

v)\<^sup>@m \ k < m" - by (induction k m rule: diff_induct, fastforce, blast, force) + by (induction k m rule: diff_induct) auto lemma comp_pows_pref_zero:"(u \ v)\<^sup>@k

k = 0" - by (induct k, simp, unfold pow_Suc, auto) - -lemma comp_pows_spref': "(u \ v)\<^sup>@k

v)\<^sup>@m \ u \ k < Suc m" + by (induct k) auto + +lemma comp_pows_spref': "(u \ v)\<^sup>@k

v)\<^sup>@m \ u \ 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_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 \ \Lemmas allowing to compare complicated terms with powers\ named_theorems shifts lemma shift_pow[shifts]: "(u\v)\<^sup>@k\u = u\(v\u)\<^sup>@k" using conjug_pow[OF rassoc]. -(* lemma[shifts]: "(u \ v \ w)\<^sup>@k \ u \ z = u \ (v \ w \ u)\<^sup>@k \ z" *) - (* by (simp add: shifts) *) -lemma[shifts]: "(u \ v)\<^sup>@k \ u \ z = u \ (v \ u)\<^sup>@k \ z" + lemma[shifts]: "(u \ v)\<^sup>@k \ u \ z = u \ (v \ u)\<^sup>@k \ z" by (simp add: shift_pow) lemma[shifts]: "u\<^sup>@k \ u \ z = u \ u\<^sup>@k \ z" by (simp add: conjug_pow) lemma[shifts]: "r\<^sup>@k \p r \ r\<^sup>@k" by (simp add: pow_comm[symmetric]) lemma [shifts]: "r\<^sup>@k \p r \ r\<^sup>@k \ z" unfolding lassoc pow_comm[symmetric] unfolding rassoc by blast lemma [shifts]: "(r \ q)\<^sup>@k \p r \ q \ (r \ q)\<^sup>@k \ z" unfolding lassoc pow_comm[symmetric] unfolding rassoc by simp lemma [shifts]: "(r \ q)\<^sup>@k \p r \ q \ (r \ q)\<^sup>@k" unfolding lassoc pow_comm[symmetric] unfolding rassoc by simp lemma[shifts]: "r\<^sup>@k \ u \p r \ r\<^sup>@k \ v \ u \p r \ v" unfolding lassoc pow_comm[symmetric] unfolding rassoc pref_cancel_conv.. -lemma[shifts]: "u \ u\<^sup>@k \ z = u\<^sup>@k \ w \ u \ z = w" +lemma[shifts]: "u \ u\<^sup>@k \ z = u\<^sup>@k \ w \ u \ z = w" unfolding lassoc pow_comm[symmetric] unfolding rassoc cancel.. -lemma[shifts]: "(r \ q)\<^sup>@k \ u \p r \ q \ (r \ q)\<^sup>@k \ v \ u \p r \ q \ v" +lemma[shifts]: "(r \ q)\<^sup>@k \ u \p r \ q \ (r \ q)\<^sup>@k \ v \ u \p r \ q \ v" unfolding lassoc pow_comm[symmetric] unfolding rassoc pref_cancel_conv.. -lemma[shifts]: "(r \ q)\<^sup>@k \ u = r \ q \ (r \ q)\<^sup>@k \ v \ u = r \ q \ v" +lemma[shifts]: "(r \ q)\<^sup>@k \ u = r \ q \ (r \ q)\<^sup>@k \ v \ u = r \ q \ v" unfolding lassoc pow_comm[symmetric] unfolding rassoc cancel.. -lemma[shifts]: "r \ q \ (r \ q)\<^sup>@k \ v = (r \ q)\<^sup>@k \ u \ r \ q \ v = u" +lemma[shifts]: "r \ q \ (r \ q)\<^sup>@k \ v = (r \ q)\<^sup>@k \ u \ r \ q \ v = u" unfolding lassoc pow_comm[symmetric] unfolding rassoc cancel.. lemma shifts_spec [shifts]: "(u\<^sup>@k \ v)\<^sup>@l \ u \ u\<^sup>@k \ z = u\<^sup>@k \ (v \ u\<^sup>@k)\<^sup>@l \ u \ z" unfolding lassoc cancel_right unfolding rassoc pow_comm[symmetric] unfolding lassoc cancel_right shift_pow.. lemmas [shifts] = shifts_spec[of "r \ q", unfolded rassoc] for r q -lemmas [shifts] = shifts_spec[of "r \ q" _ _ _ \ , unfolded rassoc clean_emp] for r q +lemmas [shifts] = shifts_spec[of "r \ q" _ _ _ \ , unfolded rassoc emp_simps] for r q lemmas [shifts] = shifts_spec[of "r \ q" _ "r \ q", unfolded rassoc] for r q -lemmas [shifts] = shifts_spec[of "r \ q" _ "r \ q" _ \ , unfolded rassoc clean_emp] for r q +lemmas [shifts] = shifts_spec[of "r \ q" _ "r \ q" _ \ , unfolded rassoc emp_simps] for r q lemma[shifts]: "(u \ (v \ u)\<^sup>@k)\<^sup>@j \ (u \ v)\<^sup>@k = (u \ v)\<^sup>@k \ (u \ (u \ v)\<^sup>@k)\<^sup>@j" by (metis shift_pow) lemma[shifts]: "(u \ (v \ u)\<^sup>@k \ z)\<^sup>@j \ (u \ v)\<^sup>@k = (u \ v)\<^sup>@k \ (u \ z \ (u \ 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 + 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 emp_simps lemmas[shifts] = less_eq_Suc_le -lemmas[shifts] = neq0_conv +lemmas[shifts] = neq0_conv lemma shifts_hd_hd [shifts]: "a#b#v = [a] \ b#v" using hd_word. lemmas [shifts] = shifts_hd_hd[of _ _ \] lemma[shifts]: "n \ k \ x\<^sup>@k = x\<^sup>@(n + (k -n))" by simp lemma[shifts]: "n < k \ x\<^sup>@k = x\<^sup>@(n + (k -n))" by simp -(* lemmas[shifts] = less_imp_le *) +lemmas[shifts] = cancel cancel_right pref_cancel_conv suf_cancel_conv triv_pref +lemmas[shifts] = pow_diff lemmas shifts_rev = shifts[reversed] -method comparison = ((simp only: shifts; fail) | simp only: shifts_rev) +lemmas shift_simps = shifts shifts[reversed] + +method comparison = ((simp only: shifts; fail) | (simp only: shifts_rev; fail)) section \Rotation\ +lemma rotate_root_self: "rotate \<^bold>|r\<^bold>| (r\<^sup>@k) = r\<^sup>@k" +proof (cases "r = \") + assume "r \ \" + show ?thesis + proof (cases k) + fix pred + assume k: "k = Suc pred" + show ?thesis + unfolding k pow_Suc rotate_append pow_comm.. + qed simp +qed simp + +lemma rotate_pow_self: "rotate (l*\<^bold>|u\<^bold>|) (u\<^sup>@k) = u\<^sup>@k" +proof(induct l) + case (Suc l) + show ?case + unfolding mult_Suc rotate_rotate[symmetric] Suc.hyps + using rotate_root_self. +qed simp + +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\v)\<^sup>@k) = (v\u)\<^sup>@k" + 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 = \") + assume "u \ \" + 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 \u\\\[unfolded length_greater_0_conv[symmetric]]]. +qed simp + +lemmas rotate_pow_comm_two = rotate_pow_comm[of _ _ 2, unfolded pow_two] + +lemma rotate_back: "rotate (\<^bold>|u\<^bold>| - n mod \<^bold>|u\<^bold>|) (rotate n u) = u" +proof (cases "u = \") + assume "u \ \" + show ?thesis + unfolding rotate_conv_mod[of n u] rotate_rotate[of "\<^bold>|u\<^bold>| - n mod \<^bold>|u\<^bold>|" "n mod \<^bold>|u\<^bold>|" u] + le_add_diff_inverse2[OF mod_le_divisor, OF nemp_pos_len[OF \u \ \\]] + by simp +qed simp + + +lemma rotate_backE: obtains m where "rotate m (rotate n u) = u" + using rotate_back by blast + +lemma rotate_back': assumes "rotate m w = rotate n w" + shows "rotate (m-n) w = w" +proof (cases) + assume "n \ m" + from rotate_backE obtain k where "rotate k (rotate n w) = w". + hence nk: "rotate n (rotate k w) = w" + unfolding rotate_rotate add.commute[of _ k]. + have mn: "rotate m (rotate k w) = (rotate n (rotate k w))" + unfolding rotate_rotate add.commute[of _ k] unfolding rotate_rotate[symmetric] assms.. + have "rotate (m - n) (rotate n (rotate k w)) = rotate m (rotate k w)" + unfolding rotate_rotate using \n \ m\ by simp + from this[unfolded mn nk] + show ?thesis. +qed simp + +lemma rotate_class_rotate': "(\n. rotate n w = u) \ (\n. rotate n (rotate l w) = u)" +proof + obtain m where rot_m: "rotate m (rotate l w) = w" using rotate_backE. + assume "\n. rotate n w = u" + then obtain n where rot_n: "rotate n w = u" by blast + show "\n. rotate n (rotate l w) = u" + using exI[of "\ 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 "\n. rotate n (rotate l w) = u \ \n. rotate n w = u" + using rotate_rotate[symmetric] by blast +qed + +lemma rotate_class_rotate: "{u . \n. rotate n w = u} = {u . \n. rotate n (rotate l w) = u}" + using rotate_class_rotate' by blast + lemma rotate_comp_eq:"w \ rotate n w \ 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 \ w" and "irrefl r" shows "mismatch_pair w (rotate n w) \ r \ (w,rotate n w) \ lexord r" proof- have "\ w \ rotate n w" using rotate_comp_eq \rotate n w \ w\ unfolding prefix_comparable_def by blast from lexord_mismatch[OF this \irrefl r\] show ?thesis. qed -lemma rotate_back: obtains m where "rotate m (rotate n u) = u" -proof(cases "u = \", simp) - assume "u \ \" - 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 \u \ \\, 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': "(\n. rotate n w = u) \ (\n. rotate n (rotate l w) = u)" -proof - obtain m where rot_m: "rotate m (rotate l w) = w" using rotate_back. - assume "\n. rotate n w = u" - then obtain n where rot_n: "rotate n w = u" by blast - show "\n. rotate n (rotate l w) = u" - using exI[of "\ 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 "\n. rotate n (rotate l w) = u \ \n. rotate n w = u" - using rotate_rotate[symmetric] by blast -qed - -lemma rotate_class_rotate: "{u . \n. rotate n w = u} = {u . \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 \ 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 \k \ 0\, of u] pop_pow_one'[OF \k \ 0\, 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\v)\<^sup>@k) = (v\u)\<^sup>@k" - 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 = \", simp) - assume "u \ \" - 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 \u\\\[unfolded length_greater_0_conv[symmetric]]]. -qed - -lemmas rotate_pow_comm_two = rotate_pow_comm[of _ _ 2, unfolded pow_two] - section \Lists of words and their concatenation\ text\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. \ lemma concat_take_is_prefix: "concat(take n ws) \p concat ws" 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) \ ws!j = concat(take (Suc j) ws)" +lemma concat_take_Suc: assumes "j < \<^bold>|ws\<^bold>|" shows "concat(take j ws) \ ws!j = concat(take (Suc j) ws)" unfolding take_Suc_conv_app_nth[OF \j < \<^bold>|ws\<^bold>|\] using sym[OF concat_append[of "(take j ws)" "[ws ! j]", unfolded concat.simps(2)[of "ws!j" \, unfolded concat.simps(1) append_Nil2]]]. lemma pref_mod_list: assumes "u

|ws\<^bold>|" and "r

r = u" proof- have "\<^bold>|ws\<^bold>| \ 0" using assms by auto then obtain l where "Suc l = \<^bold>|ws\<^bold>|" using Suc_pred by blast let ?P = "\ j. u

Suc l = \<^bold>|ws\<^bold>|\ by auto define j where "j = (LEAST j. ?P j)" \ \smallest j such that concat (take (Suc j) ws)

have "u

?P l\] unfolding sym[OF j_def]. have "j < \<^bold>|ws\<^bold>|" - using Least_le[of ?P, OF \?P l\] \Suc l = \<^bold>|ws\<^bold>|\ unfolding sym[OF j_def] + using Least_le[of ?P, OF \?P l\] \Suc l = \<^bold>|ws\<^bold>|\ unfolding sym[OF j_def] by auto have "concat(take j ws) \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 (cases "j = 0", simp) force - from prefixE[OF this] + from prefixE[OF this] obtain r where "u = concat(take j ws) \ r". - from \u

[unfolded this] + from \u

[unfolded this] have "r

j < \<^bold>|ws\<^bold>|\, symmetric] spref_cancel_conv. + unfolding concat_take_Suc[OF \j < \<^bold>|ws\<^bold>|\, symmetric] spref_cancel_conv. show thesis using that[OF \j < \<^bold>|ws\<^bold>|\ \r

\u = concat(take j ws) \ r\[symmetric]]. qed -lemma pref_mod_power: assumes "u

@l" +thm prefI + +lemma pref_mod_pow: assumes "u \p w\<^sup>@l" and "w \ \" + obtains k z where "k \ l" and "z

@k\z = u" +proof (cases "u = w\<^sup>@l") + assume "u \ w\<^sup>@l" + from sprefI[OF \u \p w\<^sup>@l\ this] + have "u

@ l". + have "w\<^sup>@l = concat ([w]\<^sup>@l)" + by simp + from pref_mod_list[of u "[w]\<^sup>@l", unfolded sing_pow_len concat_sing_pow, OF \u

@l\] + obtain j r where "j < l" "r

@ l) ! j" "concat (take j ([w] \<^sup>@ l)) \ r = u". + hence "j \ l" and "r

@j \ r = u" + unfolding sing_pow_nth[OF \j < l\] concat_take_sing[OF less_imp_le[OF \j < l\]] by auto + from that[OF this] + show thesis. +qed (use emp_spref assms in blast) + +lemma pref_mod_pow': assumes "u

@l" obtains k z where "k < l" and "z

@k\z = u" - using pref_mod_list[of u "[w]\<^sup>@l", unfolded sing_pow_len concat_sing_pow, OF \u

@l\, of thesis] - sing_pow_nth[of _ l w] concat_take_sing - less_imp_le_nat by metis - -lemma get_pow_exp: assumes "z

|t\<^sup>@m\z\<^bold>| div \<^bold>|t\<^bold>|" - 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

|t\<^sup>@m\z\<^bold>| div \<^bold>|t\<^bold>|)*\<^bold>|t\<^bold>|) (t\<^sup>@m\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_power: assumes "t \ \" and "u \p t\<^sup>@k" - shows "\ m. t\<^sup>@m \p u \ u

@m \ t" -proof (cases "u = t\<^sup>@k") - show "u = t \<^sup>@ k \ \m. t \<^sup>@ m \p u \ u

@ m \ t" - using \t \ \\ by blast -next - assume "u \ t \<^sup>@ k" - obtain m z where "m < k" "z

@ m \ z = u" - using pref_mod_power[of u t k] \u \p t\<^sup>@k\[unfolded prefix_order.dual_order.order_iff_strict] \u \ t\<^sup>@k\ - by blast - hence "t \<^sup>@ m \p u" and "u

@ m \ t" - using \t \<^sup>@ m \ z = u\ \z

spref_cancel_conv by blast+ - thus ?thesis by blast -qed - -lemma pref_powerE: assumes "t \ \" and "u \p t\<^sup>@k" - obtains m where "t\<^sup>@m \p u" "u

@m \ t" - using assms pref_power by blast - -(* lemma pref_power': assumes "u \ \" and "u \p t\<^sup>@k" *) - (* shows "\ m. t\<^sup>@m

u \p t\<^sup>@m \ t" *) -(* proof- *) - (* obtain m z where "m < k" "z \np t" "t \<^sup>@ m \ z = u" *) - (* using pref_mod_power'[OF npI[OF \u \ \\ \u \p t\<^sup>@k\]]. *) - (* thus ?thesis *) - (* by auto *) -(* qed *) - -lemmas suf_power = pref_power[reversed] - -lemma suf_powerE: assumes "t \ \" and "u \s t\<^sup>@k" - obtains m where "t\<^sup>@m \s u" "u t\<^sup>@m" - using assms suf_power by blast +proof- + have "w \ \" using assms by force + from pref_mod_pow[OF sprefD1[OF assms] this] + obtain k z where "k \ l" "z

@ k \ z = u". + note spref_extD[OF \u

@l\[folded \w \<^sup>@ k \ z = u\]] + have "k < l" + using comp_pows_spref[OF \w \<^sup>@ k

@ l\]. + from that[OF this \z

\w \<^sup>@ k \ z = u\] + show thesis. +qed + +lemma split_pow: assumes "u \ v = w\<^sup>@k" "0 < k" "v \ \" + obtains p s i j where "w = p \ s" "s \ \" "u = (p \ s)\<^sup>@i \ p" "v = (s \ p)\<^sup>@j \ s" "k = i + j + 1" +proof- + have "u

@k" + using assms(1,3) by blast + from pref_mod_pow'[OF this] + obtain ku p where "ku < k" "p

@ ku \ p = u". + from spref_exE[OF this(2)] + obtain s where "p \ s = w" "s \ \". + obtain kv where "k = Suc(ku + kv)" + using less_imp_Suc_add[OF \ku < k\] by blast + from \u \ v = w\<^sup>@k\[folded this[symmetric] \p \ s = w\ \w \<^sup>@ ku \ p = u\, unfolded rassoc pow_Suc'] + have "v = s \ w\<^sup>@kv" + unfolding shifts unfolding lassoc shift_pow[symmetric] unfolding rassoc cancel \p \ s = w\. + show thesis + using that[OF \p \ s = w\[symmetric] \s \ \\ \w \<^sup>@ ku \ p = u\[folded \p\s = w\, symmetric] + \v = s \ w\<^sup>@kv\[folded \p\s = w\,folded shift_pow] \k = Suc(ku + kv)\[unfolded Suc_eq_plus1]]. +qed + + + + + + + + + lemma del_emp_concat: "concat us = concat (filter (\x. x \ \) us)" by (induct us) simp+ -lemma lists_drop_emp: "us \ lists C\<^sub>+ \ us \ lists C" +lemma lists_minus: "us \ lists (C - A) \ us \ lists C" by blast -lemma lists_drop_emp': "us \ lists C \ (filter (\x. x \ \) us) \ lists C\<^sub>+" +lemma lists_minus': "us \ lists C \ (filter (\x. x \ \) us) \ lists (C - {\})" by (simp add: in_lists_conv_set) lemma pref_concat_pref: "us \p ws \ concat us \p concat ws" by (auto simp add: prefix_def) lemmas suf_concat_suf = pref_concat_pref[reversed] lemma concat_mono_fac: "us \f ws \ concat us \f concat ws" using concat_morph facE facI' by metis lemma ruler_concat_less: assumes "us \p ws" and "vs \p ws" and "\<^bold>|concat us\<^bold>| < \<^bold>|concat vs\<^bold>|" shows "us

us \p ws\ \vs \p ws\] pref_concat_pref[of vs us, THEN prefix_length_le] \\<^bold>|concat us\<^bold>| < \<^bold>|concat vs\<^bold>|\ - by force - -lemma concat_take_mono_strict: assumes "concat (take i ws)

k \ take j (take k xs) = take j xs" proof (rule disjE[OF le_less_linear, of k "\<^bold>|xs\<^bold>|"]) assume "j \ k" and "k \ \<^bold>|xs\<^bold>|" show ?thesis using pref_share_take[OF take_is_prefix, of j k xs, unfolded take_len[OF \k \ \<^bold>|xs\<^bold>|\], OF \j \ k\]. qed simp lemma concat_interval: assumes "concat (take k vs) = concat (take j vs) \ 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" + assume "j < k" from eq1[unfolded take_le_take[OF less_imp_le[OF this]]] show ?thesis - unfolding cancel. + unfolding cancel. next note eq1 = assms[folded arg_cong[OF takedrop[of j "take k vs"], of concat, unfolded concat_morph]] assume "k \ j" from pref_concat_pref[OF le_take_pref, OF this, of vs, unfolded assms] have "s = \" by force from drop_all[OF le_trans[OF len_take1 \k \ j\], of vs] have "concat (drop j (take k vs)) = \" - using concat.simps(1) by force + using concat.simps(1) by force with \s = \\ show ?thesis by blast qed lemma bin_lists_count_zero': assumes "ws \ lists {x,y}" and "count_list ws y = 0" shows "ws \ lists {x}" using assms -proof (induct ws, simp) +proof (induct ws) case (Cons a ws) have "a \ y" using \count_list (a # ws) y = 0\ count_list.simps(2) by force hence "count_list ws y = 0" using \count_list (a # ws) y = 0\ count_list.simps(2) by force from Cons.hyps(3)[OF this] show ?case - using \a \ {x,y}\ \a \ y\ by auto -qed + using \a \ {x,y}\ \a \ y\ by auto +qed simp lemma bin_lists_count_zero: assumes "ws \ lists {x,y}" and "count_list ws x = 0" shows "ws \ lists {y}" using assms unfolding insert_commute[of x y "{}"] using bin_lists_count_zero' by metis lemma count_in: "count_list ws a \ 0 \ a \ set ws" using count_notin[of a ws] by fast -lemma count_in_conv: "count_list w a \ 0 \ a \ set w" +lemma count_in_conv: "count_list w a \ 0 \ a \ set w" by (induct w, auto) lemma two_in_set_concat_len: assumes "u \ v" and "{u,v} \ set ws" shows "\<^bold>|u\<^bold>| + \<^bold>|v\<^bold>| \ \<^bold>|concat ws\<^bold>|" proof- let ?ws = "filter (\ x. x \ {u,v}) ws" have set: "set ?ws = {u,v}" using \{u,v} \ set ws\ by auto have "\<^bold>|concat ?ws\<^bold>| \ \<^bold>|concat ws\<^bold>|" - unfolding length_concat using sum_list_filter_le_nat by blast + unfolding length_concat using sum_list_filter_le_nat by blast have sum: "sum (\ 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 \ 0" and "count_list ?ws v \ 0" unfolding count_in_conv using assms by simp_all hence "\<^bold>|u\<^bold>| + \<^bold>|v\<^bold>| \ \<^bold>|concat ?ws\<^bold>|" unfolding length_concat sum_list_map_eq_sum_count set sum - using add_le_mono quotient_smaller by presburger + using add_le_mono quotient_smaller by presburger thus ?thesis using \\<^bold>|concat ?ws\<^bold>| \ \<^bold>|concat ws\<^bold>|\ by linarith qed section \Root\ definition root :: "'a list \ 'a list \ bool" ("_ \ _*" [51,51] 60 ) where "u \ r* = (\ k. r\<^sup>@k = u)" notation (latex output) root ("_ \ _\<^sup>*") abbreviation not_root :: "['a list, 'a list] \ bool" ("_ \ _*" [51,51] 60 ) where "u \ r* \ \ (u \ r*)" text\Empty word has all roots, including the empty root.\ lemma emp_all_roots [simp]: "\ \ r*" - unfolding root_def using power_0 by blast + unfolding root_def using pow_0 by blast + +lemma emp_all_roots'[elim]: "u = \ \ u \ r*" + using emp_all_roots by blast lemma rootI: "r\<^sup>@k \ r*" using root_def by auto lemma self_root: "u \ u*" using rootI[of u "Suc 0"] by simp -lemma rootE: assumes "u \ r*" obtains k where "r\<^sup>@k = u" +lemma rootE[elim]: assumes "u \ r*" obtains k where "r\<^sup>@k = u" using assms root_def by blast +lemma root_exp: "x \ r* \ x = r\<^sup>@(\<^bold>|x\<^bold>| div \<^bold>|r\<^bold>|)" +proof (rule iffI, cases "r = \", force) + assume "x \ r*" and "r \ \" + then obtain k where "r\<^sup>@k = x" + unfolding root_def by blast + from lenarg[OF this, unfolded pow_len] + have "k = \<^bold>|x\<^bold>| div \<^bold>|r\<^bold>|" + using nonzero_mult_div_cancel_right[OF nemp_len[OF \r \ \\], of k] by auto + from \r\<^sup>@k = x\[unfolded this, symmetric] + show "x = r \<^sup>@ (\<^bold>|x\<^bold>| div \<^bold>|r\<^bold>|)". +qed (use root_def in metis) + lemma root_nemp_expE: assumes "w \ r*" and "w \ \" - obtains k where "r\<^sup>@Suc k = w" -proof- - obtain k where "r\<^sup>@k = w" using rootE[OF \w \ r*\]. - have "k \ 0" using pow_zero[of r] \w \ \\[folded \r\<^sup>@k = w\] by metis - from not0_implies_Suc[OF \k \ 0\] - obtain k' where "k = Suc k'" by blast - from that[OF \r\<^sup>@k = w\[unfolded this]] show thesis. -qed + obtains k where "r\<^sup>@k = w" "0 < k" + using assms(1) assms(2) nemp_exp_pos root_exp by metis lemma root_rev_iff[reversal_rule]: "rev u \ rev t* \ u \ t*" unfolding root_def[reversed] using root_def.. -lemma per_root_pref[intro]: "w \ \ \ w \ r* \ r \p w" - using root_nemp_expE[unfolded pow_Suc] triv_pref by metis - -lemmas per_root_suf[intro] = per_root_pref[reversed] +lemma per_root_pref: "w \ \ \ w \ r* \ r \p w" + using root_nemp_expE pow_pos triv_pref by metis + +lemmas per_root_suf = per_root_pref[reversed] lemma per_exp_eq: "u \p r\u \ \<^bold>|u\<^bold>| = k*\<^bold>|r\<^bold>| \ u \ r*" using per_exp_pref[THEN pref_prod_eq] unfolding pow_len root_def by blast -lemma take_root: assumes "k \ 0" shows "r = take \<^bold>|r\<^bold>| (r\<^sup>@k)" - unfolding pop_pow_one[OF assms] by force +lemma take_root: assumes "0 < k" shows "r = take \<^bold>|r\<^bold>| (r\<^sup>@k)" + unfolding pow_pos[OF assms] by force lemma root_nemp: "u \ \ \ u \ r* \ r \ \" unfolding root_def using emp_pow by auto -lemma root_shorter: "u \ \ \ u \ r* \ u \ r \ \<^bold>|r\<^bold>| < \<^bold>|u\<^bold>|" - by (metis root_def leI take_all take_root pow_zero) +lemma root_shorter: assumes "u \ \" "u \ r*" "u \ r" shows "\<^bold>|r\<^bold>| < \<^bold>|u\<^bold>|" +proof (rule not_le_imp_less) + from root_nemp_expE[OF \u \ r*\ \u \ \\] + obtain k where "r\<^sup>@k = u" and "0 < k". + from take_root[OF \0 < k\, of r, unfolded \r \<^sup>@ k = u\] + show "\ \<^bold>|u\<^bold>| \ \<^bold>|r\<^bold>|" + using \u \ r\ by force +qed lemma root_shorter_eq: "u \ \ \ u \ r* \ \<^bold>|r\<^bold>| \ \<^bold>|u\<^bold>|" - using root_shorter le_eq_less_or_eq by auto + using root_shorter le_eq_less_or_eq by auto lemma root_trans[trans]: "\v \ u*; u \ t*\ \ v \ t*" by (metis root_def pow_mult) -lemma root_pow_root[trans]: "v \ u* \ v\<^sup>@n \ u*" +lemma root_pow_root[intro]: "v \ u* \ v\<^sup>@n \ u*" using rootI root_trans by blast lemma root_len: "u \ q* \ \k. \<^bold>|u\<^bold>| = k*\<^bold>|q\<^bold>|" unfolding root_def using pow_len by auto lemma root_len_dvd: "u \ t* \ \<^bold>|t\<^bold>| dvd \<^bold>|u\<^bold>|" - using root_len root_def by fastforce - -lemma common_root_len_gcd: "u \ t* \ v \ t* \ \<^bold>|t\<^bold>| dvd ( gcd \<^bold>|u\<^bold>| \<^bold>|v\<^bold>| )" + using root_len root_def by force + +lemma common_root_len_gcd: "u \ t* \ v \ t* \ \<^bold>|t\<^bold>| dvd (gcd \<^bold>|u\<^bold>| \<^bold>|v\<^bold>|)" by (simp add: root_len_dvd) lemma add_root[simp]: "z \ w \ z* \ w \ z*" proof assume "w \ z*" thus "z \ w \ z*" unfolding root_def using pow_Suc by blast next assume "z \ w \ z*" thus "w \ z*" unfolding root_def - using exp_pref_cancel[of z 1 w, unfolded power_one_right] by metis + using exp_pref_cancel[of z 1 w, unfolded pow_1] by metis qed lemma add_roots[intro]: "w \ z* \ w' \ z* \ w \ w' \ z*" unfolding root_def using add_exps by blast lemma concat_sing_list_pow: "ws \ lists {u} \ \<^bold>|ws\<^bold>| = k \ concat ws = u\<^sup>@k" proof(induct k arbitrary: ws) case (Suc k) have "ws \ \" using list.size(3) nat.distinct(2)[of k, folded \\<^bold>|ws\<^bold>| = Suc k\] by blast from hd_Cons_tl[OF this] have "ws = hd ws # tl ws" and "\<^bold>|tl ws\<^bold>| = k" using \ \<^bold>|ws\<^bold>| = Suc k\ by simp+ then show ?case unfolding pow_Suc hd_concat_tl[OF \ws \ \\, symmetric] using Suc.hyps[OF tl_in_lists[OF \ ws \ lists {u}\] \\<^bold>|tl ws\<^bold>| = k\] Nitpick.size_list_simp(2) lists_hd_in_set[of "ws" "{u}"] \ws \ lists{u}\ by blast qed simp lemma concat_sing_list_pow': "ws \ lists{u} \ concat ws = u\<^sup>@\<^bold>|ws\<^bold>|" by (simp add: concat_sing_list_pow) -lemma root_pref_cancel: assumes "x\y \ t*" and "x \ t*" shows "y \ t*" +lemma root_pref_cancel[elim]: assumes "x\y \ t*" and "x \ t*" shows "y \ t*" proof- obtain n m where "t\<^sup>@m = x \ y" and "t\<^sup>@n = x" using \x\y \ t*\[unfolded root_def] \x \ t*\[unfolded root_def] by blast from exp_pref_cancel[of t n y m, unfolded this] show "y \ t*" using rootI by auto qed -lemma root_suf_cancel: "v \ r* \ u \ v \ r* \ u \ r*" +lemma root_suf_cancel [elim]: "u \ v \ r* \ v \ r* \ u \ r*" using exp_suf_cancel[of u r] unfolding root_def by metis section Commutation text\The solution of the easiest nontrivial word equation, @{term "x \ y = y \ x"}, is in fact already contained in List.thy as the fact @{thm comm_append_are_replicate[no_vars]}.\ theorem comm: "x \ y = y \ x \ (\ t k m. x = t\<^sup>@k \ 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 \ y = y \ x \ (\ t. x \ t* \ y \ t*)" unfolding root_def comm by fast lemma comm_rootI: "x \ t* \ y \ t* \ x \ y = y \ x" using comm_root by blast lemma commE[elim]: assumes "x \ y = y \ x" - obtains t m k where "x = t\<^sup>@k" and "y = t\<^sup>@m" - using assms[unfolded comm] by blast + obtains t m k where "x = t\<^sup>@k" and "y = t\<^sup>@m" and "t \ \" +proof- + from assms[unfolded comm] + obtain t k m where "x = t\<^sup>@k" and "y = t\<^sup>@m" + by blast + from that[OF this] + show thesis + proof (cases "x \ \ \ y \ \") + assume "x \ \ \ y \ \" + thus thesis + unfolding \x = t\<^sup>@k\ \y = t\<^sup>@m\ using \t \ \ \ thesis\ + by fastforce + next + assume "\ (x \ \ \ y \ \)" + hence "x = \" "y = \" + by blast+ + from that[of "[undefined]" 0 0, unfolded this] + show thesis + by simp + qed +qed lemma comm_nemp_eqE: assumes "u \ v = v \ u" "u \ \" "v \ \" - obtains k m where "u\<^sup>@Suc k = v\<^sup>@Suc m" + obtains k m where "u\<^sup>@k = v\<^sup>@m" "0 < k" "0 < m" proof- from commE[OF \u \ v = v \ u\] - obtain t m' k' where "u = t\<^sup>@k'" and "v = t\<^sup>@m'". - from nemp_pow_SucE[OF \u \ \\ this(1)] nemp_pow_SucE[OF \v \ \\ 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 \u = t\<^sup>@Suc k''\ \v = t\<^sup>@Suc m''\ pow_mult[symmetric] - by (simp add: mult.commute) - thus thesis - using that by blast + obtain t m k where "u = t\<^sup>@k" and "v = t\<^sup>@m". + hence "0 < m" "0 < k" + using \u \ \\ \v \ \\ by blast+ + have "u\<^sup>@m = v\<^sup>@k" + unfolding \u = t\<^sup>@k\ \v = t\<^sup>@m\ pow_mult[symmetric] + by (simp add: mult.commute) + from that[OF this \0 < m\ \0 < k\] + show thesis. qed lemma comm_prod[intro]: assumes "r\u = u\r" and "r\v = v\r" shows "r\(u\v) = (u\v)\r" - using rassoc assms by metis + unfolding lassoc \r\u = u\r\ unfolding rassoc \r\v = v\r\.. + +lemma LS_comm: + assumes "y \<^sup>@ k \ x = z \<^sup>@ l" + and "z \ y = y \ z" + shows "x \ y = y \ x" +proof - + from \z \ y = y \ z\ + have "(y \<^sup>@ k \ x) \ y = y \ (y \<^sup>@ k \ x)" + unfolding \y \<^sup>@ k \ x = z \<^sup>@ l\ by (fact comm_add_exp) + then show "x \ y = y \ x" + unfolding lassoc pow_comm[symmetric] unfolding rassoc cancel. +qed section \Periods\ text\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. \ subsection "Periodic root" -definition period_root :: "'a list \ 'a list \ bool" ("_ \p _\<^sup>\" [51,51] 60 ) - where [simp]: "period_root u r = (u \p r \ u \ r \ \)" - -lemma per_rootI[simp,intro]: "u \p r \ u \ r \ \ \ u \p r\<^sup>\" + +lemma "u

u \ u \p r \ u \ r \ \" by simp -lemma per_rootI': assumes "u \p r\<^sup>@k" and "r \ \" shows "u \p r\<^sup>\" +lemma per_rootI[intro]: "u \p r \ u \ r \ \ \ u

u" + by simp + +lemma per_rootI'[intro]: assumes "u \p r\<^sup>@k" and "r \ \" shows "u

u" using per_rootI[OF pref_prod_pref[OF pref_pow_ext'[OF \u \p r\<^sup>@k\] \u \p r\<^sup>@k\] \r\\\]. -lemma per_rootD[dest]: "u \p r\<^sup>\ \ u \p r \ u" - by simp - -lemma per_rootD'[dest]: "u \p r\<^sup>\ \ r \ \" +lemma per_root_nemp[dest]: "u

u \ r \ \" by simp text \Empty word is not a periodic root but it has all nonempty periodic roots.\ -lemma emp_any_per: "r \ \ \ (\ \p r\<^sup>\ )" - by simp - -lemma emp_not_per: "\ (x \p \\<^sup>\)" - by simp + text \Any nonempty word is its own periodic root.\ -lemma root_self: "w \ \ \ w \p w\<^sup>\" - by simp +lemmas root_self = triv_spref text\"Short roots are prefixes"\ -lemma "w \p r\<^sup>\ \ \<^bold>|r\<^bold>| \ \<^bold>|w\<^bold>| \ r \p w" - using pref_prod_long[OF per_rootD]. +lemma "w

u \ \<^bold>|r\<^bold>| \ \<^bold>|w\<^bold>| \ r \p w" + using pref_prod_long[OF sprefD1]. text \Periodic words are prefixes of the power of the root, which motivates the notation\ lemma pref_pow_ext_take: assumes "u \p r\<^sup>@k" shows "u \p take \<^bold>|r\<^bold>| u \ r\<^sup>@k" proof (rule le_cases[of "\<^bold>|u\<^bold>|" "\<^bold>|r\<^bold>|"]) assume "\<^bold>|r\<^bold>| \ \<^bold>|u\<^bold>|" show "u \p take \<^bold>|r\<^bold>| u \ r \<^sup>@ k" unfolding pref_take[OF pref_prod_long[OF pref_pow_ext'[OF \u \p r\<^sup>@k\] \\<^bold>|r\<^bold>| \ \<^bold>|u\<^bold>|\]] using pref_pow_ext'[OF \u \p r\<^sup>@k\]. qed simp lemma pref_pow_take: assumes "u \p r\<^sup>@k" shows "u \p take \<^bold>|r\<^bold>| u \ u" using pref_prod_pref[of u "take \<^bold>|r\<^bold>| u" "r\<^sup>@k", OF pref_pow_ext_take \u \p r\<^sup>@k\, OF \u \p r\<^sup>@k\]. -lemma per_exp: "u \p r\<^sup>\ \ u \p r\<^sup>@k \ u" - using per_exp_pref[OF per_rootD]. - -lemma per_root_spref_powE: assumes "u \p r\<^sup>\" - obtains k where "u

@k" - 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 \p t\<^sup>\" obtains n r where "r

@n \ r = u" + +lemma per_root_powE: assumes "u

u" + obtains k where "u

@k" and "0 < k" + using pref_prod_less[OF per_exp_pref[OF sprefD1] + long_pow_exp'[OF per_root_nemp], OF assms assms] by blast + +thm per_rootI per_rootI' + +lemma per_root_powE': assumes "x

x" + obtains k where "x \p r\<^sup>@k" and "0 < k" + using per_root_powE[OF assms] sprefD1 by metis + +lemma per_root_modE' [elim]: assumes "u

u" + obtains p where "p

@(\<^bold>|u\<^bold>| div \<^bold>|r\<^bold>|) \ p = u" proof- - obtain m where "u

@m" - using per_root_spref_powE[OF \u \p t\<^sup>\\]. - from pref_mod_power[OF this that] - show ?thesis. -qed - -lemma per_add_exp: assumes "u \p r\<^sup>\" and "m \ 0" shows "u \p (r\<^sup>@m)\<^sup>\" - using per_exp_pref[OF per_rootD, OF \u \p r\<^sup>\\] per_rootD'[OF \u \p r\<^sup>\\, folded nonzero_pow_emp[OF \m \ 0\, of r]] - .. - -lemma per_pref_ex: assumes "u \p r\<^sup>\" - obtains n where "u \p r\<^sup>@n" and "n \ 0" - using comp_shorter ruler_pref''[OF per_exp[OF \u \p r\<^sup>\\]] long_pow_ex[of r "\<^bold>|u\<^bold>|", OF per_rootD'[OF \u \p r\<^sup>\\], of thesis] - by blast - -lemma root_ruler: assumes "w \p u\w" "v \p u\v" "u \ \" + have "r \ \" + using assms by blast + obtain m where "u

@m" + using per_root_powE[OF \u

u\]. + from pref_mod_pow[OF sprefD1[OF this] per_root_nemp[OF assms]] + obtain k z where "k \ m" and "z

@ k \ z = u". + have "k = (\<^bold>|u\<^bold>| div \<^bold>|r\<^bold>|)" + using lenarg[OF \r \<^sup>@ k \ z = u\, unfolded lenmorph pow_len] + get_div[OF prefix_length_less[OF \z

]] by metis + thus ?thesis + using that \r \<^sup>@ k \ z = u\ \z

by blast +qed + +lemma per_root_modE [elim]: assumes "u

u" + obtains n p s where "p \ s = r" and "r\<^sup>@n \ p = u" and "s \ \" + using per_root_modE'[OF assms] spref_exE by metis + + lemma nemp_per_root_conv: "r \ \ \ u

u \ u \p r \ u" + by force + + + +lemma root_ruler: assumes "w

w" "v

v" shows "w \ v" proof- - obtain k l where "w \p u\<^sup>@k" "v \p u\<^sup>@l" - using assms per_pref_ex[unfolded period_root_def] by metis + obtain k l where "w

@k" "v

@l" + using assms per_root_powE by metis moreover have "u\<^sup>@k \ u\<^sup>@l" - by (metis conjug_pow eqd_comp) + using conjug_pow eqd_comp by metis ultimately show ?thesis - by (meson ruler_comp) + by (rule ruler_comp[OF sprefD1 sprefD1]) qed lemmas same_len_nemp_root_eq = root_ruler[THEN pref_comp_eq] -theorem per_pref: "x \p r\<^sup>\ \ (\ k. x \p r\<^sup>@k) \ r \ \" - using per_pref_ex period_root_def pref_pow_ext' pref_prod_pref by metis - -lemma per_prefE: assumes "x \p r \ x" and "r \ \" - obtains k where "x \p r\<^sup>@k" - using assms per_pref per_rootI by metis - -lemma per_root_fac: assumes "w \p r \ w" and "r \ \" obtains k where "w \f r\<^sup>@k" - using per_prefE[OF _ _ pref_fac[elim_format], OF assms]. - -lemma pref_pow_conv: "(\ k. x \p r\<^sup>@k) \ (\ k z. r\<^sup>@k\z = x \ z \p r)" -proof - assume "\k z. r \<^sup>@ k \ z = x \ z \p r" - then obtain k z where "r\<^sup>@k \ z = x" and "z \p r" by blast - thus "\ k. x \p r\<^sup>@k" - using pref_cancel'[OF \z \p r\, of "r\<^sup>@k", unfolded \r\<^sup>@k \ z = x\, folded pow_Suc2] by fast -next - assume "\ k. x \p r\<^sup>@k" then obtain k where "x \p r\<^sup>@k" by blast - {assume "r = \" - have "x = \" - using pref_emp[OF \x \p r \<^sup>@ k\[unfolded \r = \\ emp_pow]]. - hence "\ k z. r\<^sup>@k\z = x \ z \p r" - using \r = \\ emp_pow by auto} - moreover - {assume "r \ \" have "x

@(Suc k)" - using pref_ext_nemp[OF \x \p r\<^sup>@k\ \r \ \\, folded pow_Suc2]. - then have "\ k z. r\<^sup>@k\z = x \ z \p r" - using pref_mod_power[OF pref_ext_nemp[OF \x \p r\<^sup>@k\ \r \ \\, folded pow_Suc2], of "\ k z. r\<^sup>@k\z = x \ z \p r"] - by auto} - ultimately show "\ k z. r\<^sup>@k\z = x \ z \p r" by blast -qed - -lemma per_root_eq: assumes "w \p r \ w" and "r \ \" - obtains p s m where "r = (p \ s)" and "w = (p \ s)\<^sup>@m \ p" - using conjI[OF assms, unfolded per_pref[unfolded pref_pow_conv period_root_def]] prefD by metis - -lemma per_root_eq': assumes "w \p r \ w" and "r \ \" - obtains p s m where "r = p \ s" and "w = p \ (s \ p)\<^sup>@m" + + + + + + +lemma per_root_add_exp: assumes "u

u" "0 < m" shows "u

@m \ u" + using \0 < m\ +proof (induct m) + case (Suc m) + then show ?case + unfolding pow_Suc rassoc + using spref_trans[OF \u

u\, of "r \ r \<^sup>@ m \ u"] \u

u\ + unfolding spref_cancel_conv by (cases "m = 0") simp_all + qed simp + +theorem per_root_pow_conv: "x

x \ (\ k. x \p r\<^sup>@k) \ r \ \" + by (rule iffI) (use per_root_powE' per_root_nemp in metis, use per_rootI' in blast) + +lemma per_root_exp': assumes "x \p r\<^sup>@k" shows "x \p r\<^sup>@\<^bold>|x\<^bold>|" +proof(cases "r = \") + assume "r \ \" + have "\<^bold>|x\<^bold>| \ \<^bold>|r\<^sup>@\<^bold>|x\<^bold>|\<^bold>|" + unfolding pow_len using nemp_le_len[OF \r \ \\] by force + with pref_ext[OF \x \p r\<^sup>@k\, of "r\<^sup>@\<^bold>|x\<^bold>|", unfolded pows_comm[of r k]] + show ?thesis + by blast +qed (use assms in force) + +lemma per_root_exp: assumes "x

x" shows "x \p r\<^sup>@\<^bold>|x\<^bold>|" proof- - obtain p s m where "r = p \ s" and "w = (p \ s)\<^sup>@m \ p" - using per_root_eq[OF \w \p r \ w\ \r \ \\]. - from that[OF this[unfolded shift_pow]] - show thesis. -qed - -lemma per_eq: "x \p r\<^sup>\ \ (\ k z. r\<^sup>@k\z = x \ z \p r) \ r \ \" - using per_pref[unfolded pref_pow_conv]. - -text\The previous theorem allows to prove some basic relations between powers, periods and commutation\ - -lemma per_drop_exp: "u \p (r\<^sup>@m)\<^sup>\ \ u \p r\<^sup>\" - unfolding per_pref[of u r] per_pref[of u "r\<^sup>@m"] pow_mult[symmetric] using nemp_pow_nemp - by blast + obtain k where "x \p r\<^sup>@k" + using \x

x\ unfolding per_root_pow_conv by blast + from per_root_exp'[OF this] + show "x \p r\<^sup>@\<^bold>|x\<^bold>|". +qed + +lemma per_root_drop_exp: "u

@m) \ u \ u

u" + unfolding per_root_pow_conv unfolding pow_mult[symmetric] + using emp_pow by blast + +lemma per_root_exp_conv: "u

@Suc m) \ u \ u

u" + by (rule iffI) (use per_root_drop_exp in blast, use per_root_add_exp in blast) lemma pref_drop_exp: assumes "x \p z \ x\<^sup>@m" shows "x \p z \ x" using assms pow_comm pref_prod_pref pref_prolong triv_pref by metis -lemma per_root_drop_exp: "x \p r\<^sup>@(Suc k) \ x\<^sup>@m \ x \p r \ 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 \ 0" and "x \p r\<^sup>@k \ x" shows "x \p r \ x" - using per_root_drop_exp[of _ _ "k-1" 1, unfolded pow_one' Suc_minus[OF \k \ 0\], OF assms(2)]. +lemma per_root_drop_exp': "x \p r\<^sup>@(Suc k) \ x\<^sup>@m \ x \p r \ x" + using nemp_Suc_pow_nemp per_rootI per_root_drop_exp pref_drop_exp sprefD by metis + +lemma per_drop_exp': "0 < k \ x \p r\<^sup>@k \ x \ x \p r \ x" + using nonzero_pow_emp per_rootI per_root_drop_exp sprefD by metis lemmas per_drop_exp_rev = per_drop_exp'[reversed] - -corollary comm_drop_exp: assumes "m \ 0" and "u \ r\<^sup>@m = r\<^sup>@m' \ u" shows "r \ u = u \ r" +corollary comm_drop_exp: assumes "0 < m" and "u \ r\<^sup>@m = r\<^sup>@m' \ u" shows "r \ u = u \ r" proof assume "r \ \" "u \ \" hence "m = m'" using lenarg[OF \u \ r\<^sup>@m = r\<^sup>@m' \ u\] unfolding lenmorph pow_len by auto have "u\r \p u\r\<^sup>@m" - unfolding pop_pow_one[OF \m \ 0\] by simp + unfolding pow_pos[OF \0 < m\] by simp have "u\r \p r\<^sup>@m' \ u \ r" using pref_ext[of "u \ r" "r\<^sup>@m \ u" r, unfolded rassoc \m = m'\, OF \u\r \p u\r\<^sup>@m\[unfolded \u \ r\<^sup>@m = r\<^sup>@m' \ u\]]. hence "u\r \p r\(u\r)" - using per_drop_exp[of "u\r" r m'] \m \ 0\[unfolded \m = m'\] per_drop_exp' by blast + using per_root_drop_exp[of "u\r" r m'] \0 < m\[unfolded \m = m'\] per_drop_exp' by blast from comm_ruler[OF self_pref[of "r \ u"], of "r \ u \ r", OF this] - show "r \ u = u \ r" by auto -qed - -lemma comm_drop_exp': "u\<^sup>@Suc k \ v = v \ u\<^sup>@Suc k' \ u \ v = v \ u" - using comm_drop_exp[OF nat.discI] by metis - -lemma comm_drop_exps[elim]: assumes "u\<^sup>@Suc m \ v\<^sup>@Suc k = v\<^sup>@Suc k \ u\<^sup>@Suc m" shows "u \ v = v \ u" - using comm_drop_exp'[OF comm_drop_exp'[OF assms, symmetric], symmetric]. - -lemma comm_drop_exps_conv: "u\<^sup>@Suc m \ v\<^sup>@Suc k = v\<^sup>@Suc k \ u\<^sup>@Suc m \ u \ v = v \ u" - by (meson comm_add_exps comm_drop_exps) - -corollary pow_comm_comm: assumes "x\<^sup>@j = y\<^sup>@k" and "j \ 0" shows "x\y = y\x" - using comm_drop_exp[OF \j \ 0\, of y x j, unfolded \x\<^sup>@j = y\<^sup>@k\, OF power_commutes[symmetric]]. - -corollary comm_pow_roots: assumes "m \ 0" "k \ 0" + show "r \ u = u \ r" + unfolding prefix_comparable_def + by force +qed + +lemma comm_drop_exp': assumes "u\<^sup>@k \ v = v \ u\<^sup>@k'" "0 < k'" shows "u \ v = v \ u" + using comm_drop_exp[OF \0 < k'\ assms(1)[symmetric]]. + +lemma comm_drop_exps[elim]: assumes "u\<^sup>@m \ v\<^sup>@k = v\<^sup>@k \ u\<^sup>@m" and "0 < m" and "0 < k" shows "u \ v = v \ u" + using comm_drop_exp[OF \0 < k\ \u\<^sup>@m \ v\<^sup>@k = v\<^sup>@k \ u\<^sup>@m\] comm_drop_exp[OF \0 < m\, of v u m] by blast + +lemma comm_pow_roots: + assumes "0 < m" and "0 < k" shows "u\<^sup>@m \ v\<^sup>@k = v\<^sup>@k \ u\<^sup>@m \ u \ v = v \ u" - using comm_drop_exp[OF \k \ 0\, of "u\<^sup>@m" v, THEN comm_drop_exp[OF \m \ 0\, of v u]] - comm_add_exps[of u v m k] by blast + by (rule, use comm_drop_exps[OF _ assms] in blast) + (use comm_add_exps in blast) + +corollary pow_comm_comm: assumes "x\<^sup>@j = y\<^sup>@k" and "0 < j" shows "x\y = y\x" + using comm_drop_exp[OF \0 < j\, of y x j, unfolded \x\<^sup>@j = y\<^sup>@k\, OF pow_comm[symmetric]]. + lemma pow_comm_comm': assumes comm: "u\<^sup>@(Suc k) = v\<^sup>@(Suc l)" shows "u \ v = v \ u" using comm pow_comm_comm by blast lemma comm_trans: assumes uv: "u\v = v\u" and vw: "w\v = v\w" and nemp: "v \ \" shows "u \ w = w \ u" proof - consider (u_emp) "u = \" | (w_emp) "w = \" | (nemp') "u \ \" and "w \ \" 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 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 \p u \ x" and "v \ u = u \ v" and "u \ \" shows "x \p v \ x" - using per_rootI[OF \x \p u\x\ \u \ \\] per_exp commE[OF \v \ u = u \ v\] per_drop_exp by metis - -theorem per_all_exps: "\ m \ 0; k \ 0 \ \ (u \p (r\<^sup>@m)\<^sup>\) \ (u \p (r\<^sup>@k)\<^sup>\)" - 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 \p u\<^sup>\" shows "drop \<^bold>|u\<^bold>| w \p w" - using pref_drop[OF per_rootD[OF \w \p u\<^sup>\\], of "\<^bold>|u\<^bold>|", unfolded drop_pref[of u w]]. - -lemma per_root_trans[intro]: "w \p u\<^sup>\ \ u \ t* \ w \p t\<^sup>\" - using root_def[of u t] per_drop_exp[of w t] by blast + using per_rootI[OF \x \p u\x\ \u \ \\] per_exp_pref commE[OF \v \ u = u \ v\] per_drop_exp' + assms(1) assms(3) nemp_pow by metis + + +lemma drop_per_pref: assumes "w

w" shows "drop \<^bold>|u\<^bold>| w \p w" + using pref_drop[OF sprefD1[OF \w

w\], of "\<^bold>|u\<^bold>|", unfolded drop_pref[of u w]]. + +lemma per_root_trans[intro]: assumes "w

w" and "u \ t*" shows "w

w" + using per_root_drop_exp rootE[OF \u \ t*\] \w

w\ by metis lemma per_root_trans'[intro]: "w \p u \ w \ u \ r* \ u \ \ \ w \p r \ w" - using per_root_trans per_rootD per_rootI by metis - -lemmas per_root_trans_suf'[intro] = per_root_trans'[reversed] + using per_root_trans sprefD1 per_rootI by metis + +lemmas per_root_trans_suf'[intro] = per_root_trans'[reversed] text\Note that -@{term "w \p u\<^sup>\ \ u \p t\<^sup>\ \ w \p t\<^sup>\"} +@{term "w

w \ u

u \ w

w"} does not hold. \ -lemma per_root_same_prefix:"w \p r\<^sup>\ \ w' \p r\<^sup>\ \ w \ w'" +lemma per_root_same_prefix:"w

w \ w' \p r \ w' \ w \ w'" using root_ruler by auto -lemma take_after_drop: "\<^bold>|u\<^bold>| + q \ \<^bold>|w\<^bold>| \ w \p u\<^sup>\ \ take q (drop \<^bold>|u\<^bold>| w) = take q w" +lemma take_after_drop: "\<^bold>|u\<^bold>| + q \ \<^bold>|w\<^bold>| \ w

w \ 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\The following lemmas are a weak version of the Periodicity lemma\ lemma two_pers: assumes pu: "w \p u \ w" and pv: "w \p v \ w" and len: "\<^bold>|u\<^bold>| + \<^bold>|v\<^bold>| \ \<^bold>|w\<^bold>|" shows "u \ v = v \ u" proof- have uv: "w \p (u \ v) \ w" using pref_prolong[OF pu pv] unfolding lassoc. have vu: "w \p (v \ u) \ w" using pref_prolong[OF pv pu] unfolding lassoc. have "u \ v \p w" using len pref_prod_long[OF uv] by simp moreover have "v \ u \p w" using len pref_prod_long[OF vu] by simp ultimately show "u \ v = v \ u" by (rule pref_comp_eq[unfolded prefix_comparable_def, OF ruler swap_len]) qed -lemma two_pers_root: assumes "w \p u\<^sup>\" and "w \p v\<^sup>\" and "\<^bold>|u\<^bold>|+\<^bold>|v\<^bold>| \ \<^bold>|w\<^bold>|" shows "u\v = v\u" - using two_pers[OF per_rootD[OF assms(1)] per_rootD[OF assms(2)] assms(3)]. - -lemma split_pow: assumes "x \ y \ y \ x" and "x \ y = z\<^sup>@k" - obtains l m u v where "z\<^sup>@l \ u = x" and "v \ z\<^sup>@m = y" and "u \ v = z" and "u \ v \ v \ 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>| \ \<^bold>|z\<^bold>|" - then obtain v where "v \ z \<^sup>@ k = y" "x \ v = z" - using eqd[OF \x \ y = z \<^sup>@ Suc k\[unfolded pow_Suc]] by blast - hence "x \ v \ v \ x" - using \x \ v = z\ \x \ y \ y \ x\ shift_pow rassoc by metis - from Suc.prems(1)[of 0, OF _ \v \ z \<^sup>@ k = y\ \x \ v = z\ this] - show thesis by auto - next - assume "\<^bold>|z\<^bold>| < \<^bold>|x\<^bold>|" - then obtain x' where "z \ x' = x" "x' \ y = z \<^sup>@ k" - using eqd[OF \x \ y = z \<^sup>@ Suc k\[symmetric, unfolded pow_Suc]] by auto - have "x' \ \" - using \\<^bold>|z\<^bold>| < \<^bold>|x\<^bold>|\ \z \ x' = x\ by force - have "x' \ y \ y \ x'" - proof (rule notI) - assume "x' \ y = y \ x'" - hence "y \ z\<^sup>@k = z\<^sup>@k \ y" and "x' \ z\<^sup>@k = z\<^sup>@k \ x'" - using \x' \ y = z \<^sup>@ k\ by force+ - have "x \ z\<^sup>@k = z\<^sup>@k \ x" - unfolding \z \ x' = x\[symmetric] rassoc \x' \ z\<^sup>@k = z\<^sup>@k \ x'\ - unfolding lassoc cancel_right pow_comm.. - have "z\<^sup>@k \ \" - using \x' \ y = z \<^sup>@ k\ \x' \ \\ by fastforce - show False - using comm_trans[OF \y \ z\<^sup>@k = z\<^sup>@k \ y\ \x \ z\<^sup>@k = z\<^sup>@k \ x\ \z\<^sup>@k \ \\] \x \ y \ y \ x\ by argo - qed - from Suc.hyps[OF _ this \x' \ y = z \<^sup>@ k\] - obtain l u v m where "z \<^sup>@ l \ u = x'" "v \ z \<^sup>@ m = y" "u \ v = z" "u \ v \ v \ u" "k = Suc (l + m)". - from Suc.prems(1)[OF _ this(2-4), of "Suc l", folded \z \ x' = x\, unfolded pow_Suc rassoc cancel, OF this(1)] - show thesis - using \k = Suc (l + m)\ by simp +lemma two_pers_root: assumes "w

w" and "w

w" and "\<^bold>|u\<^bold>| + \<^bold>|v\<^bold>| \ \<^bold>|w\<^bold>|" shows "u\v = v\u" + using two_pers[OF sprefD1[OF assms(1)] sprefD1[OF assms(2)] assms(3)]. + +subsection \Maximal root-prefix\ + +lemma max_root_mismatch: assumes "u \ [a]

u \ [a]" and "u \ [b] \p w" and "a \ b" + shows "w \\<^sub>p r \ w = u" +proof (rule lcp_first_mismatch_pref[OF \u \ [b] \p w\ _ \a \ b\[symmetric]]) + have "u \ [a] \p r \ u" + using assms(1)[unfolded lassoc spref_snoc_iff]. + thus "u \ [a] \p r \ w" + using append_prefixD[OF \u \ [b] \p w\] pref_prolong by blast +qed + + +lemma max_pref_per_root: "u \\<^sub>p r \ u \p r \ (u \\<^sub>p r \ u)" + by (rule pref_prod_pref[of _ _ u]) force+ + +lemma max_pref_pref: + assumes "r \ \" + shows "u \\<^sub>p r \ u \p r\<^sup>@\<^bold>|u \\<^sub>p r \ u\<^bold>|" +proof- + have "u \\<^sub>p r \ u

(u \\<^sub>p r \ u)" + using assms max_pref_per_root by auto + from per_root_exp[OF this] + show ?thesis. +qed + + +lemma max_pref_lcp_root_pow: assumes "r \ \" and "\<^bold>|u \\<^sub>p r \ u\<^bold>| \ k" + shows "u \\<^sub>p r \ u = u \\<^sub>p r\<^sup>@k" (is "?max = u \\<^sub>p r\<^sup>@k") +proof (rule pref_antisym) + from max_pref_pref[OF assms(1)] le_exps_pref[OF assms(2)] + have "?max \p r\<^sup>@k" + using pref_trans by blast + thus "?max \p u \\<^sub>p r\<^sup>@k" + by force + show "u \\<^sub>p r\<^sup>@k \p ?max" + proof (rule lcp.boundedI, force) + show "u \\<^sub>p r \<^sup>@ k \p r \ u" + proof (rule pref_prolong) + show "u \\<^sub>p r \<^sup>@ k \p r \ (u \\<^sub>p r \<^sup>@ k)" + using lcp.cobounded2 by (rule pref_prod_root[of "u \\<^sub>p r\<^sup>@k"]) + show "u \\<^sub>p r \<^sup>@ k \p u" + using lcp.cobounded1. qed qed qed +lemma max_pref_shorter_lcp: assumes "u \\<^sub>p r \ u

\<^sub>p r \ v" + shows "u \\<^sub>p v = u \\<^sub>p r \ u" +proof (cases) + assume "r = \" + then show ?thesis + using assms by (clarify, unfold emp_simps lcp.idem) (use lcp.absorb3 in blast) +next + let ?u = "u \\<^sub>p r \ u" and ?v = "v \\<^sub>p r \ v" + assume "r \ \" + from max_pref_lcp_root_pow[OF this] + obtain k where "?u = u \\<^sub>p r\<^sup>@k" and "?v = v \\<^sub>p r\<^sup>@k" + using pref_len' suf_len' by meson + from ruler_spref_lcp[OF assms[unfolded this], folded \?u = u \\<^sub>p r\<^sup>@k\] + show "u \\<^sub>p v = u \\<^sub>p r \ u". +qed + + +find_theorems "?u \\<^sub>p ?r \ ?u" + subsection "Period - numeric" text\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.\ definition period :: "'a list \ nat \ bool" - where [simp]: "period w n = w \p (take n w)\<^sup>\" - -lemma period_I': "w \ \ \ n \ 0 \ w \p (take n w) \ w \ period w n" - unfolding period_def period_root_def by fastforce - -lemma period_I[intro]: "w \ \ \ r \ \ \ w \p r \ w \ period w \<^bold>|r\<^bold>|" - using period_I'[of _ "\<^bold>|r\<^bold>|", OF _ nemp_len] per_prefE pref_pow_take by metis + where [simp]: "period w n \ w

w" + +lemma period_I': "w \ \ \ 0 < n \ w \p (take n w) \ w \ period w n" + unfolding period_def by fastforce + +lemma periodI[intro]: "w \ \ \ w

w \ period w \<^bold>|r\<^bold>|" + by (elim period_I'[of _ "\<^bold>|r\<^bold>|", OF _ nemp_pos_len]) + (blast, use pref_pow_take per_root_powE' in metis) text\The numeric definition respects the following convention about empty words and empty periods.\ lemma emp_no_period: "\ period \ n" by simp -lemma zero_not_per: "\ period w 0" +lemma "\ period w 0" by simp -(* lemma period_I [intro]: assumes "u \p r\<^sup>@k" and "u \ \" shows "period u \<^bold>|r\<^bold>|" *) -(* unfolding period_def period_root_def *) -(* using pref_pow_take[OF \u \p r\<^sup>@k\] take_nemp_len[OF \u \ \\] \u \p r\<^sup>@k\ by force *) - -(* lemma periodI' [intro]: "u \np r\<^sup>@k \ period u \<^bold>|r\<^bold>|" *) -(* unfolding nonempty_prefix_def by blast *) - -lemma period_D1: "period w n \ w \ \" + + +lemma per_nemp: "period w n \ w \ \" by simp -lemma period_D2: "period w n \ n \ 0" +lemma per_not_zero: "period w n \ 0 < n" by simp -lemma period_D3: "period w n \ w \p take n w \ w" +lemma per_pref: "period w n \ w \p take n w \ w" by simp text\A nonempty word has all "long" periods\ lemma all_long_pers: "\ w \ \; \<^bold>|w\<^bold>| \ n \ \ period w n" by simp lemma len_is_per: "w \ \ \ period w \<^bold>|w\<^bold>|" by simp -lemmas per_nemp = period_D1 - -lemmas per_positive = period_D2 - text\The standard numeric definition of a period uses indeces.\ 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 \ 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 \i + n < \<^bold>|w\<^bold>|\]]]. also have "... = w ! (i + n)" - using pref_index[OF period_D3[OF \period w n\] \i + n < \<^bold>|w\<^bold>|\, symmetric] unfolding add.commute[of n i]. + using pref_index[OF per_pref[OF \period w n\] \i + n < \<^bold>|w\<^bold>|\, symmetric] unfolding add.commute[of n i]. finally show ?thesis. qed lemma indeces_period: - assumes "w \ \" and "n \ 0" and forall: "\ i. i + n < \<^bold>|w\<^bold>| \ w!i = w!(i+n)" + assumes "w \ \" and "0 < n" and forall: "\ i. i + n < \<^bold>|w\<^bold>| \ w!i = w!(i+n)" shows "period w n" proof- have "\<^bold>|w\<^bold>| \ \<^bold>|take n w \ w\<^bold>|" by auto {fix j assume "j < \<^bold>|w\<^bold>|" have "w ! j = (take n w \ w) ! j" proof (cases "j < \<^bold>|take n w\<^bold>|") assume "j < \<^bold>|take n w\<^bold>|" show "w ! j = (take n w \ w) ! j" using pref_index[OF take_is_prefix \j < \<^bold>|take n w\<^bold>|\, symmetric] unfolding pref_index[OF triv_pref \j < \<^bold>|take n w\<^bold>|\, of w]. next assume "\ j < \<^bold>|take n w\<^bold>|" from leI[OF this] \j < \<^bold>|w\<^bold>|\ have "\<^bold>|take n w\<^bold>| = n" by force hence "j = (j - n) + n" and "(j - n) + n < \<^bold>|w\<^bold>|" using leI[OF \\ j < \<^bold>|take n w\<^bold>|\] \j < \<^bold>|w\<^bold>|\ 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 \\<^bold>|take n w\<^bold>| = n\]] show "w ! j = (take n w \ w) ! j" using \j = (j - n) + n\ by simp qed} with index_pref[OF \\<^bold>|w\<^bold>| \ \<^bold>|take n w \ w\<^bold>|\] have "w \p take n w \ w" by blast thus ?thesis using assms by force qed text\In some cases, the numeric definition is more useful than the definition using the period root.\ 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]]) +proof (rule indeces_period[of "rev w" p, OF _ per_not_zero[OF assms]]) show "rev w \ \" - using assms[unfolded period_def period_root_def] by force + using assms[unfolded period_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 \i + p < \<^bold>|rev w\<^bold>|\ by simp - have "\<^bold>|w\<^bold>| - Suc (i + p) + p < \<^bold>|w\<^bold>|" + have "\<^bold>|w\<^bold>| - Suc (i + p) + p < \<^bold>|w\<^bold>|" using \i + p < \<^bold>|w\<^bold>|\ Suc_diff_Suc \i < \<^bold>|w\<^bold>|\ - diff_less_Suc e less_irrefl_nat not_less_less_Suc_eq by metis + diff_less_Suc e less_irrefl_nat not_less_less_Suc_eq by metis from period_indeces[OF assms this] rev_nth[OF \i < \<^bold>|w\<^bold>|\, folded e] rev_nth[OF \i + p < \<^bold>|w\<^bold>|\] show "rev w ! i = rev w !(i+p)" by presburger qed lemma period_rev_conv [reversal_rule]: "period (rev w) n \ period w n" using period_rev period_rev[of "rev w"] unfolding rev_rev_ident by (intro iffI) lemma period_fac: assumes "period (u\w\v) p" and "w \ \" shows "period w p" -proof (rule indeces_period, simp add: \w \ \\) - show "p \ 0" using period_D2[OF \period (u\w\v) p\]. +proof (rule indeces_period) + show "0 < p" using per_not_zero[OF \period (u\w\v) p\]. fix i assume "i + p < \<^bold>|w\<^bold>|" hence "\<^bold>|u\<^bold>| + i + p < \<^bold>|u\w\v\<^bold>|" by simp from period_indeces[OF \period (u\w\v) p\ this] have "(u\w\v)!(\<^bold>|u\<^bold>| + i) = (u\w\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\v" i, unfolded lassoc] \i + p < \<^bold>|w\<^bold>|\ add_lessD1[OF \i + p < \<^bold>|w\<^bold>|\] nth_append[of w v] by auto -qed +qed (simp add: \w \ \\) lemma period_fac': "period v p \ u \f v \ u \ \ \ period u p" by (elim facE, hypsubst, rule period_fac) -lemma assumes "y \ \" and "k \ 0" shows "y\<^sup>@k \ \" - by (simp add: assms(1) assms(2) nemp_emp_pow) - - -lemma pow_per: assumes "y \ \" and "k \ 0" shows "period (y\<^sup>@k) \<^bold>|y\<^bold>|" - using period_I'[OF \k \ 0\[folded nemp_emp_pow[OF \y \ \\]] nemp_len[OF \y \ \\]] pref_pow_ext_take by blast - -lemma per_fac: assumes "w \ \" and "w \f y\<^sup>@k" shows "period w \<^bold>|y\<^bold>|" +lemma pow_per[intro]: assumes "y \ \" and "0 < k" shows "period (y\<^sup>@k) \<^bold>|y\<^bold>|" + using period_I'[OF _ nemp_pos_len[OF \y \ \\] pref_pow_ext_take, OF _ self_pref] + assms by blast + +lemma per_fac: assumes "w \ \" and "w \f y\<^sup>@k" shows "period w \<^bold>|y\<^bold>|" proof- have "y \ \" - using assms by force - have "k \ 0" + using assms by force + have "0 < k" using assms nemp_exp_pos sublist_Nil_right by metis from pow_per[OF \y \ \\ this] period_fac facE[OF \w \f y\<^sup>@k\] \w \ \\ show "period w \<^bold>|y\<^bold>|" by metis qed text\The numeric definition is equivalent to being prefix of a power.\ theorem period_pref: "period w n \ (\k r. w \np r\<^sup>@k \ \<^bold>|r\<^bold>| = n)" (is "_ \ ?R") -proof(cases "w = \", simp) +proof(cases "w = \") assume "w \ \" show "period w n \ ?R" proof assume "period w n" consider (short) "\<^bold>|w\<^bold>| \ n" | (long) "n < \<^bold>|w\<^bold>|" by linarith then show ?R proof(cases) assume "\<^bold>|w\<^bold>| \ n" from le_add_diff_inverse[OF this] obtain z where "\<^bold>|w \ z\<^bold>| = n" unfolding lenmorph using exE[OF Ex_list_of_length[of "n - \<^bold>|w\<^bold>|"]] by metis thus ?R - using pow_one' npI'[OF \w \ \\] by metis + using pow_1 npI'[OF \w \ \\] by metis next assume "n < \<^bold>|w\<^bold>|" then show ?R - using \period w n\[unfolded period_def per_pref[of w "take n w"]] - \w \ \\ take_len[OF less_imp_le[OF \n < \<^bold>|w\<^bold>|\]] by blast + unfolding nonempty_prefix_def + using \w \ \\ take_len[OF less_imp_le[OF \n < \<^bold>|w\<^bold>|\]] + per_root_powE[OF \period w n\[unfolded period_def]] + sprefD1 by metis qed next assume ?R then obtain k r where "w \np r\<^sup>@k" and "n = \<^bold>|r\<^bold>|" by blast have "w \p take n w \ w" using pref_pow_take[OF npD[OF \w \np r \<^sup>@ k\], folded \n = \<^bold>|r\<^bold>|\]. have "n \ 0" unfolding length_0_conv[of r, folded \n = \<^bold>|r\<^bold>|\] using \w \np r \<^sup>@ k\ by force hence "take n w \ \" unfolding \n = \<^bold>|r\<^bold>|\ using \w \ \\ by simp thus "period w n" - unfolding period_def period_root_def using \w \p take n w \ w\ by blast + unfolding period_def using \w \p take n w \ w\ by blast qed -qed +qed simp text \Two more characterizations of a period\ -theorem per_shift: assumes "w \ \" "n \ 0" +theorem per_shift: assumes "w \ \" "0 < n" shows "period w n \ drop n w \p w" proof assume "period w n" show "drop n w \p w" using drop_per_pref[OF \period w n\[unfolded period_def]] append_take_drop_id[of n w, unfolded append_eq_conv_conj] by argo next assume "drop n w \p w" show "period w n" - using conjI[OF pref_cancel'[OF \drop n w \p w\, of "take n w"] take_nemp[OF \w \ \\ \n \ 0\]] - unfolding append_take_drop_id period_root_def by force -qed - -lemma rotate_per_root: assumes "w \ \" and "n \ 0" and "w = rotate n w" + using conjI[OF pref_cancel'[OF \drop n w \p w\, of "take n w"] take_nemp[OF \w \ \\ \0 < n\]] + unfolding append_take_drop_id by force +qed + +lemma rotate_per_root: assumes "w \ \" and "0 < n" and "w = rotate n w" shows "period w n" proof (cases "\<^bold>|w\<^bold>| \ n") assume "\<^bold>|w\<^bold>| \ n" from all_long_pers[OF \w \ \\, OF this] show "period w n". next assume not: "\ \<^bold>|w\<^bold>| \ n" have "drop (n mod \<^bold>|w\<^bold>|) w \p w" using prefI[OF rotate_drop_take[symmetric, of n w]] unfolding \w = rotate n w\[symmetric]. - from per_shift[OF \w \ \\ \n \ 0\] this[unfolded mod_less[OF not[unfolded not_le]]] + from per_shift[OF \w \ \\ \0 < n\] this[unfolded mod_less[OF not[unfolded not_le]]] show "period w n".. qed subsubsection \Various lemmas on periods\ 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" \ p] \p < \<^bold>|w\<^bold>|\ \period w p\ unfolding append_take_drop_id drop_eq_Nil not_le append_Nil2 by blast lemma ext_per_left: assumes "period w p" and "p \ \<^bold>|w\<^bold>|" shows "period (take p w \ w) p" proof- have f: "take p (take p w \ w) = take p w" using \p \ \<^bold>|w\<^bold>|\ by simp show ?thesis - using \period w p\ pref_cancel'[of w "take p w \ w" "take p w" ] unfolding f period_def period_root_def + using \period w p\ pref_cancel'[of w "take p w \ w" "take p w" ] + unfolding f period_def by blast qed lemma ext_per_left_power: "period w p \ p \ \<^bold>|w\<^bold>| \ period ((take p w)\<^sup>@k \ w) p" proof (induction k) case (Suc k) show ?case using ext_per_left[OF Suc.IH[OF \period w p\ \p \ \<^bold>|w\<^bold>|\]] \p \ \<^bold>|w\<^bold>|\ - unfolding pref_share_take[OF per_exp_pref[OF period_D3[OF \period w p\]] \p \ \<^bold>|w\<^bold>|\,symmetric] + unfolding pref_share_take[OF per_exp_pref[OF per_pref[OF \period w p\]] \p \ \<^bold>|w\<^bold>|\,symmetric] lassoc pow_Suc[symmetric] by fastforce qed auto lemma take_several_pers: assumes "period w n" and "m*n \ \<^bold>|w\<^bold>|" shows "(take n w)\<^sup>@m = take (m*n) w" -proof (cases "m = 0", simp) +proof (cases "m = 0") assume "m \ 0" have "\<^bold>|(take n w)\<^sup>@m\<^bold>| = m*n" unfolding pow_len nat_prod_le[OF \m \ 0\ \m*n \ \<^bold>|w\<^bold>|\, THEN take_len] by blast have "(take n w)\<^sup>@m \p w" - using \period w n\[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 \ w" w, OF triv_pref], OF \m * n \ \<^bold>|w\<^bold>|\[folded \\<^bold>|take n w\<^sup>@m\<^bold>| = m * n\]]. + using \period w n\[unfolded period_def] + ruler_le[of "take n w\<^sup>@m" "take n w\<^sup>@m \ w" w, OF triv_pref] \m * n \ \<^bold>|w\<^bold>|\[folded \\<^bold>|take n w\<^sup>@m\<^bold>| = m * n\] + per_exp_pref sprefD by metis show ?thesis using pref_take[OF \take n w\<^sup>@m \p w\, unfolded \\<^bold>|take n w\<^sup>@m\<^bold>| = m * n\, symmetric]. -qed +qed simp 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 \period w n\ div_times_less_eq_dividend] unfolding dvd_div_mult_self[OF \n dvd \<^bold>|w\<^bold>|\] take_self. -lemma per_mult: assumes "period w n" and "m \ 0" shows "period w (m*n)" +lemma per_mult: assumes "period w n" and "0 < m" shows "period w (m*n)" proof (cases "m*n \ \<^bold>|w\<^bold>|") - have "w \ \" using period_D1[OF \period w n\]. + have "w \ \" using per_nemp[OF \period w n\]. assume "\ m * n \ \<^bold>|w\<^bold>|" thus "period w (m*n)" using all_long_pers[of w "m * n", OF \w \ \\] by linarith next assume "m * n \ \<^bold>|w\<^bold>|" show "period w (m*n)" - using per_add_exp[of w "take n w", OF _ \m \ 0\] \period w n\ - unfolding period_def period_root_def take_several_pers[OF \period w n\ \m*n \ \<^bold>|w\<^bold>|\, symmetric] by blast -qed - -lemma root_period: assumes "w \ \" and "w \p r\<^sup>\" shows "period w \<^bold>|r\<^bold>|" - unfolding period_def period_root_def using per_pref_ex[OF \w \p r\<^sup>\\ - pref_pow_take[of w r], of "\ x. x"] take_nemp_len[OF \w \ \\ per_rootD'[OF \w \p r\<^sup>\\]] by blast + using \period w n\ + unfolding period_def + using per_root_add_exp[of w "take n w"] \0 < m\ + take_several_pers[OF \period w n\ \m*n \ \<^bold>|w\<^bold>|\, symmetric] + by presburger +qed + theorem two_periods: assumes "period w p" "period w q" "p + q \ \<^bold>|w\<^bold>|" shows "period w (gcd p q)" proof- obtain t where "take p w \ t*" "take q w \ t*" using two_pers_root[OF \period w p\[unfolded period_def] \period w q\[unfolded period_def], unfolded take_len[OF add_leD1[OF \p + q \ \<^bold>|w\<^bold>|\]] take_len[OF add_leD2[OF \p + q \ \<^bold>|w\<^bold>|\]], OF \p + q \ \<^bold>|w\<^bold>|\, unfolded comm_root[of "take p w" "take q w"]] by blast - hence "w \p t\<^sup>\" + hence "w

w" using \period w p\ period_def per_root_trans by blast have "period w \<^bold>|t\<^bold>|" - using root_period[OF per_nemp[OF \period w p\] \w \p t\<^sup>\\]. + using periodI[OF per_nemp[OF \period w p\] \w

w\]. have "\<^bold>|t\<^bold>| dvd (gcd p q)" using gcd_nat.boundedI[OF root_len_dvd[OF \take p w \ t*\] root_len_dvd[OF \take q w \ t*\]] unfolding take_len[OF add_leD1[OF \p + q \ \<^bold>|w\<^bold>|\]] take_len[OF add_leD2[OF \p + q \ \<^bold>|w\<^bold>|\]]. - thus ?thesis - using per_mult[OF \period w \<^bold>|t\<^bold>|\, of "gcd p q div \<^bold>|t\<^bold>|", unfolded dvd_div_mult_self[OF \\<^bold>|t\<^bold>| dvd (gcd p q)\]] - dvd_div_mult_self[OF \\<^bold>|t\<^bold>| dvd (gcd p q)\] - gcd_eq_0_iff[of p q] mult_zero_left[of "\<^bold>|t\<^bold>|"] period_D2[OF \period w p\] by argo -qed - -lemma index_mod_per_root: assumes "r \ \" and i: "\ i < \<^bold>|w\<^bold>|. w!i = r!(i mod \<^bold>|r\<^bold>|)" shows "w \p r\<^sup>\" + from dvd_div_eq_0_iff[OF this] + have "0 < gcd p q div \<^bold>|t\<^bold>|" + using per_not_zero[OF \period w p\] unfolding gcd_nat.eq_neutr_iff by blast + from per_mult[OF \period w \<^bold>|t\<^bold>|\ this] + show ?thesis + unfolding dvd_div_mult_self[OF \\<^bold>|t\<^bold>| dvd (gcd p q)\]. +qed + +lemma index_mod_per_root: assumes "r \ \" and i: "\ i < \<^bold>|w\<^bold>|. w!i = r!(i mod \<^bold>|r\<^bold>|)" shows "w

w" proof- have "i < \<^bold>|w\<^bold>| \ (r \ w) ! i = r ! (i mod \<^bold>|r\<^bold>|)" for i by (simp add: i mod_if nth_append) hence "w \p r \ w" using index_pref[of w "r \ w"] i by simp - thus ?thesis unfolding period_root_def using \r \ \\ by auto + thus ?thesis using \r \ \\ by auto qed lemma index_pref_pow_mod: "w \p r\<^sup>@k \ i < \<^bold>|w\<^bold>| \ 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 \p r\<^sup>\ \ i < \<^bold>|w\<^bold>| \ 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 index_per_root_mod: "w

w \ i < \<^bold>|w\<^bold>| \ w!i = r!(i mod \<^bold>|r\<^bold>|)" + using index_pref_pow_mod[of w r _ i] per_root_powE' by metis lemma root_divisor: assumes "period w k" and "k dvd \<^bold>|w\<^bold>|" shows "w \ (take k w)*" using rootI[of "take k w" "(\<^bold>|w\<^bold>| div k)"] unfolding take_several_pers[OF \period w k\, of "\<^bold>|w\<^bold>| div k", unfolded dvd_div_mult_self[OF \k dvd \<^bold>|w\<^bold>|\] take_self, OF , OF order_refl]. lemma per_pref': assumes "u \ \" and "period v k" and "u \p v" shows "period u k" proof- { assume "k \ \<^bold>|u\<^bold>|" have "take k v = take k u" using pref_share_take[OF \u \p v\ \k \ \<^bold>|u\<^bold>|\] by auto hence "take k v \ \" using \period v k\ by auto hence "take k u \ \" by (simp add: \take k v = take k u\) have "u \p take k u \ v" using \period v k\ - unfolding period_def period_root_def \take k v = take k u\ + unfolding period_def \take k v = take k u\ using pref_trans[OF \u \p v\, of "take k u \ v"] by blast hence "u \p take k u \ u" using \u \p v\ pref_prod_pref by blast hence ?thesis using \take k u \ \\ period_def by blast } thus ?thesis using \u \ \\ all_long_pers nat_le_linear by blast qed subsection "Period: overview" notepad begin fix w r::"'a list" fix n::nat - assume "w \ \" "r \ \" "n > 0" - have "\ w \p \\<^sup>\" + assume "w \ \" "r \ \" "0 < n" + have "\ w

\ w" by simp - have "\ \ \p \\<^sup>\" + have "\ \

\ \" by simp - have "\ \p r\<^sup>\" - by (simp add: \r \ \\) + have "\

\" + using \r \ \\ by blast have "\ period w 0" by simp have "\ period \ 0" by simp have "\ period \ n" by simp end subsection \Singleton and its power\ primrec letter_pref_exp :: "'a list \ 'a \ nat" where "letter_pref_exp \ a = 0" | "letter_pref_exp (b # xs) a = (if b \ a then 0 else Suc (letter_pref_exp xs a))" definition letter_suf_exp :: "'a list \ 'a \ 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 \\<^bold>|us\<^bold>| = 1\, symmetric]]. lemma sing_pow_hd_tl: "c # w \ [a]* \ c = a \ w \ [a]*" proof assume "c = a \ w \ [a]*" thus "c # w \ [a]*" unfolding hd_word[of _ w] using add_root[of "[c]" w] by simp next assume "c # w \ [a]*" then obtain k where "[a]\<^sup>@k = c # w" unfolding root_def by blast thus "c = a \ w \ [a]*" - proof (cases "k = 0", simp) - assume "[a] \<^sup>@ k = c # w" and "k \ 0" - from eqd_eq[of "[a]", OF this(1)[unfolded hd_word[of _ w] pop_pow_one[OF \k \ 0\]]] + proof (cases "0 < k") + assume "[a] \<^sup>@ k = c # w" and "0 < k" + from eqd_eq[of "[a]", OF this(1)[unfolded hd_word[of _ w] pow_pos[OF \0 < k\]]] show ?thesis unfolding root_def by auto - qed + qed simp qed lemma pref_sing_pow: assumes "w \p [a]\<^sup>@m" shows "w = [a]\<^sup>@(\<^bold>|w\<^bold>|)" proof- have "[a]\<^sup>@m = [a]\<^sup>@(\<^bold>|w\<^bold>|)\[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_eq[of w "w\\<^sup>>[a]\<^sup>@m" "[a]\<^sup>@(\<^bold>|w\<^bold>|)""[a]\<^sup>@(m-\<^bold>|w\<^bold>|)", + using eqd_eq(1)[of w "w\\<^sup>>[a]\<^sup>@m" "[a]\<^sup>@(\<^bold>|w\<^bold>|)""[a]\<^sup>@(m-\<^bold>|w\<^bold>|)", unfolded lq_pref[OF assms] sing_pow_len, - OF \[a]\<^sup>@m = [a]\<^sup>@(\<^bold>|w\<^bold>|)\[a]\<^sup>@(m-\<^bold>|w\<^bold>|)\ refl]]. + OF \[a]\<^sup>@m = [a]\<^sup>@(\<^bold>|w\<^bold>|)\[a]\<^sup>@(m-\<^bold>|w\<^bold>|)\ 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_pow[of w a k, unfolded assms[unfolded root_def, symmetric], OF self_pref, symmetric]. lemma suf_sing_power: assumes "w \s [a]\<^sup>@m" shows "w \ [a]*" using sing_pow_palindrom[of "rev w" a "\<^bold>|rev w\<^bold>|", unfolded rev_rev_ident] pref_sing_pow[of "rev w" a m, OF \w \s [a]\<^sup>@m\[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 \ [a]*" and "v \f w" shows "v \ [a]*" proof- obtain k where "w = [a]\<^sup>@k" using \w \ [a]*\[unfolded root_def] by blast obtain p where "p \p w" and "v \s p" using fac_pref_suf[OF \ v \f w\] by blast hence "v \s [a]\<^sup>@ \<^bold>|p\<^bold>|" using pref_sing_pow[OF \p \p w\[unfolded \w = [a]\<^sup>@k\]] by argo from suf_sing_power[OF this] show ?thesis. qed lemma sing_pow_fac': assumes "a \ b" and "w \ [a]*" shows "\ ([b] \f w)" using sing_fac_pow[OF \ w \ [a]*\, of "[b]"] unfolding sing_pow_hd_tl[of b \] using \a \ b\ by auto lemma all_set_sing_pow: "(\ b. b \ set w \ b = a) \ w \ [a]*" (is "?All \ _") proof assume ?All then show "w \ [a]*" - proof (induct w, simp) + proof (induct w) case (Cons c w) then show ?case by (simp add: sing_pow_hd_tl) - qed + qed simp next assume "w \ [a]*" then show ?All - proof (induct w, simp) + proof (induct w) case (Cons c w) then show ?case unfolding sing_pow_hd_tl by simp - qed + qed simp qed lemma sing_fac_set: "[a] \f x \ a \ set x" by fastforce -lemma set_sing_pow_hd: assumes "k \ 0" shows "a \ set ([a]\<^sup>@k \ u)" - unfolding set_append -proof- - have "set ([a] \<^sup>@ k) = set ([a] \ [a]\<^sup>@(k-1))" - unfolding Suc_minus[OF \k \ 0\] pow_Suc[symmetric].. - thus "a \ set ([a] \<^sup>@ k) \ set u" by force -qed +lemma set_sing_pow_hd [simp]: assumes "0 < k" shows "a \ set ([a]\<^sup>@k)" + using assms gr0_conv_Suc by force lemma neq_set_not_root: "a \ b \ b \ set x \ x \ [a]*" - using all_set_sing_pow by metis - -lemma sing_pow_set_Suc[simp]: "set ([a]\<^sup>@Suc k) = {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[simp]: assumes "0 < k" shows "set ([a]\<^sup>@k) = {a}" + using sing_pow_set_Suc[of _ "k-1", unfolded Suc_minus_pos[OF assms]]. + lemma sing_pow_set_sub: "set ([a]\<^sup>@k) \ {a}" - by (induct k, simp_all) + by (induct k, simp_all) lemma unique_letter_fac_expE: assumes "w \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 \ 0" shows "set ([a]\<^sup>@k) = {a}" - using sing_pow_set_Suc[of a "k - 1", unfolded Suc_minus[OF \k \ 0\]]. lemma neq_in_set_not_pow: "a \ b \ b \ set x \ x \ [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" + by (cases "0 < k", use sing_pow_set singleton_iff in metis) force + +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" + 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 \ 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 \k \ 0\], OF \c = [a]\<^sup>@k\]. + using sing_pow_card_set_Suc[of c a "k - 1", unfolded Suc_minus[OF \k \ 0\], OF \c = [a]\<^sup>@k\]. lemma sing_pow_set': "u \ [a]* \ u \ \ \ set u = {a}" unfolding all_set_sing_pow[symmetric] 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 \ [a]* \ set u \ {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) + 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 \ \ \ hd u = a \ letter_pref_exp u a \ 0" by (induct u, auto) -(* lemma hd_pref_exp_pos: "u \ \ \ hd u = a \ letter_pref_exp u a \ 0" *) -(* by (induct u, auto) *) lemma letter_pref_exp_pref: "[a]\<^sup>@(letter_pref_exp w a) \p w " by(induct w, simp, simp) lemma letter_pref_exp_Suc: "\ [a]\<^sup>@(Suc (letter_pref_exp w a)) \p w " by (induct w, simp_all add: prefix_def) lemma takeWhile_letter_pref_exp: "takeWhile (\x. x = a) w =[a]\<^sup>@(letter_pref_exp w a)" by (induct w, simp, simp) lemma concat_takeWhile_sing: "concat (takeWhile (\ x. x = u) ws) = u\<^sup>@\<^bold>|takeWhile (\ x. x = u) ws\<^bold>|" unfolding takeWhile_letter_pref_exp concat_sing_pow sing_pow_len .. -lemma dropWhile_distinct: assumes "w \ [a]\<^sup>@(letter_pref_exp w a)" +lemma dropWhile_distinct: assumes "w \ [a]\<^sup>@(letter_pref_exp w a)" shows "[a]\<^sup>@(letter_pref_exp w a)\[hd (dropWhile (\x. x = a) w)] \p w" proof- have nemp: "dropWhile (\x. x = a) w \ \" using takeWhile_dropWhile_id[of "\x. x = a" w, unfolded takeWhile_letter_pref_exp] \w \ [a]\<^sup>@(letter_pref_exp w a)\ by force - from takeWhile_dropWhile_id[of "\x. x = a" w, unfolded takeWhile_letter_pref_exp] + from takeWhile_dropWhile_id[of "\x. x = a" w, unfolded takeWhile_letter_pref_exp] have "[a]\<^sup>@(letter_pref_exp w a)\[hd (dropWhile (\x. x = a) w)]\ tl (dropWhile (\x. x = a) w) = w" unfolding hd_tl[OF nemp]. thus ?thesis unfolding lassoc using triv_pref by blast qed +lemma letter_pref_exp_mismatch: "u = [a]\<^sup>@letter_pref_exp u a \ v \ v \ \ \ hd v \ a" + using hd_pref letter_pref_exp_Suc[unfolded pow_Suc'] same_prefix_prefix by metis + lemma takeWhile_sing_root: "takeWhile (\ x. x = a) w \ [a]*" unfolding all_set_sing_pow[symmetric] using set_takeWhileD[of _ "\ x. x = a" w] by blast lemma takeWhile_sing_pow: "takeWhile (\ x. x = a) w = w \ w = [a]\<^sup>@\<^bold>|w\<^bold>|" by(induct w, auto) lemma dropWhile_sing_pow: "dropWhile (\ x. x = a) w = \ \ w = [a]\<^sup>@\<^bold>|w\<^bold>|" by(induct w, auto) +lemma nemp_takeWhile_hd: "us \ \ \ hd (takeWhile (\ a. a = hd us) us) = hd us" + by (simp add: pref_hd_eq takeWhile_eq_Nil_iff takeWhile_is_prefix) + +lemma nemp_takeWhile_last: "us \ \ \ last (takeWhile (\ a. a = hd us) us) = hd us" +proof (induct us) + case (Cons a us) + then show ?case + by (simp add: takeWhile_eq_Nil_iff) blast +qed simp + +lemma card_set_decompose: assumes "1 < card (set us)" + shows "takeWhile (\ a. a = hd us) us \ \" and "dropWhile (\ a. a = hd us) us \ \" and + "set (takeWhile (\ a. a = hd us) us) = {hd us}" and + "last (takeWhile (\ a. a = hd us) us) \ hd(dropWhile (\ a. a = hd us) us)" +proof- + have "us \ \" + using assms by force + thus "takeWhile (\a. a = hd us) us \ \" + by (simp add: takeWhile_eq_Nil_iff) + from sing_pow_set'[OF takeWhile_sing_root this] + show set: "set (takeWhile (\ a. a = hd us) us) = {hd us}". + show "dropWhile (\a. a = hd us) us \ \" + proof (rule notI) + assume "dropWhile (\a. a = hd us) us = \" + from set[unfolded takeWhile_dropWhile_id[of "(\a. a = hd us)" us, unfolded this emp_simps]] + show False + using assms by force + qed + from hd_dropWhile[OF this] + show "last (takeWhile (\ a. a = hd us) us) \ hd(dropWhile (\ a. a = hd us) us)" + unfolding nemp_takeWhile_last[OF \us \ \\] by simp +qed + lemma distinct_letter_in: assumes "w \ [a]*" obtains m b q where "[a]\<^sup>@m \ [b] \ q = w" and "b \ a" proof- have "dropWhile (\ x. x = a) w \ \" unfolding dropWhile_sing_pow using assms rootI[of "[a]" "\<^bold>|w\<^bold>|"] by auto hence eq: "takeWhile (\ x. x = a) w \ [hd (dropWhile (\ x. x = a) w)] \ tl (dropWhile (\ x. x = a) w) = w" by simp have root:"takeWhile (\ x. x = a) w \ [a]*" by (simp add: takeWhile_sing_root) have "hd (dropWhile (\ x. x = a) w) \ a" using hd_dropWhile[OF \dropWhile (\x. x = a) w \ \\]. from that[OF _ this] show thesis using eq root unfolding root_def by metis qed lemma distinct_letter_in_hd: assumes "w \ [hd w]*" obtains m b q where "[hd w]\<^sup>@m \ [b] \ q = w" and "b \ hd w" and "m \ 0" proof- obtain m b q where a1: "[hd w]\<^sup>@m \ [b] \ q = w" and a2: "b \ hd w" using distinct_letter_in[OF assms]. have "m \ 0" proof (rule notI) assume "m = 0" - note a1[unfolded this pow_zero clean_emp, folded hd_word] + note a1[unfolded this pow_zero emp_simps, 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 \ [hd w]*" obtains m b q where "[hd w]\<^sup>@Suc m \ [b] \ q = w" and "b \ hd w" using distinct_letter_in_hd[OF assms] Suc_minus by metis lemma distinct_letter_in_suf: assumes "w \ [a]*" obtains m b where "[b] \ [a]\<^sup>@m \s w" and "b \ a" using distinct_letter_in[reversed, unfolded rassoc, OF assms] - unfolding suf_def by metis + unfolding suffix_def by metis lemma sing_pow_exp: assumes "w \ [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 \ [a]*" and "i < \<^bold>|w\<^bold>|" shows "w ! i = a" using sing_pow_nth[OF \i < \<^bold>|w\<^bold>|\, of a, folded sing_pow_exp[OF \w \ [a]*\]]. lemma rev_sing_power: "x \ [a]* \ rev x = x" unfolding root_def using rev_pow rev_singleton_conv by metis lemma lcp_letter_power: assumes "w \ \" and "w \ [a]*" and "[a]\<^sup>@m \ [b] \p z" and "a \ b" shows "w \ z \\<^sub>p z \ w = [a]\<^sup>@m" proof- obtain k z' where "w = [a]\<^sup>@k" "z = [a]\<^sup>@m \ [b] \ z'" "k \ 0" using \w \ [a]*\ \[a]\<^sup>@m \ [b] \p z\ \w \ \\ nemp_pow[of "[a]"] unfolding root_def by (auto simp add: prefix_def) hence eq1: "w \ z = [a]\<^sup>@m \ ([a]\<^sup>@k \ [b] \ z')" and eq2: "z \ w = [a]\<^sup>@m \ ([b] \ z'\ [a]\<^sup>@k)" by (simp add: \w = [a]\<^sup>@k\ \z = [a]\<^sup>@m \ [b] \ z'\ pows_comm)+ have "hd ([a]\<^sup>@k \ [b] \ z') = a" using hd_append2[OF \w \ \\, of "[b]\z'", unfolded \w = (a # \)\<^sup>@k\ hd_sing_pow[OF \k \ 0\, of a]]. moreover have "hd([b] \ z'\ [a]\<^sup>@k) = b" by simp ultimately have "[a]\<^sup>@k \ [b] \ z' \\<^sub>p [b] \ z'\ [a]\<^sup>@k = \" by (simp add: \a \ b\ lcp_distinct_hd) thus ?thesis using eq1 eq2 lcp_ext_left[of "[a]\<^sup>@m" "[a]\<^sup>@k \ [b] \ z'" "[b] \ z'\ [a]\<^sup>@k"] by simp qed -lemma per_one: assumes "w \p [a]\<^sup>\" shows "w \ [a]*" +lemma per_one: assumes "w

w" shows "w \ [a]*" proof- - have "w \p (a # \) \<^sup>@ n \ n \ 0 \ w \ [a]*" for n - using pref_sing_pow[of w a] rootI[of "[a]" "\<^bold>|w\<^bold>|"] by auto - with per_pref_ex[OF \w \p [a]\<^sup>\\] - show ?thesis by auto -qed - -lemma per_one': "w \ [a]* \ w \p [a]\<^sup>\" - by (metis append_Nil2 not_Cons_self2 per_pref prefI root_def) - -lemma per_sing_one: assumes "w \ \" "w \p [a]\<^sup>\" shows "period w 1" - using root_period[OF \w \ \\ \w \p [a]\<^sup>\\] unfolding sing_len[of a]. + have "w

) \<^sup>@ n \ 0 < n \ w \ [a]*" for n + using pref_sing_pow[of w a] sprefD1 rootI[of "[a]" "\<^bold>|w\<^bold>|"] by metis + with rootI per_root_powE[OF assms] + show ?thesis + by blast +qed + +lemma per_one': "w \ [a]* \ w

w" + using comm_root self_root triv_spref[OF not_Cons_self2] by blast + +lemma per_sing_one: assumes "w \ \" "w

w" shows "period w 1" + using periodI[OF \w \ \\ \w

w\] unfolding sing_len[of a]. section "Border" text\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.\ definition border :: "'a list \ 'a list \ bool" ("_ \b _" [51,51] 60 ) where [simp]: "border x w = (x \p w \ x \s w \ x \ w \ x \ \)" definition bordered :: "'a list \ bool" where [simp]: "bordered w = (\b. b \b w)" lemma borderI[intro]: "x \p w \ x \s w \ x \ w \ x \ \ \ x \b w" unfolding border_def by blast lemma borderD_pref: "x \b w \ x \p w" unfolding border_def by blast lemma borderD_spref: "x \b w \ x

b w \ x \s w" unfolding border_def by blast lemma borderD_ssuf: "x \b w \ x b w \ x \ \" using border_def by blast lemma borderD_neq: "x \b w \ x \ w" unfolding border_def by blast lemma borderedI: "u \b w \ bordered w" unfolding bordered_def by fast lemma border_lq_nemp: assumes "x \b w" shows "x\\<^sup>>w \ \" using assms borderD_spref lq_spref by blast lemma border_rq_nemp: assumes "x \b w" shows "w\<^sup><\x \ \" using assms borderD_ssuf rq_ssuf by blast lemma border_trans[trans]: assumes "t \b x" "x \b w" shows "t \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 \b rev w \ x \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 \b w \ (w\<^sup><\x) \ x" - unfolding border_def using rq_suf_suf ruler' by metis + 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 \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 \\<^bold>|x\<^bold>| < \<^bold>|w\<^bold>|\ unfolding border_def by linarith qed lemma borders_compare: assumes "x \b w" and "x' \b w" and "\<^bold>|x'\<^bold>| < \<^bold>|x\<^bold>|" shows "x' \b x" using ruler_le[OF borderD_pref[OF \x' \b w\] borderD_pref[OF \x \b w\] less_imp_le_nat[OF \\<^bold>|x'\<^bold>| < \<^bold>|x\<^bold>|\]] suf_ruler_le[OF borderD_suf[OF \x' \b w\] borderD_suf[OF \x \b w\] less_imp_le_nat[OF \\<^bold>|x'\<^bold>| < \<^bold>|x\<^bold>|\]] borderD_nemp[OF \x' \b w\] \\<^bold>|x'\<^bold>| < \<^bold>|x\<^bold>|\ borderI by blast lemma unbordered_border: "bordered w \ \ x. x \b w \ \ bordered x" proof (induction "\<^bold>|w\<^bold>|" arbitrary: w rule: less_induct) case less obtain x' where "x' \b w" using bordered_def less.prems by blast show ?case proof (cases "bordered x'") assume "\ bordered x'" thus ?case using \x' \b w\ by blast next assume "bordered x'" from less.hyps[OF border_len(3)[OF \x' \b w\] this] show ?case using border_trans[of _ x' w] \x' \b w\ by blast qed qed lemma unbordered_border_shortest: "x \b w \ \ bordered x \ y \b w \ \<^bold>|x\<^bold>| \ \<^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 \b w" shows "(w\<^sup><\x)\\<^sup>>x \b x" proof- define p s where "p = w\<^sup><\x" and "s = x\\<^sup>>w" hence eq: "p\x = x\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 + using lenarg[OF p_def] long unfolding rq_len by linarith have px: "p \ p\\<^sup>>x = x" and sx: "p\\<^sup>>x \ s = x" using eqd_pref[OF eq less_imp_le, OF \\<^bold>|p\<^bold>| < \<^bold>|x\<^bold>|\] by blast+ have "p\\<^sup>>x \ \" using \\<^bold>|p\<^bold>| < \<^bold>|x\<^bold>|\ px by fastforce have "p \ \" using border_rq_nemp[OF border] p_def by presburger have "p\\<^sup>>x \ x" using \p \ \\ px by force have "(p\\<^sup>>x) \b x" unfolding border_def using eqd_pref[OF eq less_imp_le, OF \\<^bold>|p\<^bold>| < \<^bold>|x\<^bold>|\] \p\\<^sup>>x \ \\ \p\\<^sup>>x \ x\ by blast thus ?thesis unfolding p_def. qed thm long_border_bordered[reversed] lemma border_short_dec: assumes border: "x \b w" and short: "\<^bold>|x\<^bold>| + \<^bold>|x\<^bold>| \ \<^bold>|w\<^bold>|" shows "x \ x\\<^sup>>(w\<^sup><\x) \ x = w" proof- have eq: "x\x\\<^sup>>w = w\<^sup><\x\x" using lq_pref[OF borderD_pref[OF border]] rq_suf[OF borderD_suf[OF border]] by simp have "\<^bold>|x\<^bold>| \ \<^bold>|w\<^sup><\x\<^bold>|" - using short[folded rq_len[OF borderD_suf[OF border]]] by simp + using short unfolding rq_len by linarith 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\v\u = w" and "u \ \" proof- obtain u where "u \b w" and "\ bordered u" using unbordered_border[OF assms] by blast have "\<^bold>|u\<^bold>| + \<^bold>|u\<^bold>| \ \<^bold>|w\<^bold>|" using long_border_bordered[OF _ \u \b w\] \\ bordered u\ bordered_def leI by blast from border_short_dec[OF \u \b w\ this, THEN that, OF borderD_nemp[OF \u \b w\]] show thesis. qed lemma emp_not_bordered: "\ bordered \" by simp lemma bordered_nemp: "bordered w \ w \ \" using emp_not_bordered by blast lemma sing_not_bordered: "\ bordered [a]" using bordered_dec[of "[a]" False] append_eq_Cons_conv[of _ _ a \] suf_nemp by fast subsection "Relation to period and conjugation" lemma border_conjug_eq: "x \b w \ (w\<^sup><\x) \ w = w \ (x\\<^sup>>w)" using lq_rq_reassoc_suf[OF borderD_pref borderD_suf, symmetric] by blast lemma border_per_root: "x \b w \ w \p (w\<^sup><\x) \ w" using border_conjug_eq by blast lemma per_root_border: assumes "\<^bold>|r\<^bold>| < \<^bold>|w\<^bold>|" and "r \ \" and "w \p r \ w" shows "r\\<^sup>>w \b w" proof have "\<^bold>|r\<^bold>| \ \<^bold>|w\<^bold>|" and "r \p w" using less_imp_le[OF \\<^bold>|r\<^bold>| < \<^bold>|w\<^bold>|\] pref_prod_long[OF \w \p r \ w\] by blast+ show "r\\<^sup>>w \p w" - using pref_lq[OF \r \p w\ \w \p r \ w\] unfolding lq_triv. + using pref_lq[OF \w \p r \ w\, of r] unfolding lq_triv. show "r\\<^sup>>w \s w" using \r \p w\ by (auto simp add: prefix_def) show "r\\<^sup>>w \ w" - using \r \p w\ \r \ \\ unfolding prefix_def by fastforce + using \r \p w\ \r \ \\ unfolding prefix_def by fastforce show "r\\<^sup>>w \ \" using lq_pref[OF \r \p w\] \\<^bold>|r\<^bold>| < \<^bold>|w\<^bold>|\ by force qed lemma pref_suf_neq_per: assumes "x \p w" and "x \s w" and "x \ w" shows "period w (\<^bold>|w\<^bold>|-\<^bold>|x\<^bold>|)" proof- have "(w\<^sup><\x)\x = w" using rq_suf[OF \x \s w\]. have "x\(x\\<^sup>>w) = w" using lq_pref[OF \x \p w\]. have take: "w\<^sup><\x = take (\<^bold>|w\<^bold>|-\<^bold>|x\<^bold>|) w" - using rq_take[OF \x \s w\]. + using rq_take. have nemp: "take (\<^bold>|w\<^bold>|-\<^bold>|x\<^bold>|) w \ \" using \x \p w\ \x \ w\ unfolding prefix_def by auto have "w \p take (\<^bold>|w\<^bold>|-\<^bold>|x\<^bold>|) w \ w" - using triv_pref[of w "x\\<^sup>>w"] - unfolding lassoc[of "w\<^sup><\x" x "x\\<^sup>>w", unfolded \x \ x\\<^sup>>w = w\ \w\<^sup><\x \ x = w\, symmetric] take. + using triv_pref[of w "x\\<^sup>>w"] + unfolding lassoc[of "w\<^sup><\x" x "x\\<^sup>>w", unfolded \x \ x\\<^sup>>w = w\ \w\<^sup><\x \ x = w\, symmetric] take. thus "period w (\<^bold>|w\<^bold>|-\<^bold>|x\<^bold>|)" - unfolding period_def period_root_def using nemp by blast + unfolding period_def using nemp by blast qed lemma border_per: "x \b w \ 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 \b w" proof- have eq: "take (\<^bold>|w\<^bold>| - n) w = drop n w" - using pref_take[OF \period w n\[unfolded per_shift[OF period_D1[OF \period w n\] per_positive[OF \period w n\]]], unfolded length_drop]. + using pref_take[OF \period w n\[unfolded + per_shift[OF per_nemp[OF \period w n\] per_not_zero[OF \period w n\]]], unfolded length_drop]. have "take (\<^bold>|w\<^bold>| - n) w \ \" using \n < \<^bold>|w\<^bold>|\ take_eq_Nil by fastforce moreover have "take (\<^bold>|w\<^bold>| - n) w \ w" - using period_D2[OF \period w n\] \n < \<^bold>|w\<^bold>|\ unfolding take_all_iff[of "\<^bold>|w\<^bold>|-n" w] by fastforce + using per_not_zero[OF \period w n\] \n < \<^bold>|w\<^bold>|\ 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 \The longest border and the shortest period\ subsection \The longest border\ definition max_borderP :: "'a list \ 'a list \ bool" where "max_borderP u w = (u \p w \ u \s w \ (u = w \ w = \) \ (\ v. v \b w \ v \p u))" -lemma max_borderP_emp_emp: "max_borderP \ \" - unfolding max_borderP_def by simp +lemma max_borderP_emp_emp: "max_borderP \ \" + unfolding max_borderP_def by simp lemma max_borderP_exE: obtains u where "max_borderP u w" proof- define P where "P = (\ x. x \p w \ x \s w \ (x = w \ w = \))" - have "P \" + have "P \" unfolding P_def by blast obtain v where "v \p w" and "P v" and "(\y. y \p w \ P y \ y \p v)" using max_pref[of \ w P thesis, OF prefix_bot.extremum \P \\] 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 \ \ u = \" by (metis max_borderP_def suffix_bot.extremum_unique) lemma max_borderP_D_neq: "w \ \ \ max_borderP u w \ u \ w" by (simp add: max_borderP_def) lemma max_borderP_D_pref: "max_borderP u w \ u \p w" by (simp add: max_borderP_def) lemma max_borderP_D_suf: "max_borderP u w \ u \s w" by (simp add: max_borderP_def) lemma max_borderP_D_max: "max_borderP u w \ v \b w \ v \p u" by (simp add: max_borderP_def) lemma max_borderP_D_max': "max_borderP u w \ v \b w \ v \s u" unfolding max_borderP_def using borderD_suf suf_pref_eq suffix_same_cases by metis lemma unbordered_max_border_emp: "\ bordered w \ max_borderP u w \ u = \" unfolding max_borderP_def bordered_def border_def by blast lemma bordered_max_border_nemp: "bordered w \ max_borderP u w \ u \ \" unfolding max_borderP_def bordered_def border_def using prefix_Nil by blast lemma max_borderP_border: "max_borderP u w \ u \ \ \ u \b w" unfolding max_borderP_def border_def by blast lemma max_borderP_rev: "max_borderP (rev u) (rev w) \ 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 \ w = \" and "u \p w" and "u \s w" and allv: "v \b rev w \ v \p rev u" for v by blast+ show "max_borderP u w" proof (unfold max_borderP_def, intro conjI, simp_all only: \u \p w\ \u \s w\) show "u = w \ w = \" by fact show "\v. v \b w \ v \p u" - proof (rule allI, rule impI) + proof (rule allI, rule impI) fix v assume "v \b w" show "v \p u" using \max_borderP (rev u) (rev w)\ \v \b w\ 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) \ max_borderP u w" using max_borderP_rev max_borderP_rev[of "rev u" "rev w", unfolded rev_rev_ident] by blast +(* TODO zkusit use argmax? + SH: nasledujici jednoduche dukazy ukazuji, ze se tim asi nic neziska *) +term arg_max definition max_border :: "'a list \ 'a list" where "max_border w = (THE u. (max_borderP u w))" +lemma max_border_unique: assumes "max_borderP u w" "max_borderP v w" + shows "u = v" + using max_borderP_D_max[OF \max_borderP u w\, OF max_borderP_border[OF \max_borderP v w\]] + max_borderP_D_max[OF \max_borderP v w\, OF max_borderP_border[OF \max_borderP u w\]] + by force + 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 "\ x. max_borderP x w", OF \max_borderP u w\]) - fix v assume "max_borderP v w" - show "v = u" - proof (cases "bordered w") - assume "bordered w" - hence "u \ \" and "v \ \" - using \max_borderP u w\ \max_borderP v w\ bordered_max_border_nemp by blast+ - then show ?thesis - using \max_borderP u w\ \max_borderP v w\ unfolding max_borderP_def border_def - using prefix_order.eq_iff by blast - next - assume "\ bordered w" - then show "v = u" - using \max_borderP u w\ \max_borderP v w\ 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 \max_borderP u w\] bordered_max_border_nemp[OF this max_border_ex] - have "u \ \" and "max_border w \ \" by blast+ - from max_borderP_border[OF \max_borderP u w\ \u \ \\] max_borderP_border[OF max_border_ex \max_border w \ \\] - have "u \b w" and "max_border w \b w" by blast+ - from max_borderP_D_max[OF \max_borderP u w\ \max_border w \b w\] max_borderP_D_max[OF max_border_ex \u \b w\] - have "max_border w \p u" and "u \p max_border w" by blast+ - thus "max_border w = u" - by force -next - assume "\ bordered w" - from unbordered_max_border_emp[OF this \max_borderP u w\] unbordered_max_border_emp[OF this max_border_ex] - show "max_border w = u" - by simp -qed +proof (rule max_borderP_exE[of w]) + fix u assume "max_borderP u w" + with max_border_unique[OF this] + show ?thesis + unfolding max_border_def + by (elim theI[of "\ x. max_borderP x w"]) simp +qed + +lemma max_borderP_max_border: "max_borderP u w \ max_border w = u" + using max_border_unique[OF max_border_ex]. lemma max_border_len_rev: "\<^bold>|max_border u\<^bold>| = \<^bold>|max_border (rev u)\<^bold>|" by (cases "u = \", 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 \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 \ \ \ max_border w \b w" - using max_borderP_border max_border_ex by blast + using max_borderP_border max_border_ex by blast lemma max_border_sing_emp: "max_border [a] = \" using max_border_ex[THEN unbordered_max_border_emp[OF sing_not_bordered]] by fast lemma max_border_suf: "max_border w \s w" using max_borderP_D_suf max_border_ex by auto lemma max_border_nemp_neq: "w \ \ \ max_border w \ w" - by (simp add: max_borderP_D_neq max_border_ex) + by (simp add: max_borderP_D_neq max_border_ex) lemma max_borderI: assumes "u \ w" and "u \p w" and "u \s w" and "\ v. v \b w \ v \p u" shows "max_border w = u" - using assms max_border_ex + 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 \ \" 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 \b w" shows "u \p max_border w" - using max_borderP_D_max[OF max_border_ex \u \b w\]. + using max_borderP_D_max[OF max_border_ex \u \b w\]. theorem max_border_max_suf: assumes "u \b w" shows "u \s max_border w" - using max_borderP_D_max'[OF max_border_ex \u \b w\]. + using max_borderP_D_max'[OF max_border_ex \u \b w\]. lemma bordered_max_bord_nemp_conv[code]: "bordered w \ max_border w \ \" 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 +next assume "\ bordered w" hence "max_border w = \" using bordered_max_bord_nemp_conv by blast thus "max_border w = take \<^bold>|max_border w\<^bold>| w" by simp qed subsection \The shortest period\ -fun min_period_root :: "'a list \ 'a list" ("\") where +(* TODO define min_period first, then use it here + SH: prazdne slovo bude mit nedefinovanou periodu +*) +definition min_period_root :: "'a list \ 'a list" ("\") where "min_period_root w = take (LEAST n. period w n) w" definition min_period :: "'a list \ nat" where "min_period w = \<^bold>|\ w\<^bold>|" lemma min_per_emp[simp]: "\ \ = \" - by simp + unfolding min_period_root_def by simp lemma min_per_zero[simp]: "min_period \ = 0" by (simp add: min_period_def) - lemma min_per_per: "w \ \ \ 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 + unfolding min_period_def min_period_root_def + using len_is_per LeastI_ex period_def periodI by metis lemma min_per_pos: "w \ \ \ 0 < min_period w" using min_per_per by auto lemma min_per_len: "min_period w \ \<^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] + unfolding min_period_def min_period_root_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 \ \" shows "w \p (\ w)\<^sup>\" - using LeastI_ex assms len_is_per min_period_root.elims period_def by metis +lemma min_per_root_per_root: assumes "w \ \" shows "w

w) \ w" + using LeastI_ex assms len_is_per period_def unfolding min_period_root_def by metis lemma min_per_pref: "\ w \p w" - unfolding min_period_root.simps using take_is_prefix by blast + unfolding min_period_root_def using take_is_prefix by blast lemma min_per_nemp: "w \ \ \ \ w \ \" - using min_per_root_per_root per_eq by blast - -lemma min_per_min: assumes "w \p r\<^sup>\" shows "\ w \p r" -proof (cases "w = \", simp) + using min_per_root_per_root by blast + +lemma min_per_min: assumes "w

w" shows "\ w \p r" +proof (cases "w = \") assume "w \ \" have "period w \<^bold>|\ w\<^bold>|" - using \w \ \\ min_per_root_per_root root_period by blast + using \w \ \\ min_per_root_per_root periodI by blast have "period w \<^bold>|r\<^bold>|" - using \w \ \\ assms root_period by blast + using \w \ \\ assms periodI by blast from Least_le[of "\ n. period w n", OF this] have "\<^bold>|\ w\<^bold>| \ \<^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 \w \p r\<^sup>\\]] - show "\ w \p r" + unfolding min_period_root_def using dual_order.trans len_take1 by metis + with pref_trans[OF min_per_pref sprefD1[OF \w

w\]] + show "\ w \p r" using pref_prod_le by blast -qed +qed simp lemma lq_min_per_pref: "\ w\\<^sup>>w \p w" - unfolding same_prefix_prefix[of "\ w" _ w, symmetric] lq_pref[OF min_per_pref] using per_rootD[OF min_per_root_per_root] + unfolding same_prefix_prefix[of "\ w" _ w, symmetric] lq_pref[OF min_per_pref] using sprefD1[OF min_per_root_per_root] by (cases "w = \", simp) lemma max_bord_emp: "max_border \ = \" by (simp add: max_borderP_of_nemp max_border_ex) theorem min_per_max_border: "\ w \ max_border w = w" -proof (cases "w = \", simp add: max_bord_emp) +proof (cases "w = \") assume "w \ \" - have "max_border w = (\ w)\\<^sup>>w" + have "max_border w = (\ w)\\<^sup>>w" proof (intro max_borderI) - show "\ w\\<^sup>>w \ w" - using min_per_nemp[OF \w \ \\] lq_pref[OF min_per_pref] append_self_conv2 by metis + show "\ w\\<^sup>>w \ w" + using min_per_nemp[OF \w \ \\] lq_pref[OF min_per_pref] append_self_conv2 by metis show "\ w\\<^sup>>w \s w" using lq_suf_suf[OF min_per_pref]. show "\ w\\<^sup>>w \p w" - using lq_min_per_pref by blast + using lq_min_per_pref by blast show "\v. v \b w \ v \p \ w\\<^sup>>w" - proof (rule allI, rule impI) + proof (rule allI, rule impI) fix v assume "v \b w" - have "w \p (w\<^sup><\v)\<^sup>\" - using per_border \v \b w\ border_per_root[OF \v \b w\] border_rq_nemp[OF \v \b w\] period_root_def by blast + have "w

<\v) \ w" + using per_border \v \b w\ border_per_root[OF \v \b w\] border_rq_nemp[OF \v \b w\] by blast from min_per_min[OF this] - have "\ w \p w\<^sup><\v". + have "\ w \p w\<^sup><\v". from pref_rq_suf_lq[OF borderD_suf[OF \v \b w\] this] have "v \s \ w\\<^sup>>w". from suf_pref_eq[OF this] ruler[OF borderD_pref[OF \v \b w\] \\ w\\<^sup>>w \p w\] - show "v \p \ w\\<^sup>>w" + show "v \p \ w\\<^sup>>w" by blast qed qed thus ?thesis - using lq_pref[OF min_per_pref, of w] by simp -qed + using lq_pref[OF min_per_pref, of w] by simp +qed (simp add: max_bord_emp) 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 + unfolding min_period_def using lenarg[OF min_per_max_border,unfolded lenmorph,of w] by linarith lemma min_per_root_take [code]: "\ 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 \Primitive words\ text\If a word $w$ is not a non-trivial power of some other word, we say it is primitive.\ definition primitive :: "'a list \ bool" where "primitive u = (\ r k. r\<^sup>@k = u \ k = 1)" +lemma emp_not_prim[simp]: "\ primitive \" + unfolding primitive_def + by (metis pow_eq_if_list zero_neq_one) + lemma primI[intro]: "(\ r k. r\<^sup>@k = u \ k = 1) \ primitive u" by (simp add: primitive_def) lemma prim_nemp: "primitive u \ u \ \" -proof- - have "u = \ \ \\<^sup>@0 = u" by simp - thus "primitive u \ u \ \" - using primitive_def zero_neq_one by blast -qed - -lemma emp_not_prim[simp]: "\ primitive \" - using prim_nemp by blast + by force lemma prim_exp_one: "primitive u \ r\<^sup>@k = u \ k = 1" using primitive_def by blast lemma pow_nemp_imprim[intro]: "2 \ k \ \ primitive (u\<^sup>@k)" using prim_exp_one by fastforce -lemma pow_not_prim: "\ primitive (u\<^sup>@Suc(Suc k))" +lemma pow_not_prim: "\ primitive (u\<^sup>@Suc(Suc k))" using prim_exp_one by fastforce lemma pow_non_prim: "k \ 1 \ \ primitive (w\<^sup>@k)" using prim_exp_one by auto lemma prim_exp_eq: "primitive u \ r\<^sup>@k = u \ u = r" - using prim_exp_one power_one_right by blast + using prim_exp_one pow_1 by blast lemma prim_per_div: assumes "primitive v" and "n \ 0" and "n \ \<^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 \primitive v\ per_div[OF this \period v (gcd \<^bold>|v\<^bold>| n)\]] have "gcd \<^bold>|v\<^bold>| n = \<^bold>|v\<^bold>|" using take_len[OF le_trans[OF gcd_le2_nat[OF \n \ 0\] \n \ \<^bold>|v\<^bold>|\], of "\<^bold>|v\<^bold>|"] by presburger from gcd_le2_nat[OF \n \ 0\, of "\<^bold>|v\<^bold>|", unfolded this] \n \ \<^bold>|v\<^bold>|\ show "n = \<^bold>|v\<^bold>|" by force qed lemma prim_triv_root: "primitive u \ u \ t* \ t = u" using prim_exp_eq unfolding root_def unfolding primitive_def root_def by fastforce -lemma prim_comm_root: assumes "primitive r" and "u\r = r\u" shows "u \ r*" +lemma prim_comm_root[elim]: assumes "primitive r" and "u \ r = r \ u" shows "u \ r*" using \u\r = r\u\[unfolded comm] prim_exp_eq[OF \primitive r\] rootI by metis lemma prim_comm_exp[elim]: assumes "primitive r" and "u\r = r\u" obtains k where "r\<^sup>@k = u" using rootE[OF prim_comm_root[OF assms]]. -lemma comm_rootE: assumes "x \ y = y \ x" - obtains t where "x \ t*" and "y \ t*" - using assms[unfolded comm_root] by blast - -lemma pow_prim_root: assumes "w\<^sup>@k = r\<^sup>@Suc q" and "primitive r" +lemma pow_prim_root: assumes "w\<^sup>@k = r\<^sup>@n" and "0 < n" "primitive r" shows "w \ r*" - using pow_comm_comm[OF \w\<^sup>@k = r\<^sup>@Suc q\[symmetric] Suc_not_Zero] prim_comm_root[OF \primitive r\] by force - -lemma prim_root_drop_exp: assumes "k \ 0" and "primitive r" and "u\<^sup>@k \ r*" + using pow_comm_comm[OF \w\<^sup>@k = r\<^sup>@n\[symmetric] \0 < n\] prim_comm_root[OF \primitive r\] + by presburger + +lemma prim_root_drop_exp[elim]: assumes "u\<^sup>@k \ r*" and "0 < k" and "primitive r" shows "u \ r*" - using pow_comm_comm[of u k r, OF _ \k \ 0\, THEN prim_comm_root[OF \primitive r\]] + using pow_comm_comm[of u k r, OF _ \0 < k\, THEN prim_comm_root[OF \primitive r\]] \u\<^sup>@k \ r*\[unfolded root_def] unfolding root_def by metis lemma prim_card_set: assumes "primitive u" and "\<^bold>|u\<^bold>| \ 1" shows "1 < card (set u)" using \\<^bold>|u\<^bold>| \ 1\ \primitive u\ pow_non_prim[OF \\<^bold>|u\<^bold>| \ 1\, 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 \ \" "v \ \" "u\v = v\u" shows "\ primitive (u\v)" +lemma comm_not_prim: assumes "u \ \" "v \ \" "u \ v = v \ u" shows "\ primitive (u \ v)" proof- obtain t k m where "u = t\<^sup>@k" "v = t\<^sup>@m" using \u\v = v\u\[unfolded comm] by blast show ?thesis using pow_non_prim[of "k+m" "t"] unfolding \u = t\<^sup>@k\ \v = t\<^sup>@m\ add_exps[of t k m] using nemp_pow[OF \u \ \\[unfolded \u = t\<^sup>@k\]] nemp_pow[OF \v \ \\[unfolded \v = t\<^sup>@m\]] by linarith qed lemma prim_rotate_conv: "primitive w \ 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 \r\<^sup>@k = rotate n w\, unfolded rotate_pow_comm] by blast + using rotate_backE[of n w, folded \r\<^sup>@k = rotate n w\, unfolded rotate_pow_comm] by blast from prim_exp_one[OF \primitive w\ 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 \primitive (rotate n w)\, OF rotate_pow_comm[of n r k, unfolded this, symmetric]] show "k = 1". qed qed lemma non_prim: assumes "\ primitive w" and "w \ \" obtains r k where "r \ \" and "1 < k" and "r\<^sup>@k = w" and "w \ r" proof- from \\ primitive w\[unfolded primitive_def] obtain r k where "k \ 1" and "r\<^sup>@k = w" by blast have "r \ \" using \w \ \\ \r\<^sup>@k = w\ emp_pow by blast have "k \ 0" using \w \ \\ \r\<^sup>@k = w\ pow_zero[of r] by meson have "w \ r" using \k \ 1\[folded eq_pow_exp[OF \r \ \\, of k 1, unfolded \r \<^sup>@ k = w\]] by simp show thesis using that[OF \r \ \\ _ \r\<^sup>@k = w\ \w \ r\] \k \ 0\ \k \ 1\ less_linear by blast qed lemma prim_no_rotate: assumes "primitive w" and "0 < n" and "n < \<^bold>|w\<^bold>|" shows "rotate n w \ w" proof assume "rotate n w = w" have "take n w \ drop n w = drop n w \ take n w" using rotate_append[of "take n w" "drop n w"] unfolding take_len[OF less_imp_le_nat[OF \n < \<^bold>|w\<^bold>|\]] append_take_drop_id \rotate n w = w\. have "take n w \ \" "drop n w \ \" using \0 < n\ \n < \<^bold>|w\<^bold>|\ by auto+ from \primitive w\ show False using comm_not_prim[OF \take n w \ \\ \drop n w \ \\ \take n w \ drop n w = drop n w \ take n w\, unfolded append_take_drop_id] by simp qed lemma no_rotate_prim: assumes "w \ \" and "\ n. 0 < n \ n < \<^bold>|w\<^bold>| \ rotate n w \ w" shows "primitive w" proof (rule ccontr) assume "\ primitive w" from non_prim[OF this \w \ \\] obtain r l where "r \ \" and "1 < l" and "r\<^sup>@l = w" and "w \ r" by blast have "rotate \<^bold>|r\<^bold>| w = w" using rotate_root_self[of r l, unfolded \r\<^sup>@l = w\]. moreover have "0 < \<^bold>|r\<^bold>|" by (simp add: \r \ \\) moreover have "\<^bold>|r\<^bold>| < \<^bold>|w\<^bold>|" unfolding pow_len[of r l, unfolded \r\<^sup>@l = w\] using \1 < l\ \0 < \<^bold>|r\<^bold>|\ by auto ultimately show False using assms(2) by blast qed corollary prim_iff_rotate: assumes "w \ \" shows "primitive w \ (\ n. 0 < n \ n < \<^bold>|w\<^bold>| \ rotate n w \ w)" using no_rotate_prim[OF \w \ \\] 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 \ t = [u] \ k = 1" - using pow_non_prim pow_one' prim_sing by metis + using pow_non_prim pow_1 prim_sing by metis lemma prim_rev_iff[reversal_rule]: "primitive (rev u) \ primitive u" unfolding primitive_def[reversed] using primitive_def.. lemma prim_map_prim: "primitive (map f ws) \ primitive ws" unfolding primitive_def using map_pow by metis lemma inj_map_prim: assumes "inj_on f A" and "u \ lists A" and - "primitive u" + "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 \inj f\ UNIV_I] prim_map_prim by (intro iffI) -lemma prim_concat_prim: "primitive (concat ws) \ primitive ws" +lemma prim_concat_prim: "primitive (concat ws) \ primitive ws" unfolding primitive_def using concat_pow by metis +lemma eq_append_not_prim: "x = y \ \ primitive (x \ y)" + by (metis append_Nil2 comm_not_prim prim_nemp) + section \Primitive root\ text\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$.\ -definition primitive_rootP :: "'a list \ 'a list \ bool" ("_ \\<^sub>p _ *" [51,51] 60) - where "primitive_rootP x r = (x \ \ \ x \ r* \ primitive r)" - -lemma primrootD [dest]: "x \\<^sub>p r* \ x \ r*" - unfolding primitive_rootP_def by (elim conjE) - -lemma primrootD_nemp [dest]: "x \\<^sub>p r* \ x \ \" - unfolding primitive_rootP_def by (elim conjE) - -lemma primrootD_prim [dest]: "x \\<^sub>p r* \ primitive r" - unfolding primitive_rootP_def by (elim conjE) - -lemma primrootI [intro]: "u \ \ \ u \ r* \ primitive r \ u \\<^sub>p r*" - unfolding primitive_rootP_def by (intro conjI) - -lemma primroot_rev_conv [reversal_rule]: "rev x \\<^sub>p rev r* \ x \\<^sub>p r*" - unfolding primitive_rootP_def[reversed] using primitive_rootP_def.. - -definition primitive_root :: "'a list \ 'a list" ("\") where "primitive_root x = (THE r. x \\<^sub>p r*)" -definition primitive_root_exp :: "'a list \ nat" ("e\<^sub>\") where "primitive_root_exp x = (THE k. x = (\ x)\<^sup>@k)" - -lemma primrootE: assumes "x \\<^sub>p r*" - obtains k where "k \ 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: "\ x \ \; x \ u*; u \\<^sub>p r*\ \ x \\<^sub>p r*" - unfolding primitive_rootP_def using root_trans by blast + + + + + + +definition primitive_root :: "'a list \ 'a list" ("\") where + "primitive_root x = (if x \ \ then (THE r. primitive r \ (\ k. x = r\<^sup>@k)) else \)" + +definition primitive_root_exp :: "'a list \ nat" ("e\<^sub>\") where + "primitive_root_exp x = (if x \ \ then (THE k. x = (\ x)\<^sup>@k) else 0)" + + + +lemma primroot_emp[simp]: "\ \ = \" + unfolding primitive_root_def by simp lemma comm_prim: assumes "primitive r" and "primitive s" and "r\s = s\r" shows "r = s" using \r\s = s\r\[unfolded comm] assms[unfolded primitive_def, rule_format] by metis -lemma primroot_ex: assumes "x \ \" shows "\ r k. x \\<^sub>p r* \ k \ 0 \ x = r\<^sup>@k" +lemma primroot_ex: assumes "x \ \" shows "\ r k. primitive r \ k \ 0 \ x = r\<^sup>@k" using \x \ \\ proof(induction "\<^bold>|x\<^bold>|" arbitrary: x rule: less_induct) case less - then show "\ r k. x \\<^sub>p r* \ k \ 0 \ x = r\<^sup>@k" + then show "\ r k. primitive r \ k \ 0 \ x = r\<^sup>@k" proof (cases "primitive x") assume "\ primitive x" from non_prim[OF this \x \ \\] obtain r l where "r \ \" and "1 < l" and "r\<^sup>@l = x" and "x \ r" by blast - then obtain pr k where "r \\<^sub>p pr*" "k \ 0" "r = pr\<^sup>@k" - using \x \ \\ less.hyps rootI root_shorter by blast - hence "x \\<^sub>p pr*" - using \r \<^sup>@ l = x\ less.prems primroot_of_root rootI by blast - show "\ r k. x \\<^sub>p r* \ k \ 0 \ x = r\<^sup>@k" - using \x \\<^sub>p pr*\[unfolded primitive_rootP_def root_def] - \x \\<^sub>p pr *\ nemp_pow by metis + from less.hyps[OF root_shorter[OF \x \ \\ rootI[of r l, unfolded \r\<^sup>@l = x\] \x \ r\] \r \ \\] + obtain k pr where "primitive pr" "k \ 0" "r = pr\<^sup>@k" + by blast + have "k*l \ 0" + using \1 < l\ \k \ 0\ by force + have "x = pr\<^sup>@(k*l)" + using pow_mult[of pr k l, folded \r = pr\<^sup>@k\, unfolded \r\<^sup>@l = x\, symmetric]. + thus "\r k. primitive r \ k \ 0 \ x = r \<^sup>@ k" + using \primitive pr\ \k*l \ 0\ by fast next assume "primitive x" - have "x \\<^sub>p x*" - by (simp add: \primitive x\ less.prems primrootI self_root) - thus "\ r k. x \\<^sub>p r* \ k \ 0 \ x = r\<^sup>@k" - by force + have "x = x\<^sup>@Suc 0" + by simp + thus "\ r k. primitive r \ k \ 0 \ x = r\<^sup>@k" + using \primitive x\ by force qed qed lemma primroot_exE: assumes"x \ \" - obtains r k where "primitive r" and "k \ 0" and "x = r\<^sup>@k" - using assms primitive_rootP_def primroot_ex[OF \ x \ \\] by blast + obtains r k where "primitive r" and "0 < k" and "x = r\<^sup>@k" + using assms primroot_ex[OF \ x \ \\] by blast text\Uniqueness of the primitive root follows from the following lemma\ -lemma primroot_unique: assumes "u \\<^sub>p r*" shows "\ u = r" +lemma primroot_unique: assumes "u \ \" and "primitive r" and "u = r\<^sup>@k" shows "\ u = r" proof- - obtain kr where "kr \ 0" and "r\<^sup>@kr = u" - using primrootE[OF \u \\<^sub>p r*\]. - have "u \\<^sub>p s* \ s = r" for s + have "0 < k" + using \u \ \\ \u = r\<^sup>@k\ by blast + have "s = r" if "primitive s" and "u = s\<^sup>@l" for s l proof- - fix s assume "u \\<^sub>p s*" - obtain ks where "ks \ 0" and "s\<^sup>@ks = u" - using primrootE[OF \u \\<^sub>p s*\]. + from pow_comm_comm[OF \u = s\<^sup>@l\[unfolded \u = r\<^sup>@k\] \0 < k\] obtain t where "s \ t*" and "r \ t*" - using comm_rootE[OF pow_comm_comm[of r kr s ks, OF _ \kr \ 0\, unfolded \r\<^sup>@kr = u\ \s\<^sup>@ks = u\, OF refl]]. - have "primitive r" and "primitive s" - using \u \\<^sub>p r *\ \u \\<^sub>p s *\ primitive_rootP_def by blast+ + using comm_root by blast from prim_exp_eq[OF \primitive r\, of t] prim_exp_eq[OF \primitive s\, of t] show "s = r" using rootE[OF \s \ t*\, of "s=r"] rootE[OF \r \ t*\, of "r = t"] by fastforce qed - from the_equality[of "\ r. u \\<^sub>p r*",OF \u \\<^sub>p r*\ this] + hence "primitive s \ (\k. u = s \<^sup>@ k) \ s = r" for s + by presburger + from the_equality[of "\ r. primitive r \ (\k. u = r \<^sup>@ k)" r, OF _ this] show "\ u = r" - unfolding primitive_root_def by auto -qed + using \primitive r\ \u = r\<^sup>@k\ unfolding primitive_root_def if_P[OF \u \ \\] by blast +qed + +lemma primroot_unique': assumes "0 < k" "primitive r" and "u = r\<^sup>@k" shows "\ u = r" + using primroot_unique[OF _ assms(2,3)] using prim_nemp[OF \primitive r\] \0 < k\ unfolding \u = r\<^sup>@k\ + using nonzero_pow_emp by blast lemma prim_self_root[intro]: "primitive x \ \ x = x" - using prim_nemp primrootI primroot_unique self_root by metis + using emp_not_prim primroot_unique pow_1 by metis lemma primroot_exp_unique: assumes "u \ \" and "(\ u)\<^sup>@k = u" shows "e\<^sub>\ u = k" - unfolding primitive_root_exp_def + unfolding primitive_root_exp_def if_P[OF \u \ \\] proof (rule the_equality) show "u = (\ u)\<^sup>@k" using \(\ u)\<^sup>@k = u\[symmetric]. have "\ u \ \" using assms by force show "ka = k" if "u = \ u \<^sup>@ ka" for ka - using eq_pow_exp[OF \\ u \ \\, of k ka, folded \u = (\ u)\<^sup>@k\ that] by blast -qed + using eq_pow_exp[OF \\ u \ \\, of k ka, folded \u = (\ u)\<^sup>@k\ that] by blast +qed + +lemma primroot_prim[intro]: "x \ \ \ primitive (\ x)" + using primroot_unique primroot_ex by metis text\Existence and uniqueness of the primitive root justifies the function @{term primitive_root}: it indeed yields the primitive root of a nonempty word.\ -lemma primroot_is_primroot[intro]: assumes "x \ \" shows "x \\<^sub>p (\ x)*" - using primroot_ex[OF \x \ \\] primroot_unique[of x] - by force - -lemma primroot_is_root[intro]: "x \ \ \ x \ (\ x)*" - using primroot_is_primroot by auto - -lemma primroot_expE[elim]: assumes "x \ \" obtains k where "(\ x)\<^sup>@Suc k = x" - using primroot_is_root[OF \x \ \\, unfolded root_def] pow_zero assms not0_implies_Suc by metis - -lemma primroot_expE': obtains k where "(\ x)\<^sup>@k = x" - using primroot_expE pow_zero by metis - -lemma primroot_exp_eq: "u \ \ \ (\ u)\<^sup>@(e\<^sub>\ u) = u" - using primroot_expE'[of u "\ u \<^sup>@ e\<^sub>\ u = u"] primroot_exp_unique by blast - -lemma primroot_exp_nemp: "u \ \ \ e\<^sub>\ u \ 0" - using primroot_exp_eq nemp_pow by metis - -(* lemma prim_root_power [elim]: assumes "x \ \" obtains i where "(\ x)\<^sup>@(Suc i) = x" *) -(* using primrootD[OF primroot_is_primroot[OF \x \ \\], unfolded root_def] assms pow_zero[of "\ x"] not0_implies_Suc *) -(* by metis *) - -(* lemma primrootI[intro]: assumes "x \ \" shows primroot_prim: "primitive (\ x)" and primroot_nemp: "\ x \ \" *) - -lemma primroot_prim[intro]: "x \ \ \ primitive (\ x)" - using primitive_rootP_def by blast - -lemma primroot_nemp[intro!]: "x \ \ \ \ x \ \" + +lemma primroot_is_root[simp]: "x \ (\ x)*" + by (cases "x = \", force, unfold root_def) (use primroot_exE primroot_unique in metis) + + +lemma primroot_expE: obtains k where "(\ x)\<^sup>@k = x" and "0 < k" +proof (cases "x = \") + assume "x \ \" + with primroot_is_root[unfolded root_def] that + show thesis by fastforce +qed auto + +lemma primroot_exp_eq [simp]: "(\ u)\<^sup>@(e\<^sub>\ u) = u" + using primroot_expE[of u "\ u \<^sup>@ e\<^sub>\ u = u"] primroot_exp_unique pow_0 primitive_root_exp_def by metis + +lemma primroot_exp_len: + shows "e\<^sub>\ w * \<^bold>|\ w\<^bold>| = \<^bold>|w\<^bold>|" + using lenarg[OF primroot_exp_eq] unfolding pow_len. + +lemma primroot_exp_nemp [intro]: "u \ \ \ 0 < e\<^sub>\ u" + using primroot_exp_eq nemp_pow by metis + + + +lemma primroot_nemp[intro!]: "x \ \ \ \ x \ \" using prim_nemp by blast -lemma primroot_idemp[simp]: "x \ \ \ \ (\ x) = \ x" - using prim_self_root by blast +lemma primroot_idemp[simp]: "\ (\ x) = \ x" + by (cases "x = \") (simp only: primroot_emp, use prim_self_root in blast) lemma prim_primroot_conv: assumes "w \ \" shows "primitive w \ \ w = w" - using assms prim_self_root primroot_prim[OF \w \ \\] by fastforce - -lemma not_prim_primroot_expE: assumes "\ primitive w" and "w \ \" - obtains k where "\ w \<^sup>@Suc (Suc k) = w" -proof- - obtain k' where "(\ w)\<^sup>@Suc k' = w" - using primroot_expE[OF \w \ \\] by blast - hence "k' \ 0" - using \\ primitive w\[unfolded prim_primroot_conv[OF \w \ \\]] pow_one by metis - then obtain k where "Suc k = k'" - using not0_implies_Suc by auto - from that[OF \(\ w)\<^sup>@Suc k' = w\[folded \Suc k = k'\]] - show thesis. -qed - -lemma not_prim_primroot_expE': assumes "\ primitive x" and "x \ \" - obtains k where "\ x\<^sup>@k = x" and "2 \ k" - using not_prim_primroot_expE[OF assms] Suc_le_mono numeral_2_eq_2 zero_le by metis + using assms prim_self_root primroot_prim[OF \w \ \\] by metis + +lemma not_prim_primroot_expE: assumes "\ primitive w" + obtains k where "\ w \<^sup>@k = w" and "2 \ k" + using primroot_exp_eq primroot_prim assms +proof (cases "w = \") + assume "w \ \" + with primroot_exp_eq[of w] + have "e\<^sub>\ w \ 1" "e\<^sub>\ w \ 0" + using pow_zero pow_1 primroot_prim[OF \w \ \\] \\ primitive w\ by force+ + with that[OF \\ w \<^sup>@ e\<^sub>\ w = w\] + show thesis by force +qed force + lemma not_prim_expE: assumes "\ primitive x" and "x \ \" obtains r k where "primitive r" and "2 \ k" and "r\<^sup>@k = x" - using not_prim_primroot_expE'[OF assms] primroot_prim[OF \x \ \\] by metis - -lemma not_prim_pow: assumes "\ primitive u" obtains k r where "r\<^sup>@k = u" and "2 \ k" - using assms -proof (cases) - assume "u \ \" - from not_prim_primroot_expE'[OF assms this that] - show thesis. -qed (simp add: that[of \ 2]) - -lemma not_prim_pow': assumes "\ primitive u" obtains k r where "r\<^sup>@Suc (Suc k) = u" -proof (cases) - assume "u \ \" - from not_prim_primroot_expE[OF assms this that] - show thesis. -qed (simp add: that[of \ 2]) - -lemma primroot_root: assumes "u \ \" and "u \ q*" shows "\ q = \ u" - using primroot_unique[OF primroot_of_root[OF \u \ \\ \u \ q*\ primroot_is_primroot, OF root_nemp[OF \u \ \\ \u \ q*\]], symmetric]. - -lemma pow_prim_primroot: "w \ \ \ primitive r \ w = r\<^sup>@k \ \ w = r" - using prim_self_root primroot_root rootI by metis - -lemma primroot_len_mult: assumes "u \ \" and "u \ q*" - obtains k where "\<^bold>|q\<^bold>| = k*\<^bold>|\ u\<^bold>|" - using primroot_is_primroot[OF root_nemp[OF \u \ \\ \u \ q*\], unfolded primroot_root[OF \u \ \\ \u \ q*\] - primitive_rootP_def] root_len[of q "\ u"] by blast + using not_prim_primroot_expE[OF \\ primitive x\] primroot_prim[OF \x \ \\] by metis + +lemma primroot_of_root: assumes "u \ \" and "u \ q*" shows "\ q = \ u" +proof- + have "q \ \" + using assms by force + from primroot_unique[OF \u \ \\ primroot_prim[OF this], symmetric] + root_trans[OF \u \ q*\ primroot_is_root[of q]] + show ?thesis + unfolding root_def by blast +qed + + lemma primroot_shorter_root: assumes "u \ \" and "u \ q*" shows "\<^bold>|\ u\<^bold>| \ \<^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 \ \" shows "\<^bold>|\ u\<^bold>| = (LEAST d. (\ r. (u \ r*) \ \<^bold>|r\<^bold>| = d))" - using Least_equality[of "\ k. (\ r. (u \ r*) \ \<^bold>|r\<^bold>| = k)" "\<^bold>|\ u\<^bold>|"] -proof - show "\r. u \ r* \ \<^bold>|r\<^bold>| = \<^bold>|\ u\<^bold>|" - using assms primitive_rootP_def primroot_is_primroot by blast - show "\y. \r. u \ r* \ \<^bold>|r\<^bold>| = y \ \<^bold>|\ u\<^bold>| \ y" - using assms primroot_shorter_root by auto -qed + unfolding primroot_of_root[OF assms, symmetric] + using root_nemp[OF assms] root_shorter_eq[of q, OF _ primroot_is_root] by blast + lemma primroot_len_le: "u \ \ \ \<^bold>|\ u\<^bold>| \ \<^bold>|u\<^bold>|" - using primroot_shorter_root self_root by auto + using primroot_expE primroot_shorter_root[OF _ self_root] by auto lemma primroot_take: assumes "u \ \" shows "\ u = (take ( \<^bold>|\ u\<^bold>| ) u)" proof- - obtain k where "(\ u)\<^sup>@k = u" and "k \ 0" - using primroot_expE[OF \u \ \\] by blast + obtain k where "(\ u)\<^sup>@k = u" and "0 < k" + using primroot_expE by blast show "\ u = (take ( \<^bold>|\ u\<^bold>| ) u)" - using take_root[of _ "(\ u)", OF \k \ 0\, unfolded \(\ u)\<^sup>@k = u\]. -qed - -lemma primroot_take_shortest: assumes "u \ \" shows "\ u = (take (LEAST d. (\ r. (u \ r*) \ \<^bold>|r\<^bold>| = d)) u)" - using primroot_take[OF assms, unfolded primroot_shortest_root[OF assms]]. + using take_root[of _ "(\ u)", OF \0 < k\, unfolded \(\ u)\<^sup>@k = u\]. +qed + lemma primroot_rotate_comm: assumes "w \ \" shows "\ (rotate n w) = rotate n (\ w)" proof- obtain l where "(\ w)\<^sup>@l = w" - using primroot_expE[OF \w \ \\]. + using primroot_expE. hence "rotate n w \ (rotate n (\ w))*" using rotate_pow_comm root_def by metis - moreover have "rotate n w \ \" + have "rotate n w \ \" using assms by auto - moreover have "primitive (rotate n (\ w))" - using assms prim_rotate_conv primitive_rootP_def primroot_is_primroot by blast - ultimately have "rotate n w \\<^sub>p (rotate n (\ w))*" - unfolding primitive_rootP_def by blast - thus ?thesis - using primroot_unique by blast + have "primitive (rotate n (\ w))" + using assms prim_rotate_conv by blast + show ?thesis + using primroot_unique[OF \rotate n w \ \\ \primitive (rotate n (\ w))\] + rootE[OF \rotate n w \ (rotate n (\ w))*\] by metis qed lemma primroot_rotate: "\ w = r \ \ (rotate (k*\<^bold>|r\<^bold>|) w) = r" (is "?L \ ?R") -proof(cases "w = \", simp add: rotate_is_Nil_conv[of "k*\<^bold>|r\<^bold>|" w]) +proof(cases "w = \") case False show ?thesis unfolding primroot_rotate_comm[OF \w \ \\, of "k*\<^bold>|r\<^bold>|"] using length_rotate[of "k*\<^bold>|r\<^bold>|" "\ w"] mod_mult_self2_is_0[of k "\<^bold>|r\<^bold>|"] rotate_id[of "k*\<^bold>|r\<^bold>|" "\ w"] by metis -qed - -lemma primrootI1[intro]: assumes pow: "u = r\<^sup>@(Suc k)" and prim: "primitive r" shows "\ u = r" +qed (simp add: rotate_is_Nil_conv[of "k*\<^bold>|r\<^bold>|" w]) + +lemma primrootI[intro]: assumes pow: "u = r\<^sup>@(Suc k)" and "primitive r" shows "\ u = r" proof- have "u \ \" - using pow prim prim_nemp by auto - have "u \ r*" - using pow rootI by blast + using pow \primitive r\ prim_nemp by auto show "\ u = r" - using primroot_unique[OF primrootI[OF \u \ \\ \u \ r*\ \primitive r\]]. -qed + using primroot_unique[OF \u \ \\ \primitive r\ \u = r\<^sup>@(Suc k)\]. +qed + +lemma primroot_pref: "\ u \p u" + by (cases "u = \", use primroot_emp in blast) + (simp add: per_root_pref[OF _ primroot_is_root]) + +lemma short_primroot: assumes "u \ \" "\ primitive u" shows "\<^bold>|\ u\<^bold>| < \<^bold>|u\<^bold>|" + using primroot_prim[OF \u \ \\] le_neq_implies_less pref_len primroot_pref + long_pref assms by metis lemma prim_primroot_cases: obtains "u = \" | "primitive u" | "\<^bold>|\ u\<^bold>| < \<^bold>|u\<^bold>|" - using primroot_is_primroot[THEN primrootD[of u "\ u"]] - primroot_prim[of u] root_shorter[of u "\ u"] by fastforce + using short_primroot by blast text\We also have the standard characterization of commutation for nonempty words.\ +lemma comm_rootE: assumes "x \ y = y \ x" + obtains t where "x \ t*" and "y \ t*" and "t \ \" + using assms[unfolded comm_root] + using emp_all_roots list.discI root_nemp by metis + theorem comm_primroots: assumes "u \ \" and "v \ \" shows "u \ v = v \ u \ \ u = \ v" proof assume "u \ v = v \ u" - then obtain t where "u \ t*" and "v \ t*" - using comm_root by blast + from comm_rootE[OF this] + obtain t where "u \ t*" and "v \ t*". show "\ u = \ v" - using primroot_root[OF \v \ \\ \v \ t*\, unfolded primroot_root[OF \u \ \\ \u \ t*\]]. + using primroot_of_root[OF \v \ \\ \v \ t*\, unfolded primroot_of_root[OF \u \ \\ \u \ t*\]]. next assume "\ u = \ v" - then show "u \ v = v \ u" - using primroot_is_primroot[OF \u \ \\, unfolded \\ u = \ v\] primroot_is_primroot[OF \v \ \\] unfolding primitive_rootP_def - comm_root by blast + from pows_comm[of "\ u" "e\<^sub>\ u" "e\<^sub>\ v"] + show "u \ v = v \ u" + unfolding primroot_exp_eq unfolding \\ u = \ v\ primroot_exp_eq. qed lemma comm_primroots': "u \ \ \ v \ \ \ u \ v = v \ u \ \ u = \ v" by (simp add: comm_primroots) +lemma same_primroots_comm: "\ x = \ y \ x \ y = y \ x" + using comm_primroots by blast + lemma pow_primroot: assumes "x \ \" shows "\ (x\<^sup>@Suc k) = \ x" - using comm_primroots'[OF nemp_Suc_pow_nemp, OF assms assms, of k, folded pow_Suc2 pow_Suc] by blast + using comm_primroots'[OF nemp_Suc_pow_nemp, OF assms assms, of k, folded pow_Suc' pow_Suc] by blast lemma comm_primroot_exp: assumes "v \ \" and "u \ v = v \ u" obtains n where "(\ v)\<^sup>@n = u" proof(cases) - assume "u = \" thus thesis using that power_0 by blast + assume "u = \" thus thesis using that pow_0 by blast next - assume "u \ \" thus thesis using that[OF primroot_expE'] \u \ v = v \ u\[unfolded comm_primroots[OF \u \ \\ \v \ \\]] by metis + assume "u \ \" thus thesis using that[OF primroot_expE] \u \ v = v \ u\[unfolded comm_primroots[OF \u \ \\ \v \ \\]] by metis qed lemma comm_primrootE: assumes "x \ y = y \ x" - obtains t where "x \ t*" and "y \ 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 \ \" shows "u \ v = v \ u \ u \ \ v = \ v \ u" - using assms -proof (cases "u = \", simp) - assume "u \ \" - from comm_primroots[of _ "\ v", OF \u \ \\, unfolded primroot_idemp[OF \v \ \\], OF primroot_nemp[OF \v \ \\]] + obtains t where "x \ t*" and "y \ t*" and "primitive t" + using comm_primroots assms emp_all_roots prim_sing primroot_is_root primroot_prim by metis + +lemma primE: obtains t where "primitive t" + using comm_primrootE by metis + +lemma comm_primrootE': assumes "x \ y = y \ x" + obtains t m k where "x = t\<^sup>@k" and "y = t\<^sup>@m" and "primitive t" + using comm_primrootE[OF \x \ y = y \ x\, unfolded root_def] by metis + +lemma comm_nemp_pows_posE: assumes "x \ y = y \ x" and "x \ \" and "y \ \" + obtains t k m where "x = t\<^sup>@k" and "y = t\<^sup>@m" and "0 < k" and "0 < m" and "primitive t" +proof- + from comm_primrootE[OF \x \ y = y \ x\, unfolded root_def] + obtain t k m where "t\<^sup>@k = x" "t\<^sup>@m = y" "primitive t" + by metis + note nemp_exp_pos[OF \x \ \\ \t\<^sup>@k = x\] nemp_exp_pos[OF \y \ \\ \t\<^sup>@m = y\] + show thesis + using that[OF \t\<^sup>@k = x\[symmetric] \t\<^sup>@m = y\[symmetric] \0 < k\ \0 < m\ \primitive t\]. +qed + +lemma comm_primroot_conv: "u \ v = v \ u \ u \ \ v = \ v \ u" +proof (cases "u = \ \ v = \") + assume "\ (u = \ \ v = \)" + hence "u \ \" "v \ \" + by blast+ show ?thesis - using comm_primroots[OF \u \ \\ \v \ \\] by blast -qed + using comm_primroots[OF \u \ \\ \v \ \\, folded + comm_primroots[OF \u \ \\ primroot_nemp[OF \v \ \\], unfolded primroot_idemp]]. +qed force lemma comm_primroot [simp, intro]: "u \ \ u = \ u \ u" - using comm_primroot_conv by blast - -lemma comp_primroot_conv': assumes "u \ \" and "v \ \" shows "u \ v = v \ u \ \ u \ \ v = \ v \ \ u" - unfolding comm_primroot_conv[OF \v \ \\, symmetric] eq_commute[of "u \ v"] eq_commute[of "\ u \ v"] - unfolding comm_primroot_conv[OF \u \ \\, symmetric].. - -lemma per_root_primroot: "w \p r \ w \ r \ \ \ w \p \ r \ w" - using comm_primroot_conv root_comm_root by metis + using comm_primroot_conv by blast + +lemma comp_primroot_conv': shows "u \ v = v \ u \ \ u \ \ v = \ v \ \ u" + using comm_primroot_conv[of u v] comm_primroot_conv[of "\ v" u] + unfolding eq_sym_conv[of "\ v \ u"] eq_sym_conv[of "\ v \ \ u"] by blast + +lemma per_root_primroot: "w

w \ w

r \ w" + using per_root_trans[OF _ primroot_is_root]. + +lemma primroot_per_root: "r \ \ \ r

r \ r" + by blast lemma prim_comm_short_emp: assumes "primitive p" and "u\p=p\u" and "\<^bold>|u\<^bold>| < \<^bold>|p\<^bold>|" shows "u = \" proof (rule ccontr) assume "u \ \" from \u \ p = p \ u\ have "\ u = \ p" unfolding comm_primroots[OF \u \ \\ prim_nemp, OF \primitive p\]. have "\ u = p" using prim_self_root[OF \primitive p\, folded \\ u = \ p\]. from \\<^bold>|u\<^bold>| < \<^bold>|p\<^bold>|\[folded this] show False using primroot_len_le[OF \u \ \\] by auto qed -lemma primroot_pref: "x \ \ \ \ x \p x" - using primroot_take take_is_prefix by metis - -lemma primroot_rev[reversal_rule]: "u \ \ \ \ (rev u) = rev (\ u)" - using primroot_rev_conv primroot_is_primroot primroot_unique by metis - -lemma primroot_suf: assumes "x \ \" shows "\ x \s x" - using primroot_pref[reversed, OF \x \ \\] unfolding primroot_rev[OF \x \ \\] suf_rev_pref_iff. +lemma primroot_rev[reversal_rule]: shows "\ (rev u) = rev (\ u)" +proof (cases "u = \") + assume "u \ \" + hence "rev u \ \" + by simp + have "primitive (rev (\ u))" + using primroot_prim[OF \u \ \\] unfolding prim_rev_iff. + have "rev u = (rev (\ u))\<^sup>@e\<^sub>\ u" + unfolding rev_pow[symmetric] primroot_exp_eq.. + from primroot_unique[OF \rev u \ \\ \primitive (rev (\ u))\ this] + show ?thesis. +qed simp + +lemmas primroot_suf = primroot_pref[reversed] lemma per_le_prim_iff: assumes "u \p p \ u" and "p \ \" and "2 * \<^bold>|p\<^bold>| \ \<^bold>|u\<^bold>|" shows "primitive u \ u \ p \ p \ u" proof have "\<^bold>|p\<^bold>| < \<^bold>|u\<^bold>|" using \2 * \<^bold>|p\<^bold>| \ \<^bold>|u\<^bold>|\ nemp_len[OF \p \ \\] by linarith - with \p \ \\ + with \p \ \\ show "primitive u \ u \ p \ p \ u" by (intro notI, elim notE) (rule prim_comm_short_emp[OF _ sym]) show "u \ p \ p \ u \ primitive u" - proof (elim swap[of "_ = _"], elim not_prim_pow) + proof (elim swap[of "_ = _"], elim not_prim_primroot_expE) fix k z assume "2 \ k" and eq: "z \<^sup>@ k = u" from this(1) lenarg[OF this(2)] \2 * \<^bold>|p\<^bold>| \ \<^bold>|u\<^bold>|\ have "\<^bold>|z\<^bold>| + \<^bold>|p\<^bold>| \ \<^bold>|u\<^bold>|" - by (elim at_least2_Suc) (simp only: power_Suc lenmorph[of z]) + by (elim at_least2_Suc) (simp only: pow_Suc lenmorph[of z]) with \u \p p \ u\ have "z \ p = p \ z" by (rule two_pers[rotated 1]) (simp flip: eq pow_comm) from comm_add_exp[OF this, of k] show "u \ p = p \ u" unfolding eq. qed qed +lemma per_root_mod_primE [elim]: assumes "u

u" + obtains n p s where "p \ s = \ r" and "(p\s)\<^sup>@n \ p = u" and "s \ \" + using per_root_modE[OF per_root_primroot[OF assms]] primroot_prim[OF per_root_nemp[OF assms]] + emp_not_prim by metis subsection \Primitivity and the shortest period\ lemma min_per_primitive: assumes "w \ \" shows "primitive (\ w)" proof- have "\(\ w) \ \" - using assms min_per_nemp primroot_nemp by blast - obtain k where "\ w = (\ (\ w))\<^sup>@k" - using pow_zero primroot_expE by metis + using assms min_per_nemp primroot_nemp by blast + obtain k where "\ w = (\ (\ w))\<^sup>@k" + using primroot_expE by metis from rootI[of "\ (\ w)" k, folded this] - have "w \p (\ (\ w))\<^sup>\" - using min_per_root_per_root[OF assms, THEN per_root_trans] by blast - from pow_pref_root_one[OF _ \\(\ w) \ \\, of k, folded \\ w = (\ (\ w))\<^sup>@k\, OF _ min_per_min[OF this]] - have "k = 1" - using \\ w = (\ (\ w))\<^sup>@k\ min_per_nemp[OF \w \ \\] pow_zero[of "\ (\ w)"] by metis + have "w

(\ w)) \ w" + using min_per_root_per_root[OF assms, THEN per_root_trans] by presburger + from pow_pref_root_one[OF _ \\(\ w) \ \\, of k, folded \\ w = (\ (\ w))\<^sup>@k\, OF _ min_per_min[OF this]] + have "k = 1" + using \\ w = (\ (\ w))\<^sup>@k\ min_per_nemp[OF \w \ \\] pow_zero[of "\ (\ w)"] by fastforce show "primitive (\ w)" using primroot_prim[OF \\ (\ w) \ \\, folded \\ w = (\ (\ w))\<^sup>@k\[unfolded \k = 1\ One_nat_def pow_one]]. qed -lemma min_per_short_primroot: assumes "w \ \" and "(\ w)\<^sup>@k = w" and "k \ 1" +lemma min_per_short_primroot: assumes "w \ \" and "(\ w)\<^sup>@k = w" and "k \ 1" shows "\ w = \ w" proof- - obtain k' where "k = Suc (Suc k')" - using \w \ \\ and \(\ w)\<^sup>@k = w\ \k \ 1\[unfolded One_nat_def] nemp_pow not0_implies_Suc by metis - have "w \p (\ w)\<^sup>\" - using assms(1) assms(2) per_drop_exp root_self by metis - have "w \p (\ w)\<^sup>\" + have "k \ 0" + using assms pow_zero by blast + with \k \ 1\ have "2 \ k" + by fastforce + have "w

w) \ w" + using assms(1) assms(2) per_root_drop_exp root_self by metis + have "w

w) \ w" using assms(1) min_per_root_per_root by blast have "\ w \p \ w" - using min_per_min[OF \w \p (\ w)\<^sup>\\]. + using min_per_min[OF \w

w) \ w\]. from prefix_length_le[OF this] have "\<^bold>|\ w\<^bold>| + \<^bold>|\ w\<^bold>| \ \<^bold>|w\<^bold>|" - using lenarg[OF \(\ w)\<^sup>@k =w\, unfolded pow_len] unfolding \k = Suc (Suc k')\ by simp - from two_pers_root[OF \w \p (\ w)\<^sup>\\ \w \p (\ w)\<^sup>\\ this] + unfolding lenarg[OF \(\ w)\<^sup>@k =w\, unfolded pow_len, symmetric] using + mult_le_mono1[OF \2 \ k\, of "\<^bold>|\ w\<^bold>|"] unfolding one_add_one[symmetric] distrib_right mult_1 + by simp + from two_pers_root[OF \w

w) \ w\ \w

w) \ w\ this] have "\ w \ \ w = \ w \ \ w". - from this[unfolded comm_primroots[OF per_rootD'[OF \w \p \ w\<^sup>\\] per_rootD'[OF \w \p \ w\<^sup>\\]]] + from this[unfolded comm_primroots[OF per_root_nemp[OF \w

w) \ w\] per_root_nemp[OF \w

w) \ w\]]] show "\ w = \ w" unfolding prim_self_root[of "\ w", OF primroot_prim[OF \w \ \\]] prim_self_root[of "\ w", OF min_per_primitive[OF \w \ \\]]. qed lemma primitive_iff_per: "primitive w \ w \ \ \ (\ w = w \ \ w \ w \ w \ \ w)" proof assume "primitive w" + hence "w \ \" by fastforce show "w \ \ \ (\ w = w \ \ w \ w \ w \ \ w)" - proof (standard, simp add: prim_nemp \primitive w\, intro verit_or_neg(1)) - assume "\ w \ w = w \ \ w" - from comm_prim[OF min_per_primitive[OF prim_nemp[OF \primitive w\]] \primitive w\ this] - show "\ w = w". - qed + proof (rule conjI) + show "\ w = w \ \ w \ w \ w \ \ w" + using comm_prim [OF min_per_primitive[OF \w \ \\] \primitive w\] + by (intro verit_or_neg(1)) + qed fact next assume asm: "w \ \ \ (\ w = w \ \ w \ w \ w \ \ w)" have "w \ \" and imp: "\ w \ w = w \ \ w \ \ w = w" using asm by blast+ - obtain k where "(\ w)\<^sup>@Suc k = w" - using primroot_expE[OF \w \ \\] by metis + obtain k where "(\ w)\<^sup>@k = w" "0 < k" + using primroot_expE. show "primitive w" - proof (cases "k = 0") - assume "k = 0" - from \(\ w)\<^sup>@Suc k = w\[unfolded this, unfolded pow_one] \w \ \\ - show "primitive w" - by (simp add: prim_primroot_conv) - next - assume "k \ 0" - hence "Suc k \ 1" by simp - from imp[unfolded min_per_short_primroot[OF \w \ \\ \(\ w)\<^sup>@Suc k = w\ this]] + proof- + from imp[unfolded min_per_short_primroot[OF \w \ \\ \(\ w)\<^sup>@k = w\]] have "\ w = w" - using power_commutes[symmetric, of "\ w" "Suc k", unfolded \\ w \<^sup>@Suc k = w\] by blast + using pow_comm[symmetric, of "\ w" k, unfolded \\ w \<^sup>@k = w\] + \\ w \<^sup>@ k = w\ min_per_short_primroot[OF \w \ \\ \\ w\<^sup>@k = w\] pow_1 \w \ \\ by metis thus "primitive w" using prim_primroot_conv[OF \w \ \\] by simp qed qed section \Conjugation\ text\Two words $x$ and $y$ are conjugated if one is a rotation of the other. Or, equivalently, there exists $z$ such that \[ xz = zy. \] \ -definition conjugate ("_ \ _" [50,50] 51) where "u \ v \ \r s. r \ s = u \ s \ r = v" - +definition conjugate (infix "\" 51) + where "u \ v \ \r s. r \ s = u \ s \ r = v" lemma conjugE [elim]: assumes "u \ v" obtains r s where "r \ s = u" and "s \ r = v" using assms unfolding conjugate_def by (elim exE conjE) lemma conjugE_nemp[elim]: assumes "u \ v" and "u \ \" obtains r s where "r \ s = u" and "s \ r = v" and "s \ \" - using assms unfolding conjugate_def -proof (cases "u = v", simp add: that[OF _ _ \u \ \\]) + using assms unfolding conjugate_def +proof (cases "u = v") assume "u \ v" obtain r s where "r \ s = u" and "s \ r = v" using conjugE[OF \u \ v\]. hence "s \ \" using \u \ v\ by force thus thesis using that[OF \r \ s = u\ \s \ r = v\] by blast -qed +qed (simp add: that[OF _ _ \u \ \\]) lemma conjugE1 [elim]: assumes "u \ v" obtains r where "u \ r = r \ v" proof - obtain r s where u: "r \ s = u" and v: "s \ r = v" using assms.. have "u \ r = r \ v" unfolding u[symmetric] v[symmetric] using rassoc. then show thesis by fact qed lemma conjug_rev_conv [reversal_rule]: "rev u \ rev v \ u \ v" unfolding conjugate_def[reversed] using conjugate_def by blast lemma conjug_rotate_iff: "u \ v \ (\ 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 \ rotate n w" - using conjug_rotate_iff by auto - -lemma conjug_rotate_iff_le: - shows "u \ v \ (\ n \ \<^bold>|u\<^bold>| - 1. v = rotate n u)" + using conjug_rotate_iff by blast + +lemma conjug_rotate_iff_le: + shows "u \ v \ (\ n \ \<^bold>|u\<^bold>| - 1. v = rotate n u)" proof show "\n \ \<^bold>|u\<^bold>| - 1 . v = rotate n u \ u \ v" - using conjug_rotate_iff by auto + using conjug_rotate_iff by blast next assume "u \ v" thus "\ n \ \<^bold>|u\<^bold>| - 1. v = rotate n u" - proof (cases "u = \", simp, blast) + proof (cases "u = \") assume "u \ \" - obtain r s where "r \ s = u" and "s \ r = v" and "s \ \" + obtain r s where "r \ s = u" and "s \ r = v" and "s \ \" using conjugE_nemp[OF \u \ v\ \u \ \\]. hence "v = rotate \<^bold>|r\<^bold>| u" - using rotate_append[of r s] by argo - moreover have "\<^bold>|r\<^bold>| \ \<^bold>|u\<^bold>| - 1" + using rotate_append[of r s] by argo + moreover have "\<^bold>|r\<^bold>| \ \<^bold>|u\<^bold>| - 1" using lenarg[OF \r \ s = u\, unfolded lenmorph] nemp_len[OF \s \ \\] by linarith ultimately show "\n \ \<^bold>|u\<^bold>| - 1. v = rotate n u" by blast - qed + qed auto qed lemma conjugI [intro]: "r \ s = u \ s \ r = v \ u \ v" unfolding conjugate_def by (intro exI conjI) lemma conjugI' [intro!]: "r \ s \ s \ r" - unfolding conjugate_def by (intro exI conjI, standard+) + unfolding conjugate_def by (intro exI conjI) standard+ lemma conjug_refl: "u \ u" by standard+ lemma conjug_sym[sym]: "u \ v \ v \ u" by (elim conjugE, intro conjugI) assumption -lemma conjug_swap: "u \ v \ v \ u" +lemma conjug_swap: "u \ v \ v \ u" by blast lemma conjug_nemp_iff: "u \ v \ u = \ \ v = \" by (elim conjugE1, intro iffI) simp+ lemma conjug_len: "u \ v \ \<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|" by (elim conjugE, hypsubst, rule swap_len) lemma pow_conjug: assumes eq: "t\<^sup>@i \ r \ u = t\<^sup>@k" and t: "r \ s = t" shows "u \ t\<^sup>@i \ r = (s \ r)\<^sup>@k" proof - have "t\<^sup>@i \ r \ u \ t\<^sup>@i \ r = t\<^sup>@i \ t\<^sup>@k \ r" unfolding eq[unfolded lassoc] lassoc append_same_eq pows_comm.. also have "\ = t\<^sup>@i \ r \ (s \ r)\<^sup>@k" unfolding conjug_pow[OF rassoc, symmetric] t.. finally show "u \ t\<^sup>@i \ r = (s \ r)\<^sup>@k" unfolding same_append_eq. qed -lemma conjug_set: assumes "u \ v" shows "set u = set v" +lemma conjug_set: assumes "u \ v" shows "set u = set v" using conjugE[OF \u \ v\] set_append Un_commute by metis lemma conjug_concat_conjug: "xs \ ys \ concat xs \ concat ys" unfolding conjugate_def using concat_morph by metis text\The solution of the equation \[ xz = zy \] is given by the next lemma. \ lemma conjug_eqE [elim, consumes 2]: assumes eq: "x \ z = z \ y" and "x \ \" obtains u v k where "u \ v = x" and "v \ u = y" and "(u \ v)\<^sup>@k \ u = z" and "v \ \" proof - have "z \p x \ z" using eq[symmetric].. - from this and \x \ \\ have "z \p x\<^sup>\".. - then obtain k u where "x\<^sup>@k \ u = z" and "u

u

obtain v where x: "u \ v = x" and "v \ \".. + from this and \x \ \\ have "z

z".. + then obtain k u v where "x\<^sup>@k \ u = z" and x: "u \ v = x" and "v \ \".. have z: "(u\v)\<^sup>@k \ u = z" unfolding x \x\<^sup>@k \ u = z\.. have "z \ y = (u\v) \ ((u\v)\<^sup>@k \ u)" unfolding z unfolding x eq.. also have "\ = (u\v)\<^sup>@k \ u \ (v \ u)" unfolding lassoc pow_comm[symmetric].. finally have y: "v \ u = y" unfolding z[symmetric] rassoc same_append_eq.. from x y z \v \ \\ show thesis.. qed theorem conjugation: assumes "x\z = z\y" and "x \ \" shows "\ u v k. u \ v = x \ v \ u = y \ (u \ v)\<^sup>@k \ u = z" using assms by blast -lemma conjug_eq_primrootE [elim, consumes 2]: +lemma conjug_eq_primrootE' [elim, consumes 2]: assumes eq: "x \ z = z \ y" and "x \ \" obtains r s i n where - "(r \ s)\<^sup>@Suc i = x" and - "(s \ r)\<^sup>@Suc i = y" and + "(r \ s)\<^sup>@i = x" and + "(s \ r)\<^sup>@i = y" and "(r \ s)\<^sup>@n \ r = z" and - "s \ \" and "primitive (r \ s)" -proof - - from \x \ \\ obtain i where "(\ x)\<^sup>@(Suc i) = x".. - also have "z \p x\<^sup>\" using prefI[OF \x \ z = z \ y\[symmetric]] \x \ \\.. - finally have "z \p (\ x)\<^sup>\" by (elim per_drop_exp) - then obtain n r where "(\ x)\<^sup>@n \ r = z" and "r

x".. - from \r

x\ obtain s where "r \ s = \ x" and "s \ \".. - define j where "j = Suc i" - have x: "(r\s)\<^sup>@j = x" unfolding \r \ s = \ x\ \j = Suc i\ \(\ x)\<^sup>@(Suc i) = x\.. + "s \ \" and "0 < i" and "primitive (r \ s)" + proof - + obtain i where "(\ x)\<^sup>@i = x" "0 < i" + using primroot_expE by blast + have "z

z" using prefI[OF \x \ z = z \ y\[symmetric]] \x \ \\.. + from per_root_primroot[OF this] + have "z

x) \ z". + from per_root_modE[OF this] + obtain n r s where "r \ s = \ x" "\ x \<^sup>@ n \ r = z" "s \ \". + have x: "(r\s)\<^sup>@i = x" unfolding \r \ s = \ x\ \(\ x)\<^sup>@i = x\.. have z: "(r\s)\<^sup>@n \ r = z" unfolding \r \ s = \ x\ using \(\ x)\<^sup>@n \ r = z\. - have y: "y = (s\r)\<^sup>@j" - using eq[symmetric, folded x z, unfolded lassoc pows_comm[of _ j], unfolded rassoc cancel, - unfolded shift_pow cancel]. + have y [symmetric]: "y = (s\r)\<^sup>@i" + using eq[symmetric, folded x z, unfolded lassoc pows_comm[of _ i], unfolded rassoc cancel, + unfolded shift_pow cancel]. from \x \ \\ have "primitive (r \ s)" unfolding \r \ s = \ x\.. - with that x y z \s \ \\ show thesis unfolding \j = Suc i\ by blast + from that[OF x y z \s \ \\ \0 < i\ this] + show thesis. qed lemma conjugI1 [intro]: assumes eq: "u \ r = r \ v" shows "u \ v" proof (cases) assume "u = \" have "v = \" using eq unfolding \u = \\ by simp show "u \ v" unfolding \u = \\ \v = \\ using conjug_refl. next assume "u \ \" show "u \ v" using eq \u \ \\ by (cases rule: conjug_eqE, intro conjugI) qed -lemma pow_conjug_conjug_conv: assumes "k \ 0" shows "u\<^sup>@k \ v\<^sup>@k \ u \ v" -proof +lemma pow_conjug_conjug_conv: assumes "0 < k" shows "u\<^sup>@k \ v\<^sup>@k \ u \ v" +proof assume "u \<^sup>@ k \ v \<^sup>@ k" - obtain r s where "r \ s = u\<^sup>@k" and "s \ r = v\<^sup>@k" + obtain r s where "r \ s = u\<^sup>@k" and "s \ r = v\<^sup>@k" using conjugE[OF \u\<^sup>@k \ v\<^sup>@k\]. hence "v\<^sup>@k = (rotate \<^bold>|r\<^bold>| u)\<^sup>@k" - using rotate_append rotate_pow_comm by metis + using rotate_append rotate_pow_comm by metis hence "v = rotate \<^bold>|r\<^bold>| u" - using pow_eq_eq[OF _ \k \ 0\] by blast + using pow_eq_eq[OF _ \0 < k\] by blast thus "u \ v" using rotate_conjug by blast next assume "u \ v" - obtain r s where "u = r \ s" and "v = s \ r" + obtain r s where "u = r \ s" and "v = s \ r" using conjugE[OF \u \ v\] by metis have "u\<^sup>@k \ r = r \ v\<^sup>@k" unfolding \u = r \ s\ \v = s \ r\ shift_pow.. - thus "u\<^sup>@k \ v\<^sup>@k" - using conjugI1 by blast + thus "u\<^sup>@k \ v\<^sup>@k" + using conjugI1 by blast qed lemma conjug_trans [trans]: assumes uv: "u \ v" and vw: "v \ w" shows "u \ w" using assms unfolding conjug_rotate_iff using rotate_rotate by blast lemma conjug_trans': assumes uv': "u \ r = r \ v" and vw': "v \ s = s \ w" shows "u \ (r \ s) = (r \ s) \ w" proof - have "u \ (r \ s) = (r \ v) \ s" unfolding uv'[symmetric] rassoc.. also have "\ = r \ (s \ w)" unfolding vw'[symmetric] rassoc.. finally show "u \ (r \ s) = (r \ s) \ w" unfolding rassoc. qed +text\Of course, conjugacy is an equivalence relation.\ +lemma conjug_equiv: "equivp (\)" + by (simp add: conjug_refl conjug_sym conjug_trans equivpI reflpI sympI transpI) + lemma rotate_fac_pref: assumes "u \f w" obtains w' where "w' \ w" and "u \p w'" proof- from facE[OF \u \f w\] obtain p s where "w = p \ u \ s". from that[OF conjugI'[of "u \ s" p, unfolded rassoc, folded this] triv_pref] show thesis. qed lemma rotate_into_pos_sq: assumes "s\p \f w\w" and "\<^bold>|s\<^bold>| \ \<^bold>|w\<^bold>|" and "\<^bold>|p\<^bold>| \ \<^bold>|w\<^bold>|" obtains w' where "w \ w'" "p \p w'" "s \s w'" proof- obtain pw where "pw\s\p \p w\w" by (meson assms(1) fac_pref) hence "pw \ s \p w\ w" unfolding lassoc prefix_def by force hence "take \<^bold>|pw \ s\<^bold>| (w \ w) = pw \ s" - using pref_take by blast + using pref_take by blast have "p \p drop \<^bold>|pw \ s\<^bold>| (w \ w)" using pref_drop[OF \pw\s\p \p w\w\[unfolded lassoc]] drop_pref by metis let ?w = "rotate \<^bold>|pw \ s\<^bold>| w" - have "\<^bold>|?w\<^bold>| = \<^bold>|w\<^bold>|" by auto + have "\<^bold>|?w\<^bold>| = \<^bold>|w\<^bold>|" by auto have "rotate \<^bold>|pw \ s\<^bold>| (w \ w) = ?w \ ?w" - using rotate_pow_comm_two. + using rotate_pow_comm_two. hence eq: "?w \ ?w = (drop \<^bold>|pw \ s\<^bold>| (w \ w)) \ take \<^bold>|pw \ s\<^bold>| (w \ w)" - by (metis \pw \ s \p w \ w\ append_take_drop_id pref_take rotate_append) - - have "p \p ?w" + by (metis \pw \ s \p w \ w\ append_take_drop_id pref_take rotate_append) + + have "p \p ?w" using pref_prod_le[OF _ \\<^bold>|p\<^bold>| \ \<^bold>|w\<^bold>|\[folded \\<^bold>|?w\<^bold>| = \<^bold>|w\<^bold>|\]] prefix_prefix[OF \p \p drop \<^bold>|pw \ s\<^bold>| (w \ w)\, of "take \<^bold>|pw \ s\<^bold>| (w \ w)", folded eq]. - - have "s \s ?w" + + have "s \s ?w" using pref_prod_le[reversed, OF _ \\<^bold>|s\<^bold>| \ \<^bold>|w\<^bold>|\[folded \\<^bold>|?w\<^bold>| = \<^bold>|w\<^bold>|\], of ?w] - unfolding eq \take \<^bold>|pw \ s\<^bold>| (w \ w) = pw \ s\ lassoc by blast + unfolding eq \take \<^bold>|pw \ s\<^bold>| (w \ w) = pw \ s\ lassoc by blast show thesis using that[OF rotate_conjug \p \p ?w\ \s \s ?w\]. qed lemma rotate_into_pref_sq: assumes "p \f w\w" and "\<^bold>|p\<^bold>| \ \<^bold>|w\<^bold>|" obtains w' where "w \ w'" "p \p w'" - using rotate_into_pos_sq[of \, unfolded clean_emp, OF \p \f w\w\ _ \\<^bold>|p\<^bold>| \ \<^bold>|w\<^bold>|\] by auto + using rotate_into_pos_sq[of \, unfolded emp_simps, OF \p \f w\w\ _ \\<^bold>|p\<^bold>| \ \<^bold>|w\<^bold>|\] by auto lemmas rotate_into_suf_sq = rotate_into_pref_sq[reversed] lemma rotate_into_pos: assumes "s\p \f w" obtains w' where "w \ w'" "p \p w'" "s \s w'" proof(rule rotate_into_pos_sq) show "s\p \f w\w" using \s \ p \f w\ by blast - show "\<^bold>|s\<^bold>| \ \<^bold>|w\<^bold>|" + show "\<^bold>|s\<^bold>| \ \<^bold>|w\<^bold>|" using order.trans[OF pref_len' fac_len[OF \s \ p \f w\] ]. show "\<^bold>|p\<^bold>| \ \<^bold>|w\<^bold>|" using order.trans[OF suf_len' fac_len[OF \s \ p \f w\]]. qed lemma rotate_into_pos_conjug: assumes "w \ v" and "s\p \f v" obtains w' where "w \ w'" "p \p w'" "s \s w'" - using assms conjug_trans rotate_into_pos by metis + using assms conjug_trans rotate_into_pos by metis lemma nconjug_neq: "\ u \ v \ u \ v" by blast lemma prim_conjug: assumes prim: "primitive u" and conjug: "u \ v" shows "primitive v" proof - have "v \ \" using prim_nemp[OF prim] unfolding conjug_nemp_iff[OF conjug]. from conjug[symmetric] obtain t where "v \ t = t \ u".. from this \v \ \\ obtain r s i where - v: "(r \ s)\<^sup>@(Suc i) = v" and u: "(s \ r)\<^sup>@(Suc i) = u" and prim': "primitive (r \ s)".. - have "r \ s = v" using v unfolding prim_exp_one[OF prim u] pow_one'. + v: "(r \ s)\<^sup>@i = v" and u: "(s \ r)\<^sup>@i = u" and prim': "primitive (r \ s)" and "0 < i".. + have "r \ s = v" using v unfolding prim_exp_one[OF prim u] pow_1. show "primitive v" using prim' unfolding \r \ s = v\. qed lemma conjug_prim_iff: assumes "u \ v" shows "primitive u = primitive v" using prim_conjug[OF _ \u \ v\] prim_conjug[OF _ conjug_sym[OF \u \ v\]].. +lemmas conjug_prim_iff' = conjug_prim_iff[OF conjugI'] + lemmas conjug_concat_prim_iff = conjug_concat_conjug[THEN conjug_prim_iff] +lemma conjug_eq_primrootE [elim, consumes 2]: + assumes eq: "x \ z = z \ y" and "x \ \" + obtains r s i n where + "(r \ s)\<^sup>@i = x" and + "(s \ r)\<^sup>@i = y" and + "(r \ s)\<^sup>@n \ r = z" and + "s \ \" and "0 < i" and "primitive (r \ s)" + and "primitive (s \ r)" + using conjug_eq_primrootE'[OF assms] conjug_prim_iff' by metis + + +lemma conjug_primrootsE: assumes "\ p \ \ q" + obtains r s k l where "p = (r \ s)\<^sup>@k" and "q = (s \ r)\<^sup>@l" and "primitive (r\s)" +proof(cases) + assume "p = \ \ q = \" + obtain w::"'a list" where "primitive w" + by blast + from that[of w \ 0 0, unfolded emp_simps] + show ?thesis + by (simp add: \p = \ \ q = \\ \primitive w\) +next + assume "\ (p = \ \ q = \)" + hence "primitive (\ p)" + using assms conjug_prim_iff by auto + from conjugE[OF \\ p \ \ q\] + obtain r s where + "r \ s = \ p" and + "s \ r = \ q". + from that[of r s "e\<^sub>\ p" "e\<^sub>\ q", unfolded this, OF _ _ \primitive (\ p)\] + show ?thesis + using primroot_exp_eq[symmetric] + by blast +qed + lemma root_conjug: "u \p r \ u \ u\\<^sup>>(r\u) \ r" using conjugI1 conjug_sym lq_pref by metis -lemmas conjug_prim_iff_pref = conjug_prim_iff[OF root_conjug] +lemmas conjug_prim_iff_pref = conjug_prim_iff[OF root_conjug] lemma conjug_primroot_word: - assumes conjug: "u \ t = t \ v" and "u \ \" + assumes conjug: "u \ t = t \ v" shows "(\ u) \ t = t \ (\ v)" -proof - +proof (cases "u = \") + assume "u \ \" from \u \ t = t \ v\ \u \ \\ obtain r s i n where - u: "(r \ s)\<^sup>@(Suc i) = u" and v: "(s \ r)\<^sup>@(Suc i) = v" and prim: "primitive (r \ s)" - and "(r \ s)\<^sup>@n \ r = t".. + u: "(r \ s)\<^sup>@i = u" and v: "(s \ r)\<^sup>@i = v" and prim: "primitive (r \ s)" + and "(r \ s)\<^sup>@n \ r = t" and "0 < i".. have rs: "\ u = r \ s" and sr: "\ v = s \ r" - using prim prim_conjug u v by blast+ + using prim_conjug[OF prim conjugI'] u v \0 < i\ prim + primroot_unique' by meson+ show ?thesis unfolding \(r \ s)\<^sup>@n \ r = t\[symmetric] rs sr by comparison +next + assume "u = \" + hence "v = \" + using assms by force + show ?thesis + unfolding \u = \\ \v = \\ by simp qed lemma conjug_primroot: assumes "u \ v" - shows "\ u \ \ v" + shows "\ u \ \ v" proof(cases) assume "u = \" with \u \ v\ show "\ u \ \ v" - using conjug_nemp_iff by blast + using conjug_nemp_iff by blast next assume "u \ \" from \u \ v\ obtain t where "u \ t = t \ v".. - from conjug_primroot_word[OF this \u \ \\] + from conjug_primroot_word[OF this] show "\ u \ \ v" - by (simp add: conjugI1) + by (simp add: conjugI1) +qed + +lemma conjug_primroots_nemp: assumes "x \ y \ y \ x" and "r \ s = \ (x \ y)" and "s \ r = \ (y \ x)" + shows "r \ \" and "s \ \" +proof- + have "x \ y \ \" and "y \ x \ \" + using assms(1) by force+ + have "r \ \ \ s \ \" + proof (rule contrapos_np[OF assms(1)]) + assume "\ (r \ \ \ s \ \)" + hence "\ (x \ y) = \ (y \ x)" + using assms(2-3) by force + with comm_primroots[symmetric, OF \x \ y \ \\ \y \ x \ \\] + show "x \ y = y \ x" + using eqd_eq[OF _ swap_len] by meson + qed + thus "r \ \" and "s \ \" + by blast+ +qed + +lemma conjugE_primrootsE[elim]: assumes "x \ y \ y \ x" + obtains r s where "r \ s = \ (x \ y)" and "s \ r = \ (y \ x)" and "r \ \" and "s \ \" +proof- + have "\ (x \ y) \ \" + using assms by force + from conjugE_nemp[OF conjug_primroot[OF conjugI', of x y] this] conjug_primroots_nemp[OF assms] that + show thesis + by auto qed lemma conjug_add_exp: "u \ v \ u\<^sup>@k \ v\<^sup>@k" by (elim conjugE1, intro conjugI1, rule conjug_pow) lemma conjug_primroot_iff: assumes nemp:"u \ \" and len: "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|" shows "\ u \ \ v \ u \ v" proof show "u \ v \ \ u \ \ v" using conjug_primroot. assume conjug: "\ u \ \ v" have "v \ \" using nemp_len[OF nemp] unfolding len length_0_conv. with nemp obtain k l where roots: "(\ u)\<^sup>@k = u" "(\ v)\<^sup>@l = v" - using primrootE primroot_is_primroot by metis + using primroot_exp_eq by blast + have "\<^bold>|(\ u)\<^sup>@k\<^bold>| = \<^bold>|(\ v)\<^sup>@l\<^bold>|" using len unfolding roots. then have "k = l" using primroot_nemp[OF \v \ \\] unfolding pow_len conjug_len[OF conjug] by simp show "u \ v" using conjug_add_exp[OF conjug, of l] unfolding roots[unfolded \k = l\]. qed +lemma two_conjugs_aux: assumes "u\v = x\y" and "v\u = y\x" and "u \ \" and "u \ x" and "\<^bold>|u\<^bold>| \ \<^bold>|x\<^bold>|" + obtains r s k l m n where + "u = (s \ r)\<^sup>@k \ s" and "v = (r \ s)\<^sup>@l \ r" and + "x = (s \ r)\<^sup>@m \ s" and "y = (r \ s)\<^sup>@n \ r" and + "primitive (r \ s)" and "primitive (s \ r)" +proof- + have "\<^bold>|u\<^bold>| < \<^bold>|x\<^bold>|" + using \u \ x\ eqd_eq(1)[OF \u\v = x\y\] le_neq_implies_less[OF \\<^bold>|u\<^bold>| \ \<^bold>|x\<^bold>|\] by blast + hence "x \ \" + by force + from eqd_lessE[OF \u\v = x\y\ \\<^bold>|u\<^bold>| < \<^bold>|x\<^bold>|\] + obtain t where "u \ t = x" "t \ y = v" "t \ \". + from \v\u = y\x\[folded this(1-2)] + obtain exp where "y \ u = (\ t)\<^sup>@exp" + using comm_primroot_exp[OF \t \ \\, of "y \ u"] unfolding rassoc by metis + hence "0 < exp" + using \u \ \\ by blast + from split_pow[OF \y \ u = (\ t)\<^sup>@exp\ this \u \ \\] + obtain r s n k where "u = (s \ r)\<^sup>@k \ s" "y = (r \ s)\<^sup>@n \ r" "r \ s = \ t" + by metis + have "primitive (r \ s)" + unfolding \r \ s = \ t\ using \t \ \\ by blast + hence "primitive (s \ r)" + using conjug_prim_iff' by blast + define e where "e = e\<^sub>\ t" + have t: "t = (r\s)\<^sup>@e" + unfolding \r \ s = \ t\ e_def by simp + have eq1: "t \ (r \ s) \<^sup>@ n \ r = (r \ s) \<^sup>@ (e\<^sub>\ t + n) \ r" + unfolding add_exps \r \ s = \ t\ primroot_exp_eq rassoc.. + have eq2: "((s \ r) \<^sup>@ k \ s) \ t = (s \ r) \<^sup>@ (k + e) \ s" + unfolding t by comparison + show thesis + using that[OF \u = (s \ r)\<^sup>@k \ s\ _ _ \y = (r \ s)\<^sup>@n \ r\ \primitive (r \ s)\ \primitive (s \ r)\, + folded \u \ t = x\ \t \ y = v\, unfolded \u = (s \ r)\<^sup>@k \ s\ \y = (r \ s)\<^sup>@n \ r\, OF eq1 eq2]. +qed + +lemma two_conjugs: assumes "u\v = x\y" and "v\u = y\x" and "u \ \" and "x \ \" and "u \ x" + obtains r s k l m n where + "u = (s \ r)\<^sup>@k \ s" and "v = (r \ s)\<^sup>@l \ r" and + "x = (s \ r)\<^sup>@m \ s" and "y = (r \ s)\<^sup>@n \ r" and + "primitive (r \ s)" and "primitive (s \ r)" + by (rule le_cases[of "\<^bold>|u\<^bold>|" "\<^bold>|x\<^bold>|"], + use two_conjugs_aux[OF assms(1-3,5)] in metis) + (use two_conjugs_aux[OF assms(1-2)[symmetric] assms(4) assms(5)[symmetric]] in metis) + lemma fac_pow_pref_conjug: assumes "u \f t\<^sup>@k" obtains t' where "t \ t'" and "u \p t'\<^sup>@k" -proof (cases "u = \") - assume "u \ \" +proof (cases "t = \") + assume "t \ \" obtain p q where eq: "p \ u \ q = t\<^sup>@k" using facE'[OF assms]. - obtain i r where "i < k" and "r

@i \ r = p" - using pref_mod_power[OF sprefI1'[OF eq pref_nemp[OF \u \ \\]]]. + obtain i r where "i \ k" and "r

@i \ r = p" + using pref_mod_pow[OF prefI[OF eq] \t \\\]. from \r

obtain s where t: "r \ s = t".. have eq': "t\<^sup>@i \ r \ (u \ q) = t\<^sup>@k" using eq unfolding lassoc p. have "u \p (s \ r)\<^sup>@k" using pow_conjug[OF eq' t] unfolding rassoc.. with conjugI'[of r s] show thesis unfolding t.. -qed blast +qed (use assms in auto) 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 \f v\<^sup>@k" shows "v \ u" proof- obtain t where "v \ t" and "u \p t\<^sup>@k" - using fac_pow_pref_conjug assms by blast + using fac_pow_pref_conjug[OF \u \f v \<^sup>@ k\]. have "u = t" - using pref_equal[OF pref_prod_root[OF \u \p t\<^sup>@k\] conjug_len[OF \v \ t\,folded \\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|\]]. + using pref_prod_eq[OF pref_prod_root[OF \u \p t\<^sup>@k\] conjug_len[OF \v \ t\,folded \\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|\]]. from \v \ t\[folded this] show "v \ u". qed lemma conjug_fac_sq: "u \ v \ u \f v \ v" by (elim conjugE, unfold eq_commute[of "_ \ _"]) (intro facI', simp) lemma conjug_fac_pow_conv: assumes "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|" and "2 \ k" shows "u \ v \ u \f v\<^sup>@k" proof assume "u \ v" have f: "v \ v \f v \<^sup>@k" - using \2 \ k\ unfolding pow_two[symmetric] using le_exps_pref by blast - from fac_trans[OF conjug_fac_sq[OF \u \ v\] this] + using \2 \ k\ unfolding pow_two[symmetric] using le_exps_pref by blast + from fac_trans[OF conjug_fac_sq[OF \u \ v\] this] show "u \f v \<^sup>@ k". next show " u \f v \<^sup>@ k \ u \ v" using fac_pow_len_conjug[OF \\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|\, THEN conjug_sym]. qed -lemma fac_pow_conjug: assumes "u \f v\<^sup>@k" and "t \ v" +lemma conjug_fac_Suc: assumes "t \ v" + shows "t\<^sup>@k \f v\<^sup>@Suc k" +proof- + obtain r s where "v = r \ s" and "t = s \ r" + using \t \ v\ by blast + show ?thesis + unfolding \v = r \ s\ \t = s \ r\ + unfolding pow_slide[of r s k, symmetric] + by force +qed + +lemma fac_pow_conjug: assumes "u \f v\<^sup>@k" and "t \ v" shows "u \f t\<^sup>@Suc k" proof- obtain r s where "v = r \ s" and "t = s \ r" using \t \ v\ by blast - have "s \ v\<^sup>@k \ r = t\<^sup>@Suc k" + have "s \ v\<^sup>@k \ r = t\<^sup>@Suc k" unfolding \v = r \ s\ \t = s \ r\ shift_pow pow_Suc rassoc.. from facI[of "v\<^sup>@k" s r, unfolded this] show "u \f t\<^sup>@Suc k" - using \u \f v\<^sup>@k\ by blast + using \u \f v\<^sup>@k\ by blast qed lemma border_conjug: "x \b w \ w\<^sup><\x \ x\\<^sup>>w" using border_conjug_eq conjugI1 by blast lemma count_list_conjug: assumes "u \ v" shows "count_list u a = count_list v a" proof- from conjugE[OF \u \ v\] obtain r s where "r \ s = u" "s \ r = v". show "count_list u a = count_list v a" - unfolding \r \ s = u\[symmetric] \s \ r = v\[symmetric] count_list_append by presburger -qed - -lemma conjug_in_lists: "us \ vs \ vs \ lists A \ us \ lists A" + unfolding \r \ s = u\[symmetric] \s \ r = v\[symmetric] count_list_append by presburger +qed + +lemma conjug_in_lists: "us \ vs \ vs \ lists A \ us \ lists A" unfolding conjugate_def by auto -lemma conjug_in_lists': "us \ vs \ us \ lists A \ vs \ lists A" +lemma conjug_in_lists': "us \ vs \ us \ lists A \ vs \ lists A" unfolding conjugate_def by auto -lemma conjug_in_lists_iff: "us \ vs \ us \ lists A \ vs \ lists A" +lemma conjug_in_lists_iff: "us \ vs \ us \ lists A \ vs \ lists A" unfolding conjugate_def by auto -lemma two_conjugs_imprim: assumes "u \ v = r \ s" and "v \ u = s \ r" and "u \ \" and "v \ \" and "u \ r" - shows "\ primitive (u \ v)" + +lemma prim_conjug_unique: assumes "primitive (u \ v)" and "u \ v = r \ s" and "v \ u = s \ r" and "u \ v \ v \ u" + shows "u = r" and "v = s" proof- - consider (u_pref_r) "u

u \ r\ prefix_append \u \ v = r \ s\ prefI strict_prefixI by metis - thus "\ primitive (u \ v)" - proof (cases) - case u_pref_r - hence "(u\\<^sup>>r) \ (s \ u) = v \ u" - using lq_pref_cancel[OF sprefD1 \u \ v = r \ s\[symmetric]] by auto - have "(s \ u) \ (u\\<^sup>>r) = v \ u" - unfolding rassoc - using \v \ u = s \ r\ lq_pref sprefD[OF u_pref_r] by (auto simp add: prefix_def) - from comm_not_prim[OF lq_spref[OF u_pref_r] _ \(u\\<^sup>>r) \ (s \ u) = v \ u\[folded this]] - have "\ primitive (v \ u)" - unfolding \(u\\<^sup>>r) \ (s \ u) = v \ u\ using \u \ \\ by blast - thus "\ primitive (u \ v)" - using prim_conjug by auto - next - case r_pref_u - hence "(r\\<^sup>>u) \ (v \ r) = s \ r" - using \u \ v = r \ s\ by (auto simp add: prefix_def) - have "(v \ r) \ (r\\<^sup>>u) = s \ r" - unfolding rassoc - using \v \ u = s \ r\ lq_pref sprefD[OF r_pref_u] by (auto simp add: prefix_def) - from comm_not_prim[OF lq_spref[OF r_pref_u] _ \(r\\<^sup>>u) \ (v \ r) = s \ r\[folded this]] - have "\ primitive (v \ u)" - unfolding \(r\\<^sup>>u) \ (v \ r) = s \ r\ \v \ u = s \ r\ using \v \ \\ by blast - thus "\ primitive (u \ v)" - using prim_conjug by auto + have "u = r" if "primitive (u \ v)" and "u \ v = r \ s" and "v \ u = s \ r" and "u \ v \ v \ u" and "\<^bold>|v\<^bold>| \ \<^bold>|s\<^bold>|" for u v r s :: "'a list" + proof- + from eqdE[OF \v \ u = s \ r\ \\<^bold>|v\<^bold>| \ \<^bold>|s\<^bold>|\] + obtain t where "v \ t = s" "t \ r = u". + have "t \ (r \ v) = (r \ v) \ t" + unfolding lassoc \t \ r = u\ unfolding rassoc \v \ t = s\ by fact + from comm_not_prim[OF _ _ this, unfolded lassoc \t \ r = u\] + have "t = \" + using \primitive (u \ v)\ \u \ v \ v \ u\ by blast + thus "u = r" + using \t \ r = u\ by force qed -qed - -lemma prim_conjugE: assumes "(u \ v) \ z = z \ (v \ u)" and "primitive (u \ v)" - obtains k where "(u \ v)\<^sup>@k \ u = z" | "u \ \" and "v = \" and "z = \" + from this[OF assms] + this[OF \primitive (u \ v)\[unfolded \u \ v = r \ s\] assms(2-3)[symmetric] assms(4)[unfolded \u \ v = r \ s\ \v \ u = s \ r\]] + show "u = r" + by fastforce + thus "v = s" + using \u \ v = r \ s\ by fast +qed + +lemma prim_conjugE[elim, consumes 3]: assumes "(u \ v) \ z = z \ (v \ u)" and "primitive (u \ v)" and "v \ \" + obtains k where "(u \ v)\<^sup>@k \ u = z" proof- from conjug_eqE[OF assms(1) prim_nemp[OF assms(2)]] - obtain x y m where "x \ y = u \ v" and "y \ x = v \ u" and "(x \ y)\<^sup>@m \ x = z" and "y \ \". - from two_conjugs_imprim[OF \x \ y = u \ v\[symmetric] \y \ x = v \ u\[symmetric] ] \primitive (u \ v)\ - consider "u = \" | "v = \" | "u = x" by blast + obtain x y m where "x \ y = u \ v" and "y \ x = v \ u" and "(x \ y)\<^sup>@m \ x = z" and "y \ \". + from prim_conjug_unique[OF \primitive (u \ v)\ \x \ y = u \ v\[symmetric] \y \ x = v \ u\[symmetric]] + consider "u \ v = v \ u" | "u = x \ v = y" by blast thus thesis proof (cases) - assume "u = \" - hence "v \ \" using \primitive (u \ v)\ by fastforce + assume "u \ v = v \ u" + from comm_not_prim[OF _ \v \ \\ this] \primitive (u \ v)\ + have "u = \" by blast + from \(u \ v) \ z = z \ (v \ u)\[symmetric] \primitive (u \ v)\ obtain k where "z = (u \ v)\<^sup>@k \ u" - using \(u \ v) \ z = z \ (v \ u)\[symmetric] \primitive (u \ v)\ - unfolding \u = \\ clean_emp using prim_comm_exp by blast - from that(1)[OF this[symmetric]] + unfolding \u = \\ emp_simps by blast + from that[OF this[symmetric]] show thesis. next - assume "v = \" - have "u \ \" and "primitive u" and "z \ u = u \ z" - using \primitive (u \ v)\ \(u \ v) \ z = z \ (v \ u)\[symmetric] - unfolding \v = \\ clean_emp by force+ - show thesis - proof(cases "z = \", simp add: that(2) \v = \\ \u \ \\) - assume "z \ \" - from prim_comm_exp[OF \primitive u\ \z \ u = u \ z\] - obtain k where "u\<^sup>@k = z". - from nemp_pow_SucE[OF \z \ \\ this[symmetric]] - obtain l where "z = (u \ v)\<^sup>@l \ u" - unfolding \v = \\ clean_emp pow_Suc2[symmetric]. - from that(1)[OF this[symmetric]] - show thesis. - qed - next - assume "u = x" - with \x \ y = u \ v\[unfolded this cancel, symmetric] - \(x \ y)\<^sup>@m \ x = z\ that(1) + assume "u = x \ v = y" + with \(x \ y)\<^sup>@m \ x = z\ that show thesis by blast qed qed +lemma prim_conjugE'[elim, consumes 3]: assumes "(r \ s) \ z = z \ (s \ r)" and "primitive (r \ s)" and "z \ \" + obtains k where "(r \ s)\<^sup>@k \ r = z" +proof (cases \s = \\) + assume "s = \" + from assms(1-2)[unfolded this emp_simps] + have "primitive r" and "z \ r = r \ z" by force+ + from prim_comm_exp[OF this] + obtain k where "z = r\<^sup>@k" "0 < k" + using nemp_exp_pos[OF \z \ \\] by metis + have "r\<^sup>@(k-1)\r = z" + unfolding pow_pos'[OF \0 < k\, of r, folded \z = r\<^sup>@k\].. + from that[unfolded \s = \\ emp_simps, OF this] + show thesis. +qed (use prim_conjugE[OF assms(1-2)] in blast) + +lemma conjug_primroots_unique: assumes "x \ y \ y \ x" and + "r \ s = \ (x \ y)" and "s \ r = \ (y \ x)" and + "r' \ s' = \ (x \ y)" and "s' \ r' = \ (y \ x)" + shows "r = r'" and "s = s'" +proof- + have "x \ y \ \" and "y \ x \ \" and "x \ \" and "y \ \" and "(x \ y) \ (y \ x) \ (y \ x) \ (x \ y)" + using \x \ y \ y \ x\ eqd_eq[OF _ swap_len] by blast+ + show "r = r'" + proof (rule prim_conjug_unique(1)) + from primroot_prim[OF \x \ y \ \\, folded \r \ s = \ (x \ y)\] + show "primitive (r \ s)". + from \r \ s = \ (x \ y)\[folded \r' \ s' = \ (x \ y)\] \s \ r = \ (y \ x)\[folded \s' \ r' = \ (y \ x)\] + show "r \ s = r' \ s'" and "s \ r = s' \ r'". + show "r \ s \ s \ r" + unfolding \r \ s = \ (x \ y)\ \s \ r = \ (y \ x)\ + using same_primroots_comm \(x \ y) \ (y \ x) \ (y \ x) \ (x \ y)\ by blast + qed + thus "s = s'" + using \r \ s = \ (x \ y)\[folded \r' \ s' = \ (x \ y)\] by blast +qed + +lemma prim_conjug_pref: assumes "primitive (s \ r)" and "u \ r \ s \p (s \ r)\<^sup>@n" and "r \ \" + obtains n where "(s \ r)\<^sup>@n \ s = u" +proof- + have "u \ r \ s \p (s \ r \ u) \ r \ s" + using pref_prod_root[OF \u \ r \ s \p (s \ r)\<^sup>@n\] unfolding rassoc. + from pref_prod_eq[OF this, unfolded lenmorph] + have "(s \ r) \ u = u \ (r \ s)" + unfolding rassoc by force + from prim_conjugE[OF this \primitive (s \ r)\ \r \ \\] + show thesis + using that. +qed + lemma fac_per_conjug: assumes "period w n" and "v \f w" and "\<^bold>|v\<^bold>| = n" shows "v \ take n w" proof- have "\<^bold>|take n w\<^bold>| = \<^bold>|v\<^bold>|" - using fac_len[OF \v \f w\] \\<^bold>|v\<^bold>| = n\ take_len by blast - from per_pref_ex[OF \period w n\[unfolded period_def]] + using fac_len[OF \v \f w\] \\<^bold>|v\<^bold>| = n\ take_len by blast + from per_root_powE'[OF \period w n\[unfolded period_def]] obtain k where "w \p take n w \<^sup>@ k". - from fac_pow_len_conjug[OF \\<^bold>|take n w\<^bold>| = \<^bold>|v\<^bold>|\[symmetric], THEN conjug_sym] + from fac_pow_len_conjug[OF \\<^bold>|take n w\<^bold>| = \<^bold>|v\<^bold>|\[symmetric], THEN conjug_sym] fac_trans[OF \v \f w\ pref_fac, OF this] - show ?thesis. + show ?thesis. qed lemma fac_pers_conjug: assumes "period w n" and "v \f w" and "\<^bold>|v\<^bold>| = n" and "u \f w" and "\<^bold>|u\<^bold>| = n" - shows "v \ u" + shows "v \ u" using conjug_trans[OF fac_per_conjug[OF \period w n\ \v \f w\ \\<^bold>|v\<^bold>| = n\] conjug_sym[OF fac_per_conjug[OF \period w n\ \u \f w\ \\<^bold>|u\<^bold>| = n\]]]. -lemma conjug_pow_powE: assumes "w \ r\<^sup>@k" obtains s where "w = s\<^sup>@k" +lemma conjug_pow_powE: assumes "w \ r\<^sup>@k" obtains s where "w = s\<^sup>@k" proof- obtain u v where "w = u \ v" and "v \ u = r\<^sup>@k" - using assms by blast + using assms by blast have "w = (v\\<^sup>>(r\v))\<^sup>@k" unfolding \w = u \ v\ lq_conjug_pow[OF pref_prod_root, OF prefI[OF \v \ u = r \<^sup>@ k\], symmetric] \v \ u = r \<^sup>@ k\[symmetric] by simp from that[OF this] show thesis. -qed - -lemma find_second_letter: assumes "a \ b" and "set ws = {a,b}" - shows "dropWhile (\ c. c = a) ws \ \" and "hd (dropWhile (\ c. c = a) ws) = b" +qed + +lemma find_second_letter: assumes "a \ b" and "set ws = {a,b}" + shows "dropWhile (\ c. c = a) ws \ \" and "hd (dropWhile (\ c. c = a) ws) = b" proof- let ?a = "(\ c. c = a)" - define wsb where "wsb = dropWhile ?a ws \ takeWhile ?a ws" - have "wsb \ ws" - unfolding wsb_def using takeWhile_dropWhile_id[of ?a ws] conjugI' by blast + define wsb where "wsb = dropWhile ?a ws \ takeWhile ?a ws" + have "wsb \ ws" + unfolding wsb_def using takeWhile_dropWhile_id[of ?a ws] conjugI' by blast hence "set wsb = {a,b}" using \set ws = {a,b}\ by (simp add: conjug_set) have "takeWhile ?a ws \ ws" unfolding takeWhile_eq_all_conv using \set ws = {a,b}\ \a \ b\ by simp - thus "dropWhile ?a ws \ \" by simp + thus "dropWhile ?a ws \ \" by simp from hd_dropWhile[OF this] set_dropWhileD[OF hd_in_set[OF this], unfolded \set ws = {a,b}\] show "hd (dropWhile ?a ws) = b" by blast qed lemma fac_conjuq_sq: assumes "u \ v" and "\<^bold>|w\<^bold>| \ \<^bold>|u\<^bold>|" and "w \f u \ u" shows "w \f v \ v" proof - have assm_le: "w \f s \ r \ s \ r" if "p \ w \ q = r \ s \ r \ s" and "\<^bold>|r\<^bold>| \ \<^bold>|p\<^bold>|" for w s r p q :: "'a list" proof - obtain p' where "r \ p' = p" using \p \ w \ q = r \ s \ r \ s\ \\<^bold>|r\<^bold>| \ \<^bold>|p\<^bold>|\ unfolding rassoc by (rule eqdE[OF sym]) show "w \f s \ r \ s \ r" using \p \ w \ q = r \ s \ r \ s\ by (intro facI'[of p' _ "q \ r"]) (simp flip: \r \ p' = p\) qed obtain r s where "r \ s = u" and "s \ r = v" using \u \ v\.. obtain p q where "p \ w \ q = u \ u" using \w \f u \ u\ .. from lenarg[OF this] \\<^bold>|w\<^bold>| \ \<^bold>|u\<^bold>|\ have "\<^bold>|r\<^bold>| \ \<^bold>|p\<^bold>| \ \<^bold>|s\<^bold>| \ \<^bold>|q\<^bold>|" unfolding \r \ s = u\[symmetric] lenmorph by linarith then show "w \f v \ v" using \p \ w \ q = u \ u\ unfolding \r \ s = u\[symmetric] \s \ r = v\[symmetric] by (elim disjE) (simp only: assm_le rassoc, simp only: assm_le[reversed] lassoc) qed lemma fac_conjuq_sq_iff: assumes "u \ v" shows "\<^bold>|w\<^bold>| \ \<^bold>|u\<^bold>| \ w \f u \ u \ w \f v \ v" using fac_conjuq_sq[OF \u \ v\] fac_conjuq_sq[OF \u \ v\[symmetric]] unfolding conjug_len[OF \u \ v\[symmetric]].. lemma map_conjug: "u \ v \ map f u \ map f v" by (elim conjugE, unfold eq_commute[of "_ \ _"]) auto lemma map_conjug_iff [reversal_rule]: assumes "inj f" shows "map f u \ map f v \ u \ v" using map_conjug map_conjug[of "map f u" "map f v" "inv f"] unfolding map_map inv_o_cancel[OF \inj f\] list.map_id by (intro iffI) -lemma switch_fac: assumes "x \ y" and "set ws = {x,y}" shows "[x,y] \f ws \ ws" +lemma card_conjug: assumes "w \ \" + shows "card (Collect (conjugate w)) = \<^bold>|\ w\<^bold>|" proof- - let ?y = "(\ a. a = y)" and ?x = "(\ a. a = x)" - have "ws \ \" - using \set ws = {x,y}\ by force - - define wsx where "wsx = dropWhile ?y ws \ takeWhile ?y ws" - have "wsx \ ws" - unfolding wsx_def using takeWhile_dropWhile_id[of ?y ws] conjugI' by blast - have "set wsx = {x,y}" - unfolding wsx_def using \set ws = {x,y}\ conjugI' conjug_set takeWhile_dropWhile_id by metis - from find_second_letter[OF \x \ y\[symmetric] \set ws = {x,y}\[unfolded insert_commute[of x]]] - have "dropWhile (\c. c = y) ws \ \" and "hd wsx = x" - unfolding wsx_def using hd_append by simp_all - hence "takeWhile ?x wsx \ \" - 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 \x \ y\ \set wsx = {x,y}\] - have "wsx = [x]\<^sup>@k \ [x] \ [hd (dropWhile ?x wsx)] \ tl (dropWhile ?x wsx)" - unfolding lassoc pow_Suc2[symmetric] \takeWhile ?x wsx = [x]\<^sup>@Suc k\[symmetric] - unfolding rassoc hd_tl[OF \dropWhile ?x wsx \ \\] takeWhile_dropWhile_id.. - from this[unfolded \hd (dropWhile ?x wsx) = y\] - have "[x,y] \f wsx" by (auto simp add: fac_def) - thus "[x,y] \f ws \ ws" - using fac_trans[OF _ conjug_fac_sq[OF \wsx \ ws\]] by blast -qed - -lemma imprim_ext_pref_comm: assumes "\ primitive (u \ v)" and "\ primitive (u \ v \ u)" - shows "u \ v = v \ u" -using \\ primitive (u \ v)\ proof (elim not_prim_pow) - fix z n assume "z \<^sup>@ n = u \ v" and "2 \ n" - have "2 * \<^bold>|z\<^bold>| \ \<^bold>|u \ v \ u\<^bold>|" - by (simp add: pow_len \2 \ n\ trans_le_add1 flip: \z\<^sup>@n = u \ v\ rassoc) - moreover have "u \ v \ u \p z \ u \ v \ u" - by (intro pref_prod_root[of _ _ "n + n"]) (simp add: \z \<^sup>@ n = u \ v\ add_exps) - ultimately have "(u \ v \ u) \ z = z \ u \ v \ u" - using \\ primitive (u \ v \ u)\ - by (cases "z = \") (unfold per_le_prim_iff, blast+) - from comm_add_exp[OF this[symmetric], of n] - show "u \ v = v \ u" - unfolding \z \<^sup>@ n = u \ v\ by simp -qed - -lemma imprim_ext_suf_comm: - "\ primitive (u \ v) \ \ primitive (u \ v \ v) \ u \ v = v \ u" - by (intro imprim_ext_pref_comm[symmetric]) - (unfold conjug_prim_iff[OF conjugI', of v] rassoc) - -lemma prim_xyky: assumes "2 \ k" and "\ primitive ((x \ y)\<^sup>@k \ y)" shows "x \ y = y \ x" -proof- - have "k \ 0" using \2 \ k\ by simp - have "(x \ y)\<^sup>@k = (x \ y)\<^sup>@(k - 1) \ x \ y" - unfolding rassoc pow_Suc2[symmetric] Suc_minus[OF \k \ 0\].. - have "(x \ y)\<^sup>@k \ y = ((x \ y)\<^sup>@(k -1) \ x) \ y \ y" - unfolding lassoc cancel_right unfolding rassoc pow_Suc2[symmetric] Suc_minus[OF \k \ 0\].. - from imprim_ext_suf_comm[OF _ \\ primitive ((x \ y)\<^sup>@k \ y)\[unfolded this], - unfolded rassoc pow_Suc2[symmetric] Suc_minus[OF \k \ 0\], OF pow_nemp_imprim[OF \2 \ k\]] - show "x \ y = y \ x" - unfolding \(x \ y)\<^sup>@k = (x \ y)\<^sup>@(k -1) \ x \ y\ shift_pow - pow_Suc2[of "x \ y", unfolded rassoc, symmetric] pow_Suc[of "y \ x", unfolded rassoc, symmetric] - using pow_eq_eq by blast -qed + define f where "f = (\n. rotate n w)" + + have "\ w \ \" + by (simp add: assms primroot_nemp) + obtain k where "(\ w)\<^sup>@k = w" + using primroot_expE + by blast + have "f`{0..<\<^bold>|\ w\<^bold>|} = {w'. w \ w'}" + unfolding set_eq_iff + unfolding mem_Collect_eq conjug_rotate_iff image_iff + unfolding atLeast0LessThan + unfolding f_def + using lessThan_iff rotate_pow_mod[of _ "\ w" k] mod_less_divisor[OF nemp_pos_len[OF \\ w \ \\]] + unfolding \(\ w)\<^sup>@k = w\ + by meson + + have "inj_on f {0..<\<^bold>|\ w\<^bold>|}" + proof (rule inj_onI) + fix x y + assume "x \ {0..<\<^bold>|\ w\<^bold>|}" "y \ {0..<\<^bold>|\ w\<^bold>|}" "f x = f y" + hence roxy: "rotate x (\ w) = rotate y (\ w)" + unfolding f_def + by (metis assms primroot_rotate_comm) + show "x = y" + using prim_no_rotate[OF primroot_prim[OF \w \ \\]] rotate_back'[OF roxy] rotate_back'[OF roxy[symmetric]] \x \ {0..<\<^bold>|\ w\<^bold>|}\ \y \ {0..<\<^bold>|\ w\<^bold>|}\ + unfolding atLeast0LessThan lessThan_iff + using bot_nat_0.not_eq_extremum less_imp_diff_less nat_le_linear zero_diff_eq by metis + qed + from card_image[OF this] + show ?thesis + unfolding \f ` {0..<\<^bold>|\ w\<^bold>|} = {w'. w \ w'}\ + unfolding atLeast0LessThan card_lessThan. +qed + +lemma finite_Bex_conjug: assumes "finite A" + shows "finite {r. Bex A (conjugate r)}" + unfolding finite_Collect_bex[OF \finite A\, of conjugate] +proof + fix y + assume "y \ A" + show "finite {r. r \ y}" + proof(cases "y = \") + case True + then show ?thesis + unfolding conjug_swap[of _ y] + by (metis (mono_tags, opaque_lifting) \y \ A\ assms conjug_nemp_iff finite_subset mem_Collect_eq subset_eq) + next + case False + then show ?thesis + unfolding conjug_swap[of _ y] + by (simp add: card_conjug card_ge_0_finite primroot_nemp) + qed +qed subsection \Enumerating conjugates\ -definition bounded_conjug +definition bounded_conjug where "bounded_conjug w' w k \ (\ n \ k. w = rotate n w')" named_theorems bounded_conjug lemma[bounded_conjug]: "bounded_conjug w' w 0 \ w = w'" unfolding bounded_conjug_def by auto lemma[bounded_conjug]: "bounded_conjug w' w (Suc k) \ bounded_conjug w' w k \ w = rotate (Suc k) w'" unfolding bounded_conjug_def using le_SucE le_imp_less_Suc le_less by metis lemma[bounded_conjug]: "w' \ w \ bounded_conjug w w' (\<^bold>|w\<^bold>|-1)" unfolding bounded_conjug_def conjug_swap[of w'] using conjug_rotate_iff_le. lemma "w \ [a,b,c] \ w = [a,b,c] \ w = [b,c,a] \ w = [c,a,b]" by (simp add: bounded_conjug) +subsection \General lemmas using conjugation\ + +lemma switch_fac: assumes "x \ y" and "set ws = {x,y}" shows "[x,y] \f ws \ ws" +proof- + let ?y = "(\ a. a = y)" and ?x = "(\ a. a = x)" + have "ws \ \" + using \set ws = {x,y}\ by force + + define wsx where "wsx = dropWhile ?y ws \ takeWhile ?y ws" + have "wsx \ ws" + unfolding wsx_def using takeWhile_dropWhile_id[of ?y ws] conjugI' by blast + have "set wsx = {x,y}" + unfolding wsx_def using \set ws = {x,y}\ conjugI' conjug_set takeWhile_dropWhile_id by metis + from find_second_letter[OF \x \ y\[symmetric] \set ws = {x,y}\[unfolded insert_commute[of x]]] + have "dropWhile (\c. c = y) ws \ \" and "hd wsx = x" + unfolding wsx_def using hd_append by simp_all + hence "takeWhile ?x wsx \ \" + unfolding wsx_def takeWhile_eq_Nil_iff by blast + from root_nemp_expE[OF takeWhile_sing_root[of x wsx] this] + obtain k where [symmetric]: "[x]\<^sup>@k = takeWhile ?x wsx" and "0 < k". + note find_second_letter[OF \x \ y\ \set wsx = {x,y}\] + have "wsx = [x]\<^sup>@(k - 1) \ [x] \ [hd (dropWhile ?x wsx)] \ tl (dropWhile ?x wsx)" + unfolding lassoc pow_pos'[OF \0 < k\,symmetric] \takeWhile ?x wsx = [x]\<^sup>@k\[symmetric] + unfolding rassoc hd_tl[OF \dropWhile ?x wsx \ \\] takeWhile_dropWhile_id.. + from this[unfolded \hd (dropWhile ?x wsx) = y\] + have "[x,y] \f wsx" by (auto simp add: fac_def) + thus "[x,y] \f ws \ ws" + using fac_trans[OF _ conjug_fac_sq[OF \wsx \ ws\]] by blast +qed + +lemma imprim_ext_pref_comm: assumes "\ primitive (u \ v)" and "\ primitive (u \ v \ u)" + shows "u \ v = v \ u" +using \\ primitive (u \ v)\ proof (elim not_prim_primroot_expE) + fix z n assume "z \<^sup>@ n = u \ v" and "2 \ n" + have "2 * \<^bold>|z\<^bold>| \ \<^bold>|u \ v \ u\<^bold>|" + by (simp add: pow_len \2 \ n\ trans_le_add1 flip: \z\<^sup>@n = u \ v\ rassoc) + moreover have "u \ v \ u \p z \ u \ v \ u" + by (intro pref_prod_root[of _ _ "n + n"]) (simp add: \z \<^sup>@ n = u \ v\ add_exps) + ultimately have "(u \ v \ u) \ z = z \ u \ v \ u" + using \\ primitive (u \ v \ u)\ per_le_prim_iff + by (cases "z = \") blast+ + from comm_add_exp[OF this[symmetric], of n] + show "u \ v = v \ u" + unfolding \z \<^sup>@ n = u \ v\ by simp +qed + +lemma imprim_ext_suf_comm: + "\ primitive (u \ v) \ \ primitive (u \ v \ v) \ u \ v = v \ u" + by (intro imprim_ext_pref_comm[symmetric]) + (unfold conjug_prim_iff[OF conjugI', of v] rassoc) + +lemma prim_xyky: assumes "2 \ k" and "\ primitive ((x \ y)\<^sup>@k \ y)" shows "x \ y = y \ x" +proof- + have "k \ 0" using \2 \ k\ by simp + have "(x \ y)\<^sup>@k = (x \ y)\<^sup>@(k - 1) \ x \ y" + unfolding rassoc pow_Suc'[symmetric] Suc_minus[OF \k \ 0\].. + have "(x \ y)\<^sup>@k \ y = ((x \ y)\<^sup>@(k -1) \ x) \ y \ y" + unfolding lassoc cancel_right unfolding rassoc pow_Suc'[symmetric] Suc_minus[OF \k \ 0\].. + from imprim_ext_suf_comm[OF _ \\ primitive ((x \ y)\<^sup>@k \ y)\[unfolded this], + unfolded rassoc pow_Suc'[symmetric] Suc_minus[OF \k \ 0\], OF pow_nemp_imprim[OF \2 \ k\]] + show "x \ y = y \ x" + unfolding \(x \ y)\<^sup>@k = (x \ y)\<^sup>@(k -1) \ x \ y\ shift_pow + pow_Suc'[of "x \ y", unfolded rassoc, symmetric] pow_Suc[of "y \ x", unfolded rassoc, symmetric] + using pow_eq_eq by blast +qed + +lemma fac_pow_div: assumes "u \f w\<^sup>@l" "primitive w" + shows "w\<^sup>@((\<^bold>|u\<^bold>| div \<^bold>|w\<^bold>|) - 1) \f u" +proof- + obtain w' where + "w \ w'" and + "u \p w' \<^sup>@ l" + using fac_pow_pref_conjug[OF \u \f w\<^sup>@l\]. + + note prim_nemp[OF \primitive w\] + hence "w' \ \" + using conjug_nemp_iff \w \ w'\ by blast + + obtain s where "s

@ (\<^bold>|u\<^bold>| div \<^bold>|w'\<^bold>|) \ s = u" + using per_root_modE'[OF per_rootI', OF \u \p w' \<^sup>@ l\ \w' \ \\]. + + have "w\<^sup>@((\<^bold>|u\<^bold>| div \<^bold>|w\<^bold>|) - 1) \f w' \<^sup>@ (\<^bold>|u\<^bold>| div \<^bold>|w'\<^bold>|)" + unfolding conjug_len[OF \w \ w'\] + using conjug_fac_Suc[OF \w \ w'\] + by (cases "(\<^bold>|u\<^bold>| div \<^bold>|w'\<^bold>|) = 0", force) + (use Suc_minus in metis) + thus ?thesis + using fac_ext_suf[of _ "w' \<^sup>@ (\<^bold>|u\<^bold>| div \<^bold>|w'\<^bold>|)" s, unfolded \w' \<^sup>@ (\<^bold>|u\<^bold>| div \<^bold>|w'\<^bold>|) \ s = u\] + by presburger +qed + section \Element of lists: a method for testing if a word is in lists A\ lemma append_in_lists[simp, intro]: "u \ lists A \ v \ lists A \ u \ v \ lists A" by simp lemma pref_in_lists: "u \p v \ v \ lists A \ u \ lists A" by (auto simp add: prefix_def) lemmas suf_in_lists = pref_in_lists[reversed] -lemma lq_in_lists: "u \p v \ v \ lists A \ u\\<^sup>>v \ lists A" - by (auto simp add: prefix_def) +lemma fac_in_lists: "ws \ lists S \ vs \f ws \ vs \ lists S" + by force + +lemma lq_in_lists: "v \ lists A \ u\\<^sup>>v \ lists A" + unfolding left_quotient_def using fac_in_lists[OF _ sublist_drop]. lemmas rq_in_lists = lq_in_lists[reversed] lemma take_in_lists: "w \ lists A \ take j w \ lists A" - using pref_in_lists[OF take_is_prefix]. + using pref_in_lists[OF take_is_prefix]. lemma drop_in_lists: "w \ lists A \ drop j w \ lists A" using suf_in_lists[OF suffix_drop]. lemma lcp_in_lists: "u \ lists A \ u \\<^sub>p v \ lists A" using pref_in_lists[OF lcp_pref]. lemma lcp_in_lists': "v \ lists A \ u \\<^sub>p v \ lists A" using pref_in_lists[OF lcp_pref']. lemma append_in_lists_dest: "u \ v \ lists A \ u \ lists A" by simp lemma append_in_lists_dest': "u \ v \ lists A \ v \ lists A" by simp lemma pow_in_lists: "u \ lists A \ u\<^sup>@k \ lists A" - by (induct k, simp, unfold pow_Suc, simp) + by (induct k) auto lemma takeWhile_in_list: "u \ lists A \ takeWhile P u \ lists A" using take_in_lists[of u _ "\<^bold>|takeWhile P u\<^bold>|", folded takeWhile_eq_take]. lemma rev_in_lists: "u \ lists A \ rev u \ lists A" by auto -lemma append_in_lists_dest1: "u \ v = w \ w \ lists A \ u \ lists A" +lemma append_in_lists_dest1: "u \ v = w \ w \ lists A \ u \ lists A" by auto lemma append_in_lists_dest2: "u \ v = w \ w \ lists A \ v \ lists A" by auto lemma pow_in_lists_dest1: "u \ v = w\<^sup>@n \ w \ lists A \ u \ lists A" using append_in_lists_dest pow_in_lists by metis lemma pow_in_lists_dest1_sym: "w\<^sup>@n = u \ v \ w \ lists A \ u \ lists A" using append_in_lists_dest pow_in_lists by metis lemma pow_in_lists_dest2: "u \ v = w\<^sup>@n \ w \ lists A \ v \ lists A" using append_in_lists_dest' pow_in_lists by metis lemma pow_in_lists_dest2_sym: "w\<^sup>@n = u \ v \ w \ lists A \ v \ lists A" using append_in_lists_dest' pow_in_lists by metis -lemma per_in_lists: "w \p r \ w \ r \ \ \ r \ lists A \ w \ lists A" - using per_pref[unfolded period_root_def] pow_in_lists[of r A] pref_in_lists by metis +lemma per_in_lists: "w

w \ r \ lists A \ w \ lists A" + using pow_in_lists[of r A] pref_in_lists per_root_pow_conv by metis + +lemma nth_in_lists: "j < \<^bold>|w\<^bold>| \ w \ lists A \ w ! j \ A" + using in_lists_conv_set nth_mem by force method inlists = (insert method_facts, use nothing in \ ((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 lq_in_lists | rule rq_in_lists | + rule take_in_lists | intro lq_in_lists | rule nth_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 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))+\) section \Reversed mappings\ -definition rev_map :: "('a list \ 'b list) \ ('a list \ 'b list)" where - "rev_map f = rev \ f \ rev" +definition rev_map :: "('a list \ 'b list) \ ('a list \ 'b list)" where + "rev_map f = rev \ f \ 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 \ g = h" +lemma rev_maps_eq_iff[simp]: "rev_map g = rev_map h \ g = h" using arg_cong[of "rev_map g" "rev_map h" rev_map, unfolded rev_map_idemp] by fast +lemma rev_map_funpow[reversal_rule]: "(rev_map (f::'a list \'a list)) ^^ k = rev_map (f ^^ k)" + unfolding funpow.simps rev_map_def + by(induct k, simp+) + section \Overlapping powers, periods, prefixes and suffixes\ lemma pref_suf_overlapE: assumes "p \p w" and "s \s w" and "\<^bold>|w\<^bold>| \ \<^bold>|p\<^bold>| + \<^bold>|s\<^bold>|" obtains p1 u s1 where "p1 \ u \ s1 = w" and "p1 \ u = p" and "u \ s1 = s" proof- define u where "u = (w\<^sup><\s)\\<^sup>>p" have "u \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 \ u = p" and "p \ s1 = w" + unfolding u_def lq_def using suffix_drop. + obtain p1 s1 where "p1 \ u = p" and "p \ s1 = w" using suffixE[OF \u \s p\] prefixE[OF \p \p w\] by metis note \p \ s1 = w\[folded \p1 \ u = p\, unfolded rassoc] have "\<^bold>|s1\<^bold>| \ \<^bold>|s\<^bold>|" using \\<^bold>|w\<^bold>| \ \<^bold>|p\<^bold>| + \<^bold>|s\<^bold>|\[folded \p \ s1 = w\, unfolded lenmorph] by force hence "s1 \s s" using \p \ s1 = w\ \s \s w\ suf_prod_long by blast from rq_lq_assoc[OF rq_suf_suf[OF \s \s w\], of s1] u_def[folded rqI[OF \p \ s1 = w\]] have "u = s\<^sup><\s1" - using suf_rq_lq_id[OF \s \s w\] \s1 \s s\ by presburger + using suf_rq_lq_id[OF \s \s w\] \s1 \s s\ by presburger hence "u \ s1 = s" using rq_suf[OF \s1 \s s\] by blast from that[OF \p1 \ u \ s1 = w\ \p1 \ u = p\ this] show thesis. -qed +qed lemma mid_sq: assumes "p\x\q=x\x" shows "x\p=p\x" and "x\q=q\x" proof- - have "(x\p)\x\q = (p\x)\q\x" + have "(x\p)\x\q = (p\x)\q\x" using assms by auto from eqd_eq[OF this] show "x\p=p\x" and "x\q=q\x" by simp+ qed lemma mid_sq': assumes "p\x\q=x\x" shows "q \ p = x" and "p \ q = x" proof- have "p\q\x = x\x" using assms[unfolded mid_sq(2)[OF assms]]. thus "p\q = x" by auto from assms[folded this] this - show "q\p = x" by auto -qed - -lemma mid_sq_pref: "p \ u \p u \ u \ p \ u = u \ p" + show "q\p = x" by auto +qed + +lemma mid_sq_pref: "p \ u \p u \ u \ p \ u = u \ 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\x\q=x\x" shows "p \p x" and "p \s x" and "q \p x" and "q \s x" using assms mid_sq'[OF assms] by blast+ lemma mid_pow: assumes "p\x\<^sup>@(Suc l)\q = x\<^sup>@k" shows "x\p=p\x" and "x\q=q\x" proof- have "x\p\x\<^sup>@l\x\q = x\(p\x\<^sup>@Suc l \ q)" by comparison - also have "... = (p\x\<^sup>@Suc l \ q) \ x" + also have "... = (p\x\<^sup>@Suc l \ q) \ x" unfolding rassoc assms by comparison also have "... = p\x\x\<^sup>@l\q\x" by simp finally have eq: "x\p\x\<^sup>@l\x\q = p\x\x\<^sup>@l\q\x". have "(x\p)\x\<^sup>@l\x\q = (p\x)\x\<^sup>@l\q\x" using eq unfolding rassoc. from eqd_comp[OF this] show "x\p = p\x" using comm_ruler by blast have "(x\p\x\<^sup>@l)\(x\q) = (x\p\x\<^sup>@l)\(q\x)" using eq unfolding lassoc \x\p = p\x\. from this[unfolded cancel] show "x\q = q\x". qed +lemma root_suf_comm: assumes "x \p r \ x" and "r \s r \ x" shows "r \ x = x \ r" +proof- + have "r \ x = x \ x\\<^sup>>(r \ x)" + using lq_pref[OF \x \p r \ x\, symmetric]. + from this and conj_len[OF this] + have "r = x\\<^sup>>(r \ x)" + using lq_pref[OF \x \p r \ x\] suf_ruler_eq_len[OF \r \s r \ x\, of "x\\<^sup>>(r \ x)"] by blast + from \r \ x = x \ x\\<^sup>>(r \ x)\[folded this] + show "r \ x = x \ r". +qed + +lemma pref_marker: assumes "w \p v \ w" and "u \ v \p w" + shows "u \ v = v \ u" + using append_prefixD[OF \u \ v \p w\] comm_ruler[OF \u \ v \p w\, of "v \ w", unfolded same_prefix_prefix] + \w \p v \ w\ by blast + +lemma pref_marker_ext: assumes "\<^bold>|x\<^bold>| \ \<^bold>|y\<^bold>|" and "v \ \" and "y \ v \p x \ v\<^sup>@k" + obtains n where "y = x \ (\ v)\<^sup>@n" +proof- + note pref_prod_long_ext[OF \y \ v \p x \ v\<^sup>@k\ \\<^bold>|x\<^bold>| \ \<^bold>|y\<^bold>|\] + have "x\\<^sup>>y \ v \p v\<^sup>@k" + using pref_cancel_lq_ext[OF \y \ v \p x \ v\<^sup>@k\ \\<^bold>|x\<^bold>| \ \<^bold>|y\<^bold>|\]. + from pref_marker[OF _ this] + have "x\\<^sup>>y \ v = v \ x\\<^sup>>y" + unfolding pow_comm[symmetric] by blast + then obtain n where "x\\<^sup>>y = (\ v)\<^sup>@n" + using \v \ \\ + using comm_primroots pow_zero primroot_expE by metis + hence "y = x \ (\ v)\<^sup>@n" + using \x \p y\ by (auto simp add: prefix_def) + from that[OF this] show thesis. +qed + +lemma pref_marker_sq: "p \ x \p x \ x \ p \ x = x \ 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 \ \" and "w \ r \ s \p s \ (r \ s)\<^sup>@m" and "primitive (r \ s)" + obtains n where "w = s \ (r \ s)\<^sup>@n" +proof- + have "(r \ w) \ r \ s \p (r \ s)\<^sup>@Suc m" + using \w \ r \ s \p s \ (r \ s)\<^sup>@m\ by auto + from pref_marker[OF _ this, folded pow_comm, OF triv_pref] + have "(r \ w) \ r \ s = (r \ s) \ r \ w". + from comm_primroots'[OF _ prim_nemp[OF \primitive (r \ s)\] this, unfolded prim_self_root[OF \primitive (r \ s)\]] + have "\ (r \ w) = r \ s" + using \w \ \\ by blast + then obtain n where "r \ w = (r \ s)\<^sup>@n" "0 < n" + using \w \ \\ primroot_expE by metis + thus thesis + using pow_pos[OF \0 < n\, of "r \ s", folded \r \ w = (r \ s)\<^sup>@n\, + unfolded rassoc cancel] that by force +qed + +lemmas pref_marker_reversed = pref_marker[reversed] + +lemma suf_marker_per_root: assumes "w \p v \ w" and "p \ v \ u \p w" + shows "u \p v \ u" +proof- + have "p \ v = v \ p" + using pref_marker[OF \w \p v \ w\, of p] \p \ v \ u \p w\ by (auto simp add: prefix_def) + from pref_trans[OF \p \ v \ u \p w\[unfolded lassoc this, unfolded rassoc] \w \p v \ w\] + have "p \ u \p w" + using pref_cancel by auto + from ruler_le[OF this \p \ v \ u \p w\] + have "p \ u \p p \ v \ u" + by force + thus ?thesis + unfolding pref_cancel_conv. +qed + +lemma suf_marker_per_root': assumes "w \p v \ w" and "p \ v \ u \p w" and "v \ \" + shows "u \p p \ u" +proof- + have "p \ v = v \ p" + using pref_marker[OF \w \p v \ w\, of p] \p \ v \ u \p w\ by (fastforce simp add: prefix_def) + from root_comm_root[OF suf_marker_per_root[OF \w \p v \ w\ \p \ v \ u \p w\] this \v \ \\] + show "u \p p \ u". +qed + +lemma marker_fac_pref: assumes "u \f r\<^sup>@k" and "r \p u" shows "u \p r\<^sup>@k" + using assms +proof (cases "r = \") + assume "r \ \" + have "\<^bold>|u\<^bold>| \ \<^bold>|r\<^sup>@k\<^bold>|" + using \u \f r\<^sup>@k\ by force + obtain u' where "r \ u' = u" + using \r \p u\ by (auto simp add: prefix_def) + obtain p s where "p \ u \ s = r\<^sup>@k" + using \u \f r\<^sup>@k\ by blast + from suf_marker_per_root[of "r\<^sup>@k" r p "u' \ s", folded pow_comm, OF triv_pref] + have "u' \ s \p r \ (u' \ s)" + using \p \ u \ s = r\<^sup>@k\[folded \r \ u' = u\, unfolded rassoc] by fastforce + hence "u' \ s \p r\<^sup>@k \ (u' \ s)" + using per_exp_pref by blast + hence "u \p (r\<^sup>@k \ r) \ (u' \ s)" + unfolding \r \ u' = u\[symmetric] pow_Suc'[symmetric] pow_Suc rassoc + by (auto simp add: prefix_def) + thus "u \p r\<^sup>@k" + unfolding rassoc using \\<^bold>|u\<^bold>| \ \<^bold>|r\<^sup>@k\<^bold>|\ by blast +qed simp + +lemma marker_fac_pref_len: assumes "u \f r\<^sup>@k" and "t \p u" and "\<^bold>|t\<^bold>| = \<^bold>|r\<^bold>|" + shows "u \p t\<^sup>@k" +proof- + have "\<^bold>|u\<^bold>| \ \<^bold>|r\<^sup>@k\<^bold>|" + using \u \f r\<^sup>@k\ by force + hence "\<^bold>|u\<^bold>| \ \<^bold>|t\<^sup>@k\<^bold>|" + unfolding pow_len \\<^bold>|t\<^bold>| = \<^bold>|r\<^bold>|\. + have "t \f r\<^sup>@k" + using assms by blast + hence "t \ r" + using \\<^bold>|t\<^bold>| = \<^bold>|r\<^bold>|\ by (simp add: conjug_sym fac_pow_len_conjug) + from fac_pow_conjug[OF \u \f r\<^sup>@k\ this] + have "u \p t\<^sup>@Suc k" + using marker_fac_pref[OF _ \t \p u\] by blast + thus "u \p t\<^sup>@k" + using \\<^bold>|u\<^bold>| \ \<^bold>|t\<^sup>@k\<^bold>|\ unfolding pow_Suc' by blast +qed + +lemma root_suf_comm': "x \p r \ x \ r \s x \ r \ x = x \ r" + using root_suf_comm suffix_appendI[of r x r] by blast + +lemmas suf_root_pref_comm = root_suf_comm'[reversed] + +lemma marker_pref_suf_fac: assumes "u \p v" and "u \s v" and "v \f u\<^sup>@k" + shows "u \ v = v \ u" + using root_suf_comm'[OF pref_prod_root[OF marker_fac_pref[OF \v \f u\<^sup>@k\ \u \p v\]] \u \s v\]. + +lemma pref_suf_per_fac_comm: + assumes "v \p u \ v" and "v \s v \ u" and "u \f v\<^sup>@k" shows "u \ v = v \ u" + using marker_pref_suf_fac[OF _ _ \u \f v\<^sup>@k\] root_suf_comm[OF \v \p u \ v\ suf_ext] root_suf_comm[reversed, OF \v \s v \ u\ pref_ext] + ruler_pref'[OF \v \p u \ v\] ruler_suf'[OF \v \s v \ u\] by argo + lemma mid_long_pow: assumes eq: "y\<^sup>@m = u \ x\<^sup>@(Suc k) \ v" and "\<^bold>|y\<^bold>| \ \<^bold>|x\<^sup>@k\<^bold>|" shows "(u \ v) \ y = y \ (u \ v)" and "(u \ x\<^sup>@l \ v) \ y = y \ (u \ x\<^sup>@l \ v)" and "(u\\<^sup>>(y\u)) \ x = x \ (u\\<^sup>>(y\u))" proof- have eq': "x\ x \v \ u = u\\<^sup>>(u\x\x\v)\u" by simp let ?y = "u\\<^sup>>(y\u)" have "u \p y \ u" using eq prefI pref_prod_root[of u y m,unfolded eq] by simp hence "?y \ y" using root_conjug by blast from conjug_len[OF this] have "\<^bold>|?y\<^bold>| \ \<^bold>|x\<^sup>@k\<^bold>|" - using \\<^bold>|y\<^bold>| \ \<^bold>|x\<^sup>@k\<^bold>|\ by simp + using \\<^bold>|y\<^bold>| \ \<^bold>|x\<^sup>@k\<^bold>|\ by simp from lq_conjug_pow[OF \u \p y \ u\, of m] have "?y\<^sup>@m = x\<^sup>@Suc k\v\u" unfolding eq eq' by simp hence "x\<^sup>@Suc k \p ?y \ x\<^sup>@Suc k" - using mult_assoc prefI pref_prod_root[of "x\<^sup>@Suc k" ?y m] by blast + using rassoc prefI pref_prod_root[of "x\<^sup>@Suc k" ?y m] by blast have "x \<^sup>@ Suc k \p x \ x \<^sup>@ Suc k" - using pref_pow_ext' by blast + using pref_pow_ext' by blast have com: "?y \ x = x \ ?y" using \\<^bold>|?y\<^bold>| \ \<^bold>|x\<^sup>@k\<^bold>|\ two_pers[OF \x\<^sup>@Suc k \p ?y \ x\<^sup>@Suc k\ \x \<^sup>@ Suc k \p x \ x \<^sup>@ Suc k\] - unfolding power_Suc2 lenmorph by linarith + unfolding pow_Suc' lenmorph by linarith thus "?y \ x = x \ ?y" by blast have "?y \ x\<^sup>@Suc k = x\<^sup>@Suc k \ ?y" - using power_commuting_commutes[OF com[symmetric], symmetric]. - from power_commutes[of ?y m, unfolded \?y \<^sup>@ m = x\<^sup>@(Suc k) \ v \ u\, unfolded lassoc this, unfolded rassoc] + using com comm_add_exp by metis + from pow_comm[of ?y m, unfolded \?y \<^sup>@ m = x\<^sup>@(Suc k) \ v \ u\, unfolded lassoc this, unfolded rassoc] have "x\<^sup>@Suc k \ v \ u \ ?y = x\<^sup>@Suc k \ ?y \ v \ u". hence "u \ ?y \ v \ u = u \ v \ u \ ?y" by simp thus "(u \ v) \ y = y \ (u \ v)" unfolding lassoc lq_pref[OF \u \p y \ u\] by fastforce have "u \ x\<^sup>@l \ v \ u \ ?y = u \ (?y \ x\<^sup>@l) \ v \ u" - unfolding power_commuting_commutes[OF com[symmetric], of l, symmetric] rassoc cancel + unfolding comm_add_exp[OF com[symmetric], of l, symmetric] rassoc cancel using \u \ ?y \ v \ u = u \ v \ u \ ?y\[unfolded cancel, symmetric]. thus "(u \ x\<^sup>@l \ v) \ y = y \ (u \ x\<^sup>@l \ v)" unfolding lq_pref[OF \u \p y \ u\] lassoc by blast qed lemma mid_pow_pref_suf': assumes "s\w\<^sup>@(Suc l)\p \f w\<^sup>@k" shows "p \p w\<^sup>@k" and "s \s w\<^sup>@k" proof- - obtain v u where dec: "v \ s \ w\<^sup>@(Suc l) \ p \ u = w\<^sup>@k" - using facE'[OF assms, unfolded rassoc]. + obtain v u where dec: "v \ s \ w\<^sup>@(Suc l) \ p \ u = w\<^sup>@k" + using facE'[OF assms, unfolded rassoc]. hence "(v \ s) \ w = w \ (v \ s)" and "w \ (p \ u) = (p \ u) \ w" using mid_pow[of "v \ s" w l "p \ u" k] unfolding rassoc by presburger+ have "\<^bold>|p\<^bold>| \ \<^bold>|w\<^sup>@k\<^bold>|" and "\<^bold>|s\<^bold>| \ \<^bold>|w\<^sup>@k\<^bold>|" using fac_len[OF assms] unfolding lenmorph by linarith+ - from per_exp_pref[of "p \ u" w k, unfolded \w \ (p \ u) = (p \ u) \ w\, OF triv_pref] - have "p \p w\<^sup>@k \ (p \ u)" + from per_exp_pref[of "p \ u" w k, unfolded \w \ (p \ u) = (p \ u) \ w\, OF triv_pref] + have "p \p w\<^sup>@k \ (p \ u)" using prefix_order.trans[OF triv_pref[of p u]] by blast thus "p \p w\<^sup>@k" using \\<^bold>|p\<^bold>| \ \<^bold>|w \<^sup>@ k\<^bold>|\ pref_prod_le by blast from per_exp_suf[of "v \ s" w k, unfolded \(v \ s) \ w = w \ (v \ s)\, OF triv_suf] have "s \s (v \ s) \ w\<^sup>@k" using suffix_order.trans[OF triv_suf[of s v], of "(v \ s) \ w\<^sup>@k"] by blast thus "s \s w\<^sup>@k" using \\<^bold>|s\<^bold>| \ \<^bold>|w \<^sup>@ k\<^bold>|\ suf_prod_le by blast qed lemma mid_pow_pref_suf: assumes "s\w\p \f w\<^sup>@k" shows "p \p w\<^sup>@k" and "s \s w\<^sup>@k" - using mid_pow_pref_suf'[of s w 0 p k, unfolded power_Suc0_right, OF assms]. + using mid_pow_pref_suf'[of s w 0 p k, unfolded pow_one, OF assms]. lemma fac_marker_pref: "y \ x \f y\<^sup>@k \ x \p y \ x" - using mid_pow_pref_suf(1)[of \, unfolded clean_emp, THEN pref_prod_root]. + using mid_pow_pref_suf(1)[of \, unfolded emp_simps, 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 \ r \ q = r \ r" obtains (pref_emp) "p = \" | (suff_emp) "q = \" proof (cases "\<^bold>|p\<^bold>| = 0", blast) assume "\<^bold>|p\<^bold>| \ 0" and qemp: "q = \ \ thesis" hence "\<^bold>|q\<^bold>| < \<^bold>|r\<^bold>|" using lenarg[OF eq] unfolding lenmorph by linarith have "q = \" using prim_comm_short_emp[OF prim mid_sq(2)[OF eq, symmetric] \\<^bold>|q\<^bold>| < \<^bold>|r\<^bold>|\]. from qemp[OF this] show thesis. qed lemma prim_overlap_sqE' [consumes 2]: assumes prim: "primitive r" and eq: "p \ r \ q = r \ r" obtains (pref_emp) "p = \" | (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 \ r \ q = r \ r" shows "p = \ \ q = \" using prim_overlap_sqE[OF prim eq disjI1 disjI2]. lemma prim_overlap_sq': assumes prim: "primitive r" and pref: "p \ r \p r \ r" and len: "\<^bold>|p\<^bold>| < \<^bold>|r\<^bold>|" shows "p = \" using mid_sq(1)[symmetric, THEN prim_comm_short_emp[OF prim _ len ]] pref - by (auto simp add: prefix_def) + by (auto simp add: prefix_def) lemma prim_overlap_pow: assumes prim: "primitive r" and pref: "u \ r \p r\<^sup>@k" obtains i where "u = r\<^sup>@i" and "i < k" proof- obtain q where eq: "u \ r \<^sup>@ Suc 0 \ q = r \<^sup>@ k" using pref by (auto simp add: prefix_def) from mid_pow(1)[OF this, symmetric] have "u \ r = r \ u". - from prim_comm_exp[OF \primitive r\ this] - obtain i where "r\<^sup>@i = u". + from prim_comm_exp[OF \primitive r\ this] + obtain i where "r\<^sup>@i = u". hence "\<^bold>|r \<^sup>@ Suc i\<^bold>| \ \<^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 mult_cancel_le[OF nemp_len[OF prim_nemp[OF prim]] this[unfolded pow_len]] + have "i < k" by auto from that[OF \r\<^sup>@i = u\[symmetric] this] show thesis. qed lemma prim_overlap_pow': assumes prim: "primitive r" and pref: "u \ r \p r\<^sup>@k" and less: "\<^bold>|u\<^bold>| < \<^bold>|r\<^bold>|" shows "u = \" proof- obtain i where "u = r\<^sup>@i" - using prim_overlap_pow[OF prim pref] by fastforce + using prim_overlap_pow[OF prim pref] by force from less[unfolded pow_len[of r i, folded this]] have "i = 0" by force from \u = r\<^sup>@i\[unfolded this pow_zero] show "u = \". qed lemma prim_sqs_overlap: assumes prim: "primitive r" and comp: "u \ r \ r \ v \ r \ 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 \ (r \ r) \ v \ (r \ r)" and len_v: "\<^bold>|v\<^bold>| < \<^bold>|u\<^bold>| + \<^bold>|r\<^bold>|" and "\<^bold>|u\<^bold>| \ \<^bold>|v\<^bold>|" for u v proof - - obtain w where v: "u \ w = v" + obtain w where v: "u \ w = v" using comp_shorter[OF comp_prefs_comp[OF comp] \\<^bold>|u\<^bold>| \ \<^bold>|v\<^bold>|\] by (auto simp add: prefix_def) have "\<^bold>|w\<^bold>| < \<^bold>|r\<^bold>|" using len_v unfolding v[symmetric] by simp have comp': "r \ r \ (w \ r) \ r" using comp unfolding v[symmetric] rassoc comp_cancel. moreover have "\<^bold>|w \ r\<^bold>| \ \<^bold>|r \ r\<^bold>|" using less_imp_le_nat[OF \\<^bold>|w\<^bold>| < \<^bold>|r\<^bold>|\] by simp - ultimately have pref: "w \ r \p r \ r" + ultimately have pref: "w \ r \p r \ r" by (rule pref_comp_len_trans[OF triv_pref]) from this \\<^bold>|w\<^bold>| < \<^bold>|r\<^bold>|\ have "w = \" by (rule prim_overlap_sq'[OF prim]) show "u = v" using v unfolding \w = \\ append_Nil2. qed show "\<^bold>|u\<^bold>| \ \<^bold>|v\<^bold>| \ u = v" using wlog_le[OF comp len_v]. show "\<^bold>|v\<^bold>| \ \<^bold>|u\<^bold>| \ u = v" using wlog_le[OF comp[symmetric] len_u, symmetric]. qed lemma drop_pref_prim: assumes "Suc n < \<^bold>|w\<^bold>|" and "w \p drop (Suc n) (w \ w)" and "primitive w" shows False using assms -proof (cases "w = \", simp) - assume "w \ \" +proof (cases "w = \") + assume "w \ \" obtain s where "drop (Suc n) (w \ w) = w \ s" using prefD[OF \w \p drop (Suc n) (w \ w)\] by blast - note takedrop[of "Suc n" "w \ w", unfolded this] + note takedrop[of "Suc n" "w \ w", unfolded this] from \Suc n < \<^bold>|w\<^bold>|\ \w \ \\ prim_overlap_sqE'[OF \primitive w\ this] show False by auto -qed - -lemma root_suf_comm: assumes "x \p r \ x" and "r \s r \ x" shows "r \ x = x \ r" -proof- - have "r \ x = x \ x\\<^sup>>(r \ x)" - using lq_pref[OF \x \p r \ x\, symmetric]. - from this and conj_len[OF this] - have "r = x\\<^sup>>(r \ x)" - using lq_pref[OF \x \p r \ x\] suf_ruler_eq_len[OF \r \s r \ x\, of "x\\<^sup>>(r \ x)"] by blast - from \r \ x = x \ x\\<^sup>>(r \ x)\[folded this] - show "r \ x = x \ r". -qed - -lemma root_suf_comm': "x \p r \ x \ r \s x \ r \ x = x \ r" - using root_suf_comm suffix_appendI[of r x r] by blast - -lemma root_suf_conjug: assumes "primitive (s \ r)" and "y \p (s \ r) \ y" and "y \s y \ (r \ s)" - and "y \ \" and "\<^bold>|s \ r\<^bold>| \ \<^bold>|y\<^bold>|" +qed simp + +lemma root_suf_conjug: assumes "primitive (s \ r)" and "y \p (s \ r) \ y" and "y \s y \ (r \ s)" and "\<^bold>|s \ r\<^bold>| \ \<^bold>|y\<^bold>|" obtains l where "y = (s \ r)\<^sup>@l \ s" proof- + have "y \ \" + using assms(1) assms(4) by force have "r \ s \s y" using suf_prod_long[OF \y \s y \ (r \ s)\ \\<^bold>|s \ r\<^bold>| \ \<^bold>|y\<^bold>|\[unfolded swap_len]]. have "primitive (r \ s)" - using prim_conjug[OF \primitive (s \ r)\ conjugI']. - have "r \ y \p (r \ s) \ (r \ y)" - using \y \p (s \ r) \ y\ by auto + using prim_conjug[OF \primitive (s \ r)\ conjugI']. + have "r \ y \p (r \ s) \ (r \ y)" + using \y \p (s \ r) \ y\ by auto from prim_comm_exp[OF \primitive (r \ s)\ root_suf_comm'[OF this suf_ext[OF \r \ s \s y\], symmetric]] - obtain k where [symmetric]: "(r \ s)\<^sup>@k = r \ y". - from nemp_pow_SucE[OF _ this that, unfolded pow_Suc rassoc cancel shift_pow] \y \ \\ - show thesis by simp + obtain k where [symmetric]: "(r \ s)\<^sup>@k = r \ y" and "0 < k" + using \y \ \\ using nemp_exp_pos sufI suf_emp by metis + hence "y = (s \ r)\<^sup>@(k-1) \ s" + unfolding pow_pos[of _ "r\s", OF \0 < k\] rassoc cancel shift_pow by blast + from that[OF this] + show thesis. qed lemma pref_suf_pows_comm: assumes "x \p y\<^sup>@(Suc k)\x\<^sup>@l" and "y \s y\<^sup>@m \ x\<^sup>@(Suc n)" shows "x \ y = y \ x" - using root_suf_comm[OF per_root_drop_exp[OF \x \p y\<^sup>@(Suc k)\x\<^sup>@l\] per_root_drop_exp[reversed, OF \y \s y\<^sup>@m \ x\<^sup>@(Suc n)\], symmetric]. + using root_suf_comm[OF per_root_drop_exp'[OF assms(1)] per_root_drop_exp'[reversed, OF assms(2)], symmetric]. lemma root_suf_pow_comm: assumes "x \p r \ x" and "r \s x\<^sup>@(Suc k)" shows "r \ x = x \ r" - using root_suf_comm[OF \x \p r \ x\ suf_prod_root[OF \r \s x\<^sup>@(Suc k)\]]. + using root_suf_comm[OF \x \p r \ x\ suf_prod_root[OF \r \s x\<^sup>@(Suc k)\]]. lemma suf_pow_short_suf: "r \s x\<^sup>@k \ \<^bold>|x\<^bold>| \ \<^bold>|r\<^bold>| \ x \s r" using suf_prod_root[THEN suf_prod_long]. thm suf_pow_short_suf[reversed] -lemma pref_marker: assumes "w \p v \ w" and "u \ v \p w" - shows "u \ v = v \ u" - using append_prefixD[OF \u \ v \p w\] comm_ruler[OF \u \ v \p w\, of "v \ w", unfolded same_prefix_prefix] - \w \p v \ w\ by blast - -lemma pref_marker_ext: assumes "\<^bold>|x\<^bold>| \ \<^bold>|y\<^bold>|" and "v \ \" and "y \ v \p x \ v\<^sup>@k" - obtains n where "y = x \ (\ v)\<^sup>@n" -proof- - note pref_prod_long_ext[OF \y \ v \p x \ v\<^sup>@k\ \\<^bold>|x\<^bold>| \ \<^bold>|y\<^bold>|\] - have "x\\<^sup>>y \ v \p v\<^sup>@k" - using pref_cancel_lq_ext[OF \y \ v \p x \ v\<^sup>@k\ \\<^bold>|x\<^bold>| \ \<^bold>|y\<^bold>|\]. - from pref_marker[OF _ this] - have "x\\<^sup>>y \ v = v \ x\\<^sup>>y" - unfolding pow_comm[symmetric] by blast - then obtain n where "x\\<^sup>>y = (\ v)\<^sup>@n" - using \v \ \\ - using comm_primroots pow_zero primroot_expE' by metis - hence "y = x \ (\ v)\<^sup>@n" - using \x \p y\ by (auto simp add: prefix_def) - from that[OF this] show thesis. -qed - -lemma pref_marker_sq: "p \ x \p x \ x \ p \ x = x \ 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 \ \" and "w \ r \ s \p s \ (r \ s)\<^sup>@m" and "primitive (r \ s)" - obtains n where "w = s \ (r \ s)\<^sup>@n" -proof- - have "(r \ w) \ r \ s \p (r \ s)\<^sup>@Suc m" - using \w \ r \ s \p s \ (r \ s)\<^sup>@m\ by auto - from pref_marker[OF _ this, folded pow_comm, OF triv_pref] - have "(r \ w) \ r \ s = (r \ s) \ r \ w". - from comm_primroots'[OF _ prim_nemp[OF \primitive (r \ s)\] this, unfolded prim_self_root[OF \primitive (r \ s)\]] - have "\ (r \ w) = r \ s" - using \w \ \\ by blast - then obtain n where "r \ w = (r \ s)\<^sup>@Suc n" - using \w \ \\ 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>| \ \<^bold>|v\<^bold>|" and "v\v \p u\(v\v)" shows "u\v = v\u" - using - pref_marker[of "v\v", OF \v\v \p u\(v\v)\ + using + pref_marker[of "v\v", OF \v\v \p u\(v\v)\ pref_prod_long[OF append_prefixD[OF \v\v \p u\(v\v)\] \\<^bold>|u\<^bold>| \ \<^bold>|v\<^bold>|\, - THEN pref_cancel'], symmetric]. - -lemma fac_marker: assumes "w \p u\w" and "u\v\u \f w" + THEN pref_cancel'], symmetric]. + +lemma fac_marker: assumes "w \p u\w" and "u\v\u \f w" shows "u \ v = v \ u" proof- obtain p s where "w = p\u\v\u\s" using \u\v\u \f w\[unfolded fac_def] by auto hence "p\u\v\u = u\p\u\v" - using pref_marker[OF \w \p u\w\, unfolded \w = p\u\v\u\s\, of "p \ u \ v"] + using pref_marker[OF \w \p u\w\, unfolded \w = p\u\v\u\s\, of "p \ u \ v"] by force thus "u\v = v\u" using eqd_eq[of "p \ u" "v \ u" "u \ p" "u \ v", unfolded rassoc, OF _ swap_len] by presburger qed -lemma suf_marker_per_root: assumes "w \p v \ w" and "p \ v \ u \p w" - shows "u \p v \ u" -proof- - have "p \ v = v \ p" - using pref_marker[OF \w \p v \ w\, of p] \p \ v \ u \p w\ by (auto simp add: prefix_def) - from pref_trans[OF \p \ v \ u \p w\[unfolded lassoc this, unfolded rassoc] \w \p v \ w\] - have "p \ u \p w" - using pref_cancel by auto - from ruler_le[OF this \p \ v \ u \p w\] - have "p \ u \p p \ v \ u" - by force - thus ?thesis - using pref_cancel by fast -qed - -lemma marker_fac_pref: assumes "u \f r\<^sup>@k" and "r \p u" shows "u \p r\<^sup>@k" - using assms -proof (cases "r = \", simp) - assume "r \ \" - have "\<^bold>|u\<^bold>| \ \<^bold>|r\<^sup>@k\<^bold>|" - using \u \f r\<^sup>@k\ by force - obtain u' where "r \ u' = u" - using \r \p u\ by (auto simp add: prefix_def) - obtain p s where "p \ u \ s = r\<^sup>@k" - using \u \f r\<^sup>@k\ by blast - from suf_marker_per_root[of "r\<^sup>@k" r p "u' \ s", folded pow_comm, OF triv_pref] - have "u' \ s \p r \ (u' \ s)" - using \p \ u \ s = r\<^sup>@k\[folded \r \ u' = u\, unfolded rassoc] by fastforce - hence "u' \ s \p r\<^sup>@k \ (u' \ s)" - using per_exp_pref by blast - hence "u \p (r\<^sup>@k \ r) \ (u' \ s)" - unfolding \r \ u' = u\[symmetric] pow_Suc2[symmetric] pow_Suc rassoc - by (auto simp add: prefix_def) - thus "u \p r\<^sup>@k" - unfolding rassoc using \\<^bold>|u\<^bold>| \ \<^bold>|r\<^sup>@k\<^bold>|\ by blast -qed - -lemma marker_fac_pref_len: assumes "u \f r\<^sup>@k" and "t \p u" and "\<^bold>|t\<^bold>| = \<^bold>|r\<^bold>|" - shows "u \p t\<^sup>@k" -proof- - have "\<^bold>|u\<^bold>| \ \<^bold>|r\<^sup>@k\<^bold>|" - using \u \f r\<^sup>@k\ by fastforce - hence "\<^bold>|u\<^bold>| \ \<^bold>|t\<^sup>@k\<^bold>|" - unfolding pow_len \\<^bold>|t\<^bold>| = \<^bold>|r\<^bold>|\. - have "t \f r\<^sup>@k" - using assms by blast - hence "t \ r" - using \\<^bold>|t\<^bold>| = \<^bold>|r\<^bold>|\ by (simp add: conjug_sym fac_pow_len_conjug) - from fac_pow_conjug[OF \u \f r\<^sup>@k\ this] - have "u \p t\<^sup>@Suc k" - using marker_fac_pref[OF _ \t \p u\] by blast - thus "u \p t\<^sup>@k" - using \\<^bold>|u\<^bold>| \ \<^bold>|t\<^sup>@k\<^bold>|\ unfolding pow_Suc2 by blast -qed - -lemma suf_marker_per_root': assumes "w \p v \ w" and "p \ v \ u \p w" and "v \ \" - shows "u \p p \ u" -proof- - have "p \ v = v \ p" - using pref_marker[OF \w \p v \ w\, of p] \p \ v \ u \p w\ by (fastforce simp add: prefix_def) - from root_comm_root[OF suf_marker_per_root[OF \w \p v \ w\ \p \ v \ u \p w\] this \v \ \\] - show "u \p p \ u". -qed +lemma "4 = Suc(Suc(Suc(Suc 0)))" + using [[simp_trace]] by simp + lemma xyxy_conj_yxxy: assumes "x \ y \ x \ y \ y \ x \ x \ y" shows "x \ y = y \ x" proof- + have four: "x\<^sup>@4 = x\x\x\x" for x :: "'a list" + unfolding numeral_Bit0 by simp from conjug_fac_sq[OF assms[symmetric]] have "y \ x \ x \ y \f (x \ y)\<^sup>@4" - unfolding power4_eq_xxxx rassoc. - from marker_fac_pref[reversed, + unfolding four rassoc. + from marker_fac_pref[reversed, OF this triv_suf[of "x\y" "y\x", unfolded rassoc]] have "y \ x \ x \ y \s (x \ y) \<^sup>@ 4". hence "y \ x \ x \ y \s (x\y\x\y)\x\y\x\y" - unfolding power4_eq_xxxx rassoc. + unfolding four rassoc. from suf_prod_eq[OF this] show "x \ y = y \ x" by simp qed lemma per_glue: assumes "period u n" and "period v n" and "u \p w" and "v \s w" and "\<^bold>|w\<^bold>| + n \ \<^bold>|u\<^bold>| + \<^bold>|v\<^bold>|" shows "period w n" proof (rule indeces_period) show "w \ \" - using \period u n\ \u \p w\ by force - show "n \ 0" - using \period u n\ zero_not_per by metis - fix i assume "i + n < \<^bold>|w\<^bold>|" + using \period u n\ \u \p w\ by force + show "0 < n" + using \period u n\ per_not_zero 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)" + hence "w ! i = u ! i" and "w ! (i+n) = u ! (i+n)" using add_lessD1 \u \p w\ pref_index by metis+ thus "w ! i = w ! (i + n)" unfolding \w ! i = u ! i\ \w ! (i+n) = u ! (i+n)\ - using period_indeces[OF \period u n\ \i + n < \<^bold>|u\<^bold>|\] by blast + using period_indeces[OF \period u n\ \i + n < \<^bold>|u\<^bold>|\] by blast next - assume "\ i + n < \<^bold>|u\<^bold>|" + assume "\ i + n < \<^bold>|u\<^bold>|" obtain p where "w = p \ v" - using \v \s w\ by (auto simp add: suf_def) + using \v \s w\ by (auto simp add: suffix_def) have "\ i < \<^bold>|p\<^bold>|" using \\ i + n < \<^bold>|u\<^bold>|\ \\<^bold>|w\<^bold>| + n \ \<^bold>|u\<^bold>| + \<^bold>|v\<^bold>|\ unfolding lenarg[OF \w = p \ v\, unfolded lenmorph] by auto hence "w!i = v!(i - \<^bold>|p\<^bold>|)" and "w!(i+n) = v!((i - \<^bold>|p\<^bold>|) + n)" unfolding \w = p \ v\ nth_append by simp_all have "i - \<^bold>|p\<^bold>| + n < \<^bold>|v\<^bold>|" using \\ i < \<^bold>|p\<^bold>|\ \i + n < \<^bold>|w\<^bold>|\ \w = p \ v\ by auto - from period_indeces[OF \period v n\ this] + from period_indeces[OF \period v n\ this] show "w ! i = w ! (i + n)" unfolding \w!i = v!(i - \<^bold>|p\<^bold>|)\ \w!(i+n) = v!(i - \<^bold>|p\<^bold>| + n)\. qed qed -lemma per_glue_facs: assumes "u \ z \f w\<^sup>@k" and "z \ v \f w\<^sup>@m" and "\<^bold>|w\<^bold>| \ \<^bold>|z\<^bold>|" +lemma per_glue_facs: assumes "u \ z \f w\<^sup>@k" and "z \ v \f w\<^sup>@m" and "\<^bold>|w\<^bold>| \ \<^bold>|z\<^bold>|" obtains l where "u \ z \ v \f w\<^sup>@l" using assms -proof (cases "k = 0", simp) - assume "k \ 0" +proof (cases "k = 0") + assume "k \ 0" have "z \f w\<^sup>@k" using \u \ z \f w\<^sup>@k\ by blast have "z \f w\<^sup>@m" using \z \ v \f w\<^sup>@m\ by blast define t where "t = take \<^bold>|w\<^bold>| z" have "\<^bold>|t\<^bold>| = \<^bold>|w\<^bold>|" and "t \p z" unfolding t_def using \\<^bold>|w\<^bold>| \ \<^bold>|z\<^bold>|\ take_is_prefix by (force,blast) hence "w \ t" using \z \f w\<^sup>@m\ by blast from marker_fac_pref_len[OF \z \ v \f (w) \<^sup>@ m\ _ \\<^bold>|t\<^bold>| = \<^bold>|w\<^bold>|\ ] have "z \ v \p t\<^sup>@m" using \t \p z\ by force have "u \ z \f t\<^sup>@Suc k" - using fac_pow_conjug[OF \u \ z \f w\<^sup>@k\ \w \ t\[symmetric]]. + using fac_pow_conjug[OF \u \ z \f w\<^sup>@k\ \w \ t\[symmetric]]. with \t \p z\ have "u \s t\<^sup>@Suc k" - using mid_pow_pref_suf(2)[of u t "t\\<^sup>>z" "Suc k"] lq_pref by metis - have "(t\<^sup>@Suc k\<^sup><\u)\ (u \ z \ v) \ (z \ v)\\<^sup>>(t\<^sup>@m) = t\<^sup>@Suc k \ t\<^sup>@m" + using mid_pow_pref_suf(2)[of u t "t\\<^sup>>z" "Suc k"] lq_pref by metis + have "(t\<^sup>@Suc k\<^sup><\u)\ (u \ z \ v) \ (z \ v)\\<^sup>>(t\<^sup>@m) = t\<^sup>@Suc k \ t\<^sup>@m" unfolding lassoc rq_suf[OF \u \s t\<^sup>@Suc k\] unfolding rassoc cancel using lq_pref[OF \z \ v \p t\<^sup>@m\] unfolding rassoc. from facI[of "u \ z \ v" "t\<^sup>@Suc k\<^sup><\u" "(z \ v)\\<^sup>>(t\<^sup>@m)", unfolded this, folded add_exps] - obtain l where "u \ z \ v \f t\<^sup>@l" + obtain l where "u \ z \ v \f t\<^sup>@l" by metis from that[OF fac_pow_conjug[OF this \w \ t\]] show thesis. -qed +qed simp lemma per_fac_pow_fac: assumes "period w n" and "v \f w" and "\<^bold>|v\<^bold>| = n" - obtains k where "w \f v\<^sup>@k" + obtains k where "w \f v\<^sup>@k" proof- obtain m where "w \f (take n w)\<^sup>@m" - using period_D3[OF \period w n\, THEN per_root_fac] per_positive[OF \period w n\] period_D1[OF \period w n\] - take_nemp by blast + using per_root_powE[OF \period w n\[unfolded period_def]] pref_fac sprefD1 by metis obtain r s where "r \ s = v" and "s \ r = take n w" - using fac_per_conjug[OF assms, THEN conjugE]. + using fac_per_conjug[OF assms, THEN conjugE]. hence "r \ (take n w)\<^sup>@m \ s = v\<^sup>@Suc m" by (metis pow_slide) from that[OF fac_trans, OF \w \f (take n w)\<^sup>@m\] 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 \f w" and "n \ \<^bold>|v\<^bold>|" and "period v k" and "k dvd n" shows "period w k" proof- have "n \ 0" using \period w n\ by auto have "w \ \" using \period w n\ by auto have "v \ \" using \period v k\ by auto have "\<^bold>|take n w\<^bold>| = n" - using take_len[OF le_trans[OF \n \ \<^bold>|v\<^bold>|\ fac_len[OF \v \f w\]]]. + using take_len[OF le_trans[OF \n \ \<^bold>|v\<^bold>|\ fac_len[OF \v \f w\]]]. have "\<^bold>|take n v\<^bold>| = n" - using take_len[OF \n \ \<^bold>|v\<^bold>|\]. + using take_len[OF \n \ \<^bold>|v\<^bold>|\]. have "period v n" - using period_fac'[OF \period w n\ \v \f w\ \v \ \\] by blast + using period_fac'[OF \period w n\ \v \f w\ \v \ \\] by blast have "take n v \f w" using \v \f w\ \n \ \<^bold>|v\<^bold>|\ sublist_order.dual_order.trans sublist_take by metis have "period (take n v) k" - using \period w n\ \period v k\ per_positive per_pref' take_is_prefix take_nemp by metis - have "k \ n" + using \period w n\ \period v k\ per_not_zero per_pref' take_is_prefix take_nemp by metis + have "k \ n" using \k dvd n\ \n \ 0\ by auto hence "take k (take n v) = take k v" - using take_le_take by blast + using take_le_take by blast hence "(take k v)\<^sup>@(n div k) = take n v" - using per_div[OF _ \period (take n v) k\, unfolded \\<^bold>|take n v\<^bold>| = n\, OF \k dvd n\] by presburger + using per_div[OF _ \period (take n v) k\, unfolded \\<^bold>|take n v\<^bold>| = n\, OF \k dvd n\] by presburger have "\<^bold>|take k v\<^bold>| = k" using order.trans[OF \k \ n\ \n \ \<^bold>|v\<^bold>|\, THEN take_len]. obtain e where "w \f (take n v)\<^sup>@e" using per_fac_pow_fac[OF \period w n\ \take n v \f w\ \\<^bold>|take n v\<^bold>| = n\]. - from per_fac[OF \w \ \\ this[folded \(take k v)\<^sup>@(n div k) = take n v\, folded power_mult]] - show ?thesis - unfolding \\<^bold>|take k v\<^bold>| = k\. + from per_fac[OF \w \ \\ this[folded \(take k v)\<^sup>@(n div k) = take n v\, folded pow_mult]] + show ?thesis + unfolding \\<^bold>|take k v\<^bold>| = k\ by blast qed lemma xy_per_comp: assumes "x\y \p q\x\y" and "q \ \" and "q \ y" shows "x \ y" proof(cases rule: pref_compE[OF \q \ y\]) assume "q \p y" have "x\q = q\x" - using + using pref_cancel'[OF \q \p y\, of x, THEN pref_trans, OF \x \ y \p q \ x \ y\] 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 \p q" then show ?thesis by (meson append_prefixD prefix_append ruler' assms) qed lemma prim_xyxyy: "x \ y \ y \ x \ primitive (x \ y \ x \ y \ y)" proof (rule prim_conjug) show "y \ x \ y \ x \ y \ x \ y \ x \ y \ y" by (intro conjugI1) simp show "x \ y \ y \ x \ primitive (y \ x \ y \ x \ y)" by (intro iffD2[OF per_le_prim_iff[of _ "y \ x"]]) auto qed +lemma prim_min_per_suf_eq: assumes "primitive x" and "\ x \s x" shows "\ x = x" + using assms(1) min_per_root_per_root[OF prim_nemp[OF \primitive x\], unfolded ] root_suf_comm'[OF _ \\ x \s x\] + unfolding primitive_iff_per by blast + +lemma primroot_code[code]: "\ x = (if x \ \ then (if \ x \s x then \ x else x) else Code.abort (STR ''Empty word has no primitive root.'') (\_. (\ x)))" +proof(cases "x = \") + assume "x \ \" + thus ?thesis + unfolding if_P[OF \x \ \\] + proof(cases) + assume "e\<^sub>\ x = 1" + have "primitive x" + using primroot_exp_eq[of x, unfolded \e\<^sub>\ x = 1\ exp_simps] + unfolding prim_primroot_conv[OF \x \ \\]. + from prim_min_per_suf_eq[OF this] prim_self_root[OF this] + show "\ x = (if \ x \s x then \ x else x)" + by argo + next + assume "e\<^sub>\ x \ 1" + show "\ x = (if \ x \s x then \ x else x)" + using primroot_suf + unfolding min_per_short_primroot[OF \x \ \\ primroot_exp_eq \e\<^sub>\ x \ 1\] + by auto + qed +qed (simp add: primitive_root_def) + +lemma per_lemma_pref_suf: assumes "w

w" and "w q" and + fw: "\<^bold>|p\<^bold>| + \<^bold>|q\<^bold>| \ \<^bold>|w\<^bold>|" +obtains r s k l m where "p = (r \ s)\<^sup>@k" and "q = (s \ r)\<^sup>@l" and "w = (r \ s)\<^sup>@m \ r" and "primitive (r\s)" +proof- + let ?q = "(w \ q)\<^sup><\w" + have "w

w" + using ssufD1[OF \w q\] rq_suf[symmetric, THEN per_rootI[OF prefI rq_ssuf[OF \w q\]]] + by argo + have "q \ ?q" + by (meson assms(2) conjugI1 conjug_sym rq_suf suffix_order.less_imp_le) + + have nemps': "p \ \" "?q\ \" + using assms(1) \w

w\ by fastforce+ + from two_pers[OF sprefD1[OF \w

w\] sprefD1[OF \w

w\]] fw + have "p \ ?q = ?q \ p" + unfolding conjug_len[OF \q \ (w \ q)\<^sup><\w\] + by blast + then have "\ p = \ ?q" using comm_primroots[OF nemps'] by force + hence [symmetric]: "\ q \ \ p" + using conjug_primroot[OF \q \ (w \ q)\<^sup><\w\] + by argo + from conjug_primrootsE[OF this] + obtain r s k l where + "p = (r \ s) \<^sup>@ k" and + "q = (s \ r) \<^sup>@ l" and + "primitive (r \ s)". + have "w \p (r\s)\w" + using assms per_root_drop_exp sprefD1 \p = (r \ s) \<^sup>@ k\ + by meson + have "w \s w\(s\r)" + using assms(2) per_root_drop_exp[reversed] ssufD1 \q = (s \ r) \<^sup>@ l\ + by meson + have "\<^bold>|r \ s\<^bold>| \ \<^bold>|w\<^bold>|" + using conjug_nemp_iff[OF \q \ ?q\] dual_order.trans length_0_conv nemps' primroot_len_le[OF nemps'(1)] fw + unfolding primroot_unique[OF nemps'(1) \primitive (r \ s)\ \p = (r \ s) \<^sup>@ k\] + by linarith + from root_suf_conjug[OF \primitive (r \ s)\ \w \p (r\s)\w\ \w \s w\(s\r)\ this] + obtain m where "w = (r \ s) \<^sup>@ m \ r". + from that[OF \p = (r \ s) \<^sup>@ k\ \q = (s \ r) \<^sup>@ l\ this \primitive (r \ s)\] + show ?thesis. +qed + +lemma fac_two_conjug_primroot: + assumes facs: "w \f p\<^sup>@k" "w \f q\<^sup>@l" and nemps: "p \ \" "q \ \" and len: "\<^bold>|p\<^bold>| + \<^bold>|q\<^bold>| \ \<^bold>|w\<^bold>|" + obtains r s m where "\ p \ r \ s" and "\ q \ r \ s" and "w = (r \ s)\<^sup>@m \ r" and "primitive (r\s)" +proof - + obtain p' where "w

w" "p \ p'" "p' \ \" + using conjug_nemp_iff fac_pow_pref_conjug[OF facs(1)] nemps(1) per_rootI' by metis + obtain q' where "w q'" "q \ q'" "q' \ \" + using fac_pow_pref_conjug[reversed, OF \w \f q\<^sup>@l\] conjug_nemp_iff nemps(2) per_rootI'[reversed] by metis + from per_lemma_pref_suf[OF \w

w\ \w q'\] + obtain r s k l m where + "p' = (r \ s) \<^sup>@ k" and + "q' = (s \ r) \<^sup>@ l" and + "w = (r \ s) \<^sup>@ m \ r" and + "primitive (r \ s)" + using len[unfolded conjug_len[OF \p \ p'\] conjug_len[OF \q \ q'\]] + by blast + moreover have "\ p' = r\s" + using \p' = (r \ s) \<^sup>@ k\ \primitive (r \ s)\ \p' \ \\ primroot_unique by blast + hence "\ p \ r\s" + using conjug_primroot[OF \p \ p'\] + by simp + moreover have "\ q' = s\r" + using \q' = (s \ r) \<^sup>@ l\ \primitive (r \ s)\[unfolded conjug_prim_iff'[of r]] \q' \ \\ primroot_unique by blast + hence "\ q \ s\r" + using conjug_primroot[OF \q \ q'\] by simp + hence "\ q \ r\s" + using conjug_trans[OF _ conjugI'] + by meson + ultimately show ?thesis + using that by blast +qed + +corollary fac_two_conjug_primroot': + assumes facs: "u \f r\<^sup>@k" "u \f s\<^sup>@l" and nemps: "r \ \" "s \ \" and len: "\<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| \ \<^bold>|u\<^bold>|" + shows "\ r \ \ s" + using fac_two_conjug_primroot[OF assms] conjug_trans[OF _ conjug_sym[of "\ s"]] + by metis + +lemma fac_two_conjug_primroot'': + assumes facs: "u \f r\<^sup>@k" "u \f s\<^sup>@l" and "u \ \" and len: "\<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| \ \<^bold>|u\<^bold>|" + shows "\ r \ \ s" +proof - + have nemps: "r \ \" "s \ \" using facs \u \ \\ by auto + show "conjugate (\ r) (\ s)" using fac_two_conjug_primroot'[OF facs nemps len]. +qed + +lemma fac_two_prim_conjug: + assumes "w \f u\<^sup>@n" "w \f v\<^sup>@m" "primitive u" "primitive v" "\<^bold>|u\<^bold>| + \<^bold>|v\<^bold>| \ \<^bold>|w\<^bold>|" + shows "u \ v" + using fac_two_conjug_primroot'[OF assms(1-2) _ _ assms(5)] prim_nemp[OF \primitive u\] prim_nemp[OF \primitive v\] + unfolding prim_self_root[OF \primitive u\] prim_self_root[OF \primitive v\]. + +lemma fac_pow_conjug_primroot: assumes "u\<^sup>@k \f v\<^sup>@l" and "\<^bold>|u\<^sup>@k\<^bold>| \ 2*\<^bold>|v\<^bold>|" and "2 \ k" and "u \ \" + shows "\ u \ \ v" +proof(rule fac_two_conjug_primroot''[OF _ assms(1)], force) + have "0 < k" + using \2 \ k\ by linarith + show "\<^bold>|u\<^bold>| + \<^bold>|v\<^bold>| \ \<^bold>|u \<^sup>@ k\<^bold>|" + proof(cases "\<^bold>|u\<^bold>|" "\<^bold>|v\<^bold>|" rule: le_cases) + assume "\<^bold>|u\<^bold>| \ \<^bold>|v\<^bold>|" + thus ?thesis + using assms(2) by linarith + next + assume "\<^bold>|v\<^bold>| \ \<^bold>|u\<^bold>|" + hence " \<^bold>|u\<^bold>| + \<^bold>|v\<^bold>| \ 2*\<^bold>|u\<^bold>|" + by simp + thus ?thesis + unfolding pow_len + using mult_le_mono1[OF \2 \ k\] le_trans + by blast + qed + show "u \<^sup>@ k \ \" + using \u \ \\ \0 < k\ by blast +qed + section \Testing primitivity\ text\This section defines a proof method used to prove that a word is primitive.\ lemma primitive_iff [code]: "primitive w \ \ w \f tl w \ butlast w" proof- have "\ primitive w \ w \f tl w \ butlast w" proof assume "\ primitive w" then obtain r k where "k \ 1" and "w = r\<^sup>@k" unfolding primitive_def by blast show "w \f tl w \ butlast w" - proof (cases "w = \", simp) + proof (cases "w = \") assume "w \ \" from this[unfolded \w = r\<^sup>@k\] - have "k \ 0" + have "0 < k" using nemp_pow by blast - have "r \ \" + have "r \ \" using pow_zero \r \<^sup>@ k \ \\ by force - have "r\<^sup>@(k-1) \ \" + have "r\<^sup>@(k-1) \ \" unfolding nemp_emp_pow[OF \r \ \\, of "k-1"] - using \k \ 0\ \k \ 1\ by force + using \0 < k\ \k \ 1\ by force have "r \ w \ r\<^sup>@(k-1) = w \ w" unfolding \w = r\<^sup>@k\ pows_comm[of r k "k - 1"] - unfolding lassoc cancel_right pop_pow_one[OF \k \ 0\].. + unfolding lassoc cancel_right pow_pos[OF \0 < k\].. hence "[hd r] \ tl r \ w \ butlast (r\<^sup>@(k-1)) \ [last (r\<^sup>@(k-1))] = [hd w] \ tl w \ butlast w \ [last w]" unfolding hd_tl[reversed, OF \r\<^sup>@(k-1) \ \\] hd_tl[reversed, OF \w \ \\] - unfolding lassoc hd_tl[OF \r \ \\] hd_tl[OF \w \ \\]. + unfolding lassoc hd_tl[OF \r \ \\] hd_tl[OF \w \ \\]. hence "tl r \ w \ butlast (r\<^sup>@(k-1)) = tl w \ butlast w" by force thus ?thesis unfolding fac_def by metis - qed - next + qed simp + next assume "w \f tl w \ butlast w" show "\ primitive w" - proof (cases "w = \", simp) + proof (cases "w = \") assume "w \ \" from facE[OF \w \f tl w \ butlast w\] obtain p s where "tl w \ butlast w = p \ w \ s". - have "[hd w] \ (p \ w \ s) \ [last w] = w \ w" + have "[hd w] \ (p \ w \ s) \ [last w] = w \ w" unfolding \tl w \ butlast w = p \ w \ s\[symmetric] unfolding lassoc hd_tl[OF \w \ \\] unfolding rassoc hd_tl[reversed, OF \w \ \\].. from prim_overlap_sqE[of w "[hd w] \ p" "s \ [last w]" False, unfolded rassoc, OF _ this[unfolded rassoc]] - show "\ primitive w" + show "\ primitive w" by blast - qed + qed simp qed thus ?thesis by blast qed -method primitivity_inspection = (insert method_facts, use nothing in - \simp add: primitive_iff pop_pow_one\) - -(* Internal: Examples moved to ExamplesMethod.thy *) - -(* subsection Examples *) - -(* lemma "x \ y \ primitive [x,y,x,x,y,x,x,y,y,x,y,x,x,y,x,x,y,y,x]" *) - (* by primitivity_inspection *) - -(* lemma "\ primitive [x,y,x,y]" *) - (* by primitivity_inspection *) - -(* lemma "x \ y \ primitive (([x,y,x,y]\<^sup>@6)\[x])" *) - (* by primitivity_inspection *) - -(* lemma "x \ y \ primitive ([x]\([x,y,x,y]\<^sup>@6)\[x])" *) - (* by primitivity_inspection *) - -(* lemma "x \ y \ n \ 0 \ primitive (([x,y,x,y]\<^sup>@n)\[x])" *) - (* oops \ \this is out of scope of the method\ *) - -end \ No newline at end of file +method primitivity_inspection = (insert method_facts, use nothing in + \simp add: primitive_iff pow_pos\) + +\ \This is out of scope of the method, and has to be proved separately\ +lemma alternate_prim: assumes "x \ y" shows "primitive ([x,y]\<^sup>@n\[x])" +proof- + consider "n = 0" | "n = 1" | "2 \ n" by linarith + then show ?thesis + proof(cases) + assume "2 \ n" + have pref: "[x, y] \<^sup>@ n \ [x] \p [x, y] \ [x, y] \<^sup>@ n \ [x]" + by comparison + have neq: "([x, y] \<^sup>@ n \ [x]) \ [x, y] \ [x, y] \ [x, y] \<^sup>@ n \ [x]" + using \x \ y\ by force + then show ?thesis + using per_le_prim_iff[of "[x,y]\<^sup>@n\[x]" "[x,y]", OF pref] \2 \ n\ + unfolding lenmorph pow_len + by fastforce + qed (simp_all add: \x \ y\ primitive_iff) +qed + + + + + + + + +end diff --git a/thys/Combinatorics_Words/Equations_Basic.thy b/thys/Combinatorics_Words/Equations_Basic.thy --- a/thys/Combinatorics_Words/Equations_Basic.thy +++ b/thys/Combinatorics_Words/Equations_Basic.thy @@ -1,1632 +1,1987 @@ (* 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 + imports + Periodicity_Lemma + Lyndon_Schutzenberger + Submonoids Binary_Code_Morphisms begin chapter "Equations on words - basics" -text +text \Contains various nontrivial auxiliary or rudimentary facts related to equations. Often moderately advanced or even fairly advanced. May change significantly in the future.\ section \Factor interpretation\ definition factor_interpretation :: "'a list \ 'a list \ 'a list \ 'a list list \ bool" ("_ _ _ \\<^sub>\ _" [51,51,51,51] 60) where "factor_interpretation p u s ws = (p

s p \ u \ s = concat ws)" -lemma fac_interpret_nemp: "u \ \ \ p u s \\<^sub>\ ws \ ws \ \" + +lemma fac_interp_nemp: "u \ \ \ p u s \\<^sub>\ ws \ ws \ \" unfolding factor_interpretation_def by auto -lemma fac_interpretE: assumes "p u s \\<^sub>\ ws" +lemma fac_interpD: assumes "p u s \\<^sub>\ ws" shows "p

u \ s = concat ws" - using assms unfolding factor_interpretation_def by blast+ + using assms unfolding factor_interpretation_def by blast+ -lemma fac_interpretI: +lemma fac_interpI: "p

s p \ u \ s = concat ws \ p u s \\<^sub>\ ws" unfolding factor_interpretation_def by blast -lemma obtain_fac_interpret: assumes "pu \ u \ su = concat ws" and "u \ \" +lemma obtain_fac_interp: assumes "pu \ u \ su = concat ws" and "u \ \" obtains ps ss p s vs where "p u s \\<^sub>\ vs" and "ps \ vs \ ss = ws" and "concat ps \ p = pu" and - "s \ concat ss = su" + "s \ 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 \ \" using \u \ \\ \pu \ u \ su = concat ws\ by force have "\<^bold>|tl ws\<^bold>| < \<^bold>|ws\<^bold>|" and "\<^bold>|butlast ws\<^bold>| < \<^bold>|ws\<^bold>|" using \ws \ \\ by force+ show thesis - proof (cases) + proof (cases) assume "hd ws \p pu \ last ws \s su" then show thesis - proof + proof assume "hd ws \p pu" from prefixE[OF this] obtain pu' where "pu = hd ws \ pu'". from \pu \ u \ su = concat ws\[unfolded this, folded arg_cong[OF hd_tl[OF \ws \ \\], of concat]] have "pu' \ u \ su = concat (tl ws)" by force - from less.hyps[OF \\<^bold>|tl ws\<^bold>| < \<^bold>|ws\<^bold>|\ _ \pu' \ u \ su = concat (tl ws)\ \u \ \\] - obtain p s vs ps' ss where "p u s \\<^sub>\ vs" and "ps' \ vs \ ss = tl ws" and "concat ps' \ p = pu'" + from less.hyps[OF \\<^bold>|tl ws\<^bold>| < \<^bold>|ws\<^bold>|\ _ \pu' \ u \ su = concat (tl ws)\ \u \ \\] + obtain p s vs ps' ss where "p u s \\<^sub>\ vs" and "ps' \ vs \ ss = tl ws" and "concat ps' \ p = pu'" and "s \ concat ss = su". - have "(hd ws # ps') \ vs \ ss = ws" + have "(hd ws # ps') \ vs \ ss = ws" using \ws \ \\ \ps' \ vs \ ss = tl ws\ by auto have "concat (hd ws # ps') \ p = pu" using \concat ps' \ p = pu'\ unfolding \pu = hd ws \ pu'\ by fastforce from less.prems(1)[OF \p u s \\<^sub>\ vs\ \(hd ws # ps') \ vs \ ss = ws\ \concat (hd ws # ps') \ p = pu\ \s \ concat ss = su\] show thesis. next assume "last ws \s su" from suffixE[OF this] obtain su' where "su = su' \ last ws". from \pu \ u \ su = concat ws\[unfolded this, folded arg_cong[OF hd_tl[reversed, OF \ws \ \\], of concat]] have "pu \ u \ su' = concat (butlast ws)" by force - from less.hyps[OF \\<^bold>|butlast ws\<^bold>| < \<^bold>|ws\<^bold>|\ _ \pu \ u \ su' = concat (butlast ws)\ \u \ \\] + from less.hyps[OF \\<^bold>|butlast ws\<^bold>| < \<^bold>|ws\<^bold>|\ _ \pu \ u \ su' = concat (butlast ws)\ \u \ \\] obtain p s vs ps ss' where "p u s \\<^sub>\ vs" and "ps \ vs \ ss' = butlast ws" and "concat ps \ p = pu" and "s \ concat ss' = su'". - have "ps \ vs \ (ss' \ [last ws]) = ws" - using append_butlast_last_id[OF \ws \ \\, folded \ps \ vs \ ss' = butlast ws\] unfolding rassoc. + have "ps \ vs \ (ss' \ [last ws]) = ws" + using append_butlast_last_id[OF \ws \ \\, folded \ps \ vs \ ss' = butlast ws\] unfolding rassoc. have "s \ concat (ss' \ [last ws]) = su" using \s \ concat ss' = su'\ \su = su' \ last ws\ by fastforce - from less.prems(1)[OF \p u s \\<^sub>\ vs\ \ps \ vs \ (ss' \ [last ws]) = ws\ \concat ps \ p = pu\ \s \ concat (ss' \ [last ws]) = su\] + from less.prems(1)[OF \p u s \\<^sub>\ vs\ \ps \ vs \ (ss' \ [last ws]) = ws\ \concat ps \ p = pu\ \s \ concat (ss' \ [last ws]) = su\] show thesis. qed next assume not_or: "\ (hd ws \p pu \ last ws \s su)" hence "pu

ws \ \\] prefI'[OF \pu \ u \ su = concat ws\[symmetric]]] - ruler[reversed, OF concat_hd_pref[reversed, OF \ws \ \\] prefI'[reversed, OF \pu \ u \ su = concat ws\[symmetric, unfolded lassoc]]] by auto - from fac_interpretI[OF this \pu \ u \ su = concat ws\] + using ruler[OF concat_hd_pref[OF \ws \ \\] prefI'[OF \pu \ u \ su = concat ws\[symmetric]]] + ruler[reversed, OF concat_hd_pref[reversed, OF \ws \ \\] prefI'[reversed, OF \pu \ u \ su = concat ws\[symmetric, unfolded lassoc]]] by auto + from fac_interpI[OF this \pu \ u \ su = concat ws\] have "pu u su \\<^sub>\ ws". from less.prems(1)[OF this, of \ \] show thesis by simp qed qed qed -lemma obtain_fac_interp': assumes "u \f concat ws" and "u \ \" - obtains p s vs where "p u s \\<^sub>\ vs" and "vs \f ws" +lemma obtain_fac_interp': assumes "u \f concat ws" and "u \ \" + obtains p s vs where "p u s \\<^sub>\ vs" and "vs \f ws" proof- from facE[OF \u \f concat ws\] obtain pu su where "concat ws = pu \ u \ su". - from obtain_fac_interpret[OF this[symmetric] \u \ \\] that + from obtain_fac_interp[OF this[symmetric] \u \ \\] that show thesis - using facI' by metis -qed + using facI' by metis +qed + +lemma fac_pow_longE: assumes "w \f v\<^sup>@k" and "\<^bold>|v\<^bold>| \ \<^bold>|w\<^bold>|" + obtains m v1 v2 where "v1 \s v" "v2 \p v" "w = v1 \ v\<^sup>@m \ v2" + using assms +proof (cases "w = \ \ w = v") + assume "w = \ \ w = v" + then show thesis + by (rule disjE) (use that[of \ \ 0] in fastforce, use that[of \ \ 1] in auto) +next + assume "\ (w = \ \ w = v)" + hence "w \ \" and "w \ v" by blast+ + have "v\<^sup>@k = concat ([v]\<^sup>@k)" + by auto + from obtain_fac_interp'[OF \w \f v\<^sup>@k\[unfolded this] \w \ \\] + obtain p vs s where "p w s \\<^sub>\ vs" "vs \f [v] \<^sup>@ k". + note fac_interpD[OF this(1)] + obtain m where "vs = [v]\<^sup>@m" + using \vs \f [v] \<^sup>@ k\ unique_letter_fac_expE by meson + hence "concat vs = v\<^sup>@m" + by simp + from lenarg[OF \p \ w \ s = concat vs\, unfolded this lenmorph pow_len] + have "0 < m" + using \\<^bold>|v\<^bold>| \ \<^bold>|w\<^bold>|\ \\ (w = \ \ w = v)\ by force + hence "hd vs = v" and "last vs = v" + using \vs = [v]\<^sup>@m\ + by (simp_all add: hd_pow hd_pow[reversed]) + obtain v1 where "v = p \ v1" + using \p

unfolding \hd vs = v\ strict_prefix_def prefix_def by force + obtain v2 where "v = v2 \ s" + using \s unfolding \last vs = v\ strict_suffix_def suffix_def by force + have "m \ 1" + using \p \ w \ s = concat vs\ unfolding \concat vs = v\<^sup>@m\ + using \w \ v\ \\<^bold>|v\<^bold>| \ \<^bold>|w\<^bold>|\ by force + hence "2 \ m" + using \0 < m\ by linarith + from Suc_minus2[OF this] + have "concat vs = v \ v\<^sup>@(m-2) \ v" + unfolding pow_Suc'[symmetric] pow_Suc[symmetric] \concat vs = v\<^sup>@m\ by argo + hence "w = v1 \ v\<^sup>@(m-2) \ v2" + by (subst(asm) \v = p \ v1\, subst(asm) (2) \v = v2 \ s\) + (simp add: \p \ w \ s = concat vs\[symmetric]) + from that[OF _ _ this] + show thesis + using \v = p \ v1\ \v = v2 \ s\ by blast +qed + +lemma obtain_fac_interp_dec: assumes "w \ \G\" "u \f w" "u \ \" + obtains p s ws where "ws \ lists (G - {\})" "p u s \\<^sub>\ ws" "ws \f Dec G w" +proof- + from obtain_fac_interp'[OF _ \u \ \\, of "Dec G w", unfolded concat_dec[OF \w \ \G\\], OF \u \f w\] + obtain p s ws where *: "p u s \\<^sub>\ ws" "ws \f Dec G w". + have "ws \ lists (G - {\})" + using fac_in_lists[OF dec_in_lists'[OF \w \ \G\\] \ws \f Dec G w\]. + from that[OF this *] + show thesis. +qed + + +lemma fac_interp_inner: assumes "u \ \" and "p u s \\<^sub>\ ws" and "1 < \<^bold>|ws\<^bold>|" +shows "p\\<^sup>>(hd ws)\concat(butlast (tl ws))\(last ws)\<^sup><\s = u" +proof- +have "p

u \ s = concat ws" +using assms[unfolded factor_interpretation_def] by blast+ +have "last (tl ws) = last ws" +using last_tl long_list_tl[OF \1 < \<^bold>|ws\<^bold>|\] by blast +have ws_eq: "[hd ws] \ butlast (tl ws) \ [last ws] = ws" +using hd_tl[OF fac_interp_nemp[OF \u \ \\ \p u s \\<^sub>\ ws\]] append_butlast_last_id[OF long_list_tl[OF \1 < \<^bold>|ws\<^bold>|\], unfolded \last (tl ws) = last ws\] by simp +from arg_cong[OF this, of concat, unfolded concat_morph, unfolded concat_sing', folded \p \ u \ s = concat ws\] +have "(hd ws)\concat(butlast (tl ws))\(last ws) = p \ u \ s". +thus "p\\<^sup>>(hd ws)\concat(butlast (tl ws))\(last ws)\<^sup><\s = u" +unfolding cancel_right[of "p\\<^sup>>(hd ws)\concat (butlast (tl ws)) \ last ws\<^sup><\s" s u, symmetric] +unfolding rassoc rq_suf[OF ssufD1[OF \s ]] +unfolding cancel[of p "p\\<^sup>>hd ws \ concat (butlast (tl ws)) \ last ws" "u\s", symmetric] +unfolding lassoc lq_pref[OF sprefD1[OF \p

]]. +qed + + +lemma fac_interp_inner_len: assumes "u \ \" and "p u s \\<^sub>\ ws" +shows "\<^bold>|concat(butlast (tl ws))\<^bold>| < \<^bold>|u\<^bold>|" +proof (cases "\<^bold>|ws\<^bold>| \ 1") +assume "\<^bold>|ws\<^bold>| \ 1" +hence "tl ws = \" +using nemp_le_len by fastforce +thus ?thesis +using \u \ \\ by simp +next +assume neg: "\ \<^bold>|ws\<^bold>| \ 1" hence "1 < \<^bold>|ws\<^bold>|" by auto +from lenarg[OF fac_interp_inner[OF \u \ \\ \p u s \\<^sub>\ ws\ this]] \p u s \\<^sub>\ ws\ +show ?thesis +unfolding factor_interpretation_def lenmorph +using rq_ssuf[of s "last ws", folded length_greater_0_conv] +by linarith +qed lemma rev_in_set_map_rev_conv: "rev u \ set (map rev ws) \ u \ set ws" by auto lemma rev_fac_interp: assumes "p u s \\<^sub>\ ws" shows "(rev s) (rev u) (rev p) \\<^sub>\ rev (map rev ws)" -proof (rule fac_interpretI) - note fac_interpretE[OF assms] +proof (rule fac_interpI) + note fac_interpD[OF assms] show \rev s

using \s by (metis \p

\p \ u \ s = concat ws\ 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 p

by (metis \p \ u \ s = concat ws\ \s 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 \ rev u \ rev p = concat (rev (map rev ws))" using \p \ u \ s = concat ws\ by (metis append_assoc rev_append rev_concat rev_map) -qed +qed lemma rev_fac_interp_iff [reversal_rule]: "(rev s) (rev u) (rev p) \\<^sub>\ rev (map rev ws) \ p u s \\<^sub>\ ws" using rev_fac_interp - by (metis (no_types, lifting) map_rev_involution rev_map rev_rev_ident) + by (metis (no_types, lifting) map_rev_involution rev_map rev_rev_ident) + +lemma fac_interp_mid_fac: assumes "p u s \\<^sub>\ ws" + shows "concat (butlast (tl ws)) \f u" +proof(rule le_cases) + assume "2 \ \<^bold>|ws\<^bold>|" + note fac_interpD[OF \p u s \\<^sub>\ ws\] + mid_fac_ex[OF \2 \ \<^bold>|ws\<^bold>|\] + note ex = sprefD1[OF this(1)] sprefE[reversed, OF this(2)] + obtain p' where "hd ws = p \ p'" + using ex(1) prefixE + by blast + obtain s' where "last ws = s' \ s" + using \s by (blast elim: ssufE sufE) + show ?thesis + using \p \ u \ s = concat ws\ + unfolding arg_cong[OF \ws = [hd ws] \ butlast (tl ws) \ [last ws]\, of concat] + unfolding concat_morph concat_sing' + unfolding \hd ws = p \ p'\ \last ws = s' \ s\ + by simp +next + assume "\<^bold>|ws\<^bold>| \ 2" + hence "butlast (tl ws) = \" + using nemp_le_len by fastforce + thus ?thesis + by simp +qed + +definition disjoint_interpretation :: "'a list \ 'a list list \ 'a list \ 'a list list \ bool" ("_ _ _ \\<^sub>\ _" [51,51,51,51] 60) + where "p us s \\<^sub>\ ws \ p (concat us) s \\<^sub>\ ws \ + (\ u v. u \p us \ v \p ws \ p \ concat u \ concat v)" + +lemma disjoint_interpI: "p (concat us) s \\<^sub>\ ws \ + (\ u v. u \p us \ v \p ws \ p \ concat u \ concat v) \ p us s \\<^sub>\ ws" + unfolding disjoint_interpretation_def by blast + +lemma disjoint_interpI'[intro]: "p (concat us) s \\<^sub>\ ws \ + (\ u v. u \p us \ v \p ws \ p \ concat u \ concat v) \ p us s \\<^sub>\ ws" + unfolding disjoint_interpretation_def by blast + +lemma disj_interpD: "p us s \\<^sub>\ ws \ p (concat us) s \\<^sub>\ ws" + unfolding disjoint_interpretation_def by blast + +lemma disj_interpD1: assumes "p us s \\<^sub>\ ws" and "us' \p us" and "ws' \p ws" + shows "p \ concat us' \ concat ws'" + using assms unfolding disjoint_interpretation_def by blast + +lemma disj_interp_nemp: assumes "p us s \\<^sub>\ ws" + shows "p \ \" and "s \ \" + using disj_interpD1[OF assms emp_pref emp_pref] + disj_interpD1[OF assms self_pref self_pref, folded + fac_interpD(3)[OF disj_interpD, OF assms], unfolded cancel] by blast+ + +subsection "Factor intepretation of morphic images" + +context morphism +begin + +lemma image_fac_interp': assumes "w \f f z" "w \ \" + obtains p w_pred s where "w_pred \f z" "p w s \\<^sub>\ (map f\<^sup>\ w_pred)" +proof- + let ?fzs = "map f\<^sup>\ z" + have "w \f concat (map f\<^sup>\ z)" + by (simp add: assms(1) morph_concat_map) + + from obtain_fac_interp'[OF \w \f concat (map f\<^sup>\ z)\ \w \ \\] + obtain p s ws where "p w s \\<^sub>\ ws" "ws \f ?fzs" + by blast + + obtain w_pred where "ws = map f\<^sup>\ w_pred" "w_pred \f z" + using \ws \f map f\<^sup>\ z\ sublist_map_rightE by blast + + show ?thesis + using \p w s \\<^sub>\ ws\ \w_pred \f z\ \ws = map f\<^sup>\ w_pred\ that by blast +qed + +lemma image_fac_interp: assumes "u\w\v = f z" "w \ \" + obtains p w_pred s u_pred v_pred where + "u_pred\w_pred\v_pred = z" "p w s \\<^sub>\ (map f\<^sup>\ w_pred)" + "u = (f u_pred)\p" "v = s\(f v_pred)" +proof- + let ?fzs = "map f\<^sup>\ z" + + have "u\w\v = concat (map f\<^sup>\ z)" + by (simp add: assms(1) morph_concat_map) + + from obtain_fac_interp[OF \u\w\v = concat (map f\<^sup>\ z)\ \w \ \\] + obtain ps ss p s ws where "p w s \\<^sub>\ ws" "ps\ws\ss = ?fzs" "concat ps \ p = u" "s \ concat ss = v" + by metis + + obtain w_pred u_pred v_pred where "ws = map f\<^sup>\ w_pred" "ps = map f\<^sup>\ u_pred" + "ss = map f\<^sup>\ v_pred" "u_pred\w_pred\v_pred = z" + using \ps \ ws \ ss = map f\<^sup>\ z\[unfolded append_eq_map_conv] + by blast + + show ?thesis + using \concat ps \ p = u\ \p w s \\<^sub>\ ws\ \ps = map f\<^sup>\ u_pred\ \s \ concat ss = v\ \ss = map f\<^sup>\ v_pred\ \u_pred \ w_pred \ v_pred = z\ \ws = map f\<^sup>\ w_pred\ morph_concat_map that by blast +qed + +lemma image_fac_interp_mid: assumes "p w s \\<^sub>\ map f\<^sup>\ w_pred" "2 \ \<^bold>|w_pred\<^bold>|" + obtains pw sw where + "w = pw \ (f (butlast (tl w_pred))) \ sw" "p\pw = f [hd w_pred]" "sw\s = f [last w_pred]" +proof- + note fac_interpD[OF \p w s \\<^sub>\ map f\<^sup>\ w_pred\, unfolded morph_concat_map] + note butl = mid_fac_ex[OF \2 \ \<^bold>|w_pred\<^bold>|\] + + have "w_pred \ \" + using assms(2) by force + + obtain pw' where + "p \ pw' = hd (map f\<^sup>\ w_pred)" + using sprefE[OF \p

\ w_pred)\] prefixE by metis + hence pw': "p \ pw' = f [hd w_pred]" + unfolding core_def + unfolding hd_map[OF \w_pred \ \\, of "f\<^sup>\", unfolded core_def]. + + obtain sw' where + "sw' \ s = last (map f\<^sup>\ (w_pred))" + using sprefE[reversed, OF \s \ w_pred)\] suffix_def by metis + hence sw' : "sw' \ s = f [last (w_pred)]" + unfolding core_def + unfolding last_map[OF \w_pred \ \\, of "f\<^sup>\", unfolded core_def]. + + have "w = pw' \ f (butlast (tl w_pred)) \ sw'" + using \p \ w \ s = f w_pred\[unfolded arg_cong[OF butl, of f]] + unfolding morph + unfolding pw'[symmetric] sw'[symmetric] + by simp + thus ?thesis + using pw' sw' that by blast +qed + +end section Miscellanea subsection \Mismatch additions\ -lemma mismatch_pref_comm_len: assumes "w1 \ \{u,v}\" and "w2 \ \{u,v}\" and "p \p w1" +lemma mismatch_pref_comm_len: assumes "w1 \ \{u,v}\" and "w2 \ \{u,v}\" and "p \p w1" "u \ p \p v \ w2" and "\<^bold>|v\<^bold>| \ \<^bold>|p\<^bold>|" shows "u \ v = v \ u" proof (rule ccontr) assume "u \ v \ v \ u" - then interpret binary_code u v + then interpret binary_code u v by unfold_locales - show False - using bin_code_prefs bin_code_prefs[OF \w1 \ \{u,v}\\ \p \p w1\ \w2 \ \{u,v}\\ \\<^bold>|v\<^bold>| \ \<^bold>|p\<^bold>|\] - \u \ p \p v \ w2\ bin_code_prefs + show False + using bin_code_prefs[OF \w1 \ \{u,v}\\ \p \p w1\ \w2 \ \{u,v}\\ \\<^bold>|v\<^bold>| \ \<^bold>|p\<^bold>|\] + \u \ p \p v \ w2\ by blast qed -lemma mismatch_pref_comm: assumes "w1 \ \{u,v}\" and "w2 \ \{u,v}\" and +lemma mismatch_pref_comm: assumes "w1 \ \{u,v}\" and "w2 \ \{u,v}\" and "u \ w1 \ v \p v \ w2 \ u" -shows "u \ v = v \ u" +shows "u \ v = v \ u" using assms by mismatch -lemma mismatch_eq_comm: assumes "w1 \ \{u,v}\" and "w2 \ \{u,v}\" and +lemma mismatch_eq_comm: assumes "w1 \ \{u,v}\" and "w2 \ \{u,v}\" and "u \ w1 = v \ w2" shows "u \ v = v \ 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] + mismatch_suf_comm_len = mismatch_pref_comm_len[reversed, unfolded rassoc] subsection \Conjugate words with conjugate periods\ lemma conj_pers_conj_comm_aux: - assumes "(u \ v)\<^sup>@Suc k \ u = r \ s" and "(v \ u)\<^sup>@Suc l \ v = (s \ r)\<^sup>@Suc (Suc m)" + assumes "(u \ v)\<^sup>@k \ u = r \ s" and "(v \ u)\<^sup>@l \ v = (s \ r)\<^sup>@m" and "0 < k" "0 < l" and "2 \ m" shows "u \ v = v \ u" proof (rule nemp_comm) assume "u \ \" and "v \ \" hence "u \ v \ \" and "v \ u \ \" by blast+ - have "l \ 0" \ \impossible by a length argument\ + have "l \ 1" \ \impossible by a length argument\ proof (rule notI) - assume "l = 0" - hence "v \ u \ v = (s \ r)\<^sup>@ Suc(Suc m)" + assume "l = 1" + hence "v \ u \ v = (s \ r)\<^sup>@m" using assms(2) by simp - from lenarg[OF assms(1)] \u \ \\ - have "\<^bold>|v \ u\<^bold>| + \<^bold>|u\<^bold>| \ \<^bold>|r \ s\<^bold>|" - unfolding lenmorph pow_len by simp + have "\<^bold>|v \ u\<^bold>| + \<^bold>|u\<^bold>| \ \<^bold>|r \ s\<^bold>|" + unfolding lenmorph add.commute[of "\<^bold>|u\<^bold>|"] + lenarg[OF assms(1), unfolded lenmorph pow_len, symmetric] + using \0 < k\ by simp hence "\<^bold>|v \ u \ v \ u\<^bold>| \ 2*\<^bold>|r \ s\<^bold>|" - unfolding lenmorph pow_len by simp + unfolding lenmorph pow_len by simp hence "\<^bold>|v \ u \ v\<^bold>| < 2*\<^bold>|r \ s\<^bold>|" unfolding lenmorph pow_len using nemp_len[OF \u \ \\] by linarith - from this[unfolded \v \ u \ v = (s \ r)\<^sup>@ Suc(Suc m)\] + from this[unfolded \v \ u \ v = (s \ r)\<^sup>@m\] show False - unfolding lenmorph pow_len by simp + using mult_le_mono1[OF \2 \ m\, of "\<^bold>|r\<^bold>| + \<^bold>|s\<^bold>|"] + unfolding lenmorph pow_len add.commute[of "\<^bold>|s\<^bold>|"] by force qed \ \we can therefore use the Periodicity lemma\ - then obtain l' where "l = Suc l'" - using not0_implies_Suc by auto - let ?w = "(v \ u)\<^sup>@Suc l \ v" + hence "2 \ l" + using \0 < l\ by force + let ?w = "(v \ u)\<^sup>@l \ v" have per1: "?w \p (v \ u) \ ?w" - using \v \ u \ \\ per_rootD[of ?w "v \ u", unfolded per_eq] by blast + unfolding lassoc pow_comm[symmetric] by force have per2: "?w \p (s \ r) \ ?w" - unfolding assms(2) using pref_pow_ext' by blast + unfolding assms(2) using pref_pow_ext' by blast have len: "\<^bold>|v \ u\<^bold>| + \<^bold>|s \ r\<^bold>| \ \<^bold>|?w\<^bold>|" proof- have len1: "2*\<^bold>|s \ r\<^bold>| \ \<^bold>|?w\<^bold>|" - unfolding \(v \ u)\<^sup>@Suc l \ v = (s \ r)\<^sup>@Suc (Suc m)\ lenmorph pow_len by simp + using mult_le_mono1[OF \2 \ m\, of "\<^bold>|s\<^bold>| + \<^bold>|r\<^bold>|"] + unfolding \(v \ u)\<^sup>@l \ v = (s \ r)\<^sup>@m\ lenmorph pow_len. moreover have len2: "2*\<^bold>|v \ u\<^bold>| \ \<^bold>|?w\<^bold>|" - unfolding lenmorph pow_len \l = Suc l'\ by simp + using mult_le_mono1[OF \2 \ l\, of "\<^bold>|v\<^bold>| + \<^bold>|u\<^bold>|"] + unfolding lenmorph pow_len by linarith ultimately show ?thesis using len1 len2 by linarith qed from two_pers[OF per1 per2 len] have "(v \ u) \ (s \ r) = (s \ r) \ (v \ u)". - hence "(v \ u)\<^sup>@Suc l \ (s \ r)\<^sup>@Suc (Suc m) = (s \ r)\<^sup>@Suc (Suc m) \ (v \ u)\<^sup>@Suc l" + hence "(v \ u)\<^sup>@l \ (s \ r)\<^sup>@m = (s \ r)\<^sup>@m \ (v \ u)\<^sup>@l" using comm_add_exps by blast - from comm_drop_exp'[OF this[folded assms(2), unfolded rassoc cancel]] + from comm_drop_exp'[OF this[folded assms(2), unfolded rassoc cancel] \0 < l\] show "u \ v = v \ u" - unfolding rassoc cancel. + unfolding rassoc cancel by blast qed -lemma conj_pers_conj_comm: assumes "\ (v \ (u \ v)\<^sup>@(Suc k)) \ \ ((u \ v)\<^sup>@(Suc m) \ u)" +lemma conj_pers_conj_comm: assumes "\ (v \ (u \ v)\<^sup>@k) \ \ ((u \ v)\<^sup>@m \ u)" and "0 < k" and "0 < m" shows "u \ v = v \ u" proof (rule nemp_comm) - let ?v = "v \ (u \ v)\<^sup>@(Suc k)" and ?u = "(u \ v)\<^sup>@(Suc m) \ u" + let ?v = "v \ (u \ v)\<^sup>@k" and ?u = "(u \ v)\<^sup>@m \ u" assume "u \ \" and "v \ \" hence "u \ v \ \" and "?v \ \" and "?u \ \" by simp_all obtain r s where "r \ s = \ ?v" and "s \ r = \ ?u" - using conjugE[OF assms]. - then obtain k1 k2 where "?v = (r \ s)\<^sup>@Suc k1" and "?u = (s \ r)\<^sup>@Suc k2" - using primroot_expE[OF \?v \ \\] primroot_expE[OF \?u \ \\] by metis - hence eq: "(s \ r)\<^sup>@Suc k2 \ (r \ s)\<^sup>@Suc k1 = (u \ v)\<^sup>@(Suc m + Suc 0 + Suc k)" + using conjugE[OF assms(1)]. + then obtain k1 k2 where "?v = (r \ s)\<^sup>@k1" and "?u = (s \ r)\<^sup>@k2" and "0 < k1" and "0 < k2" + using primroot_expE[of ?u] primroot_expE[of ?v] unfolding shift_pow by metis + hence eq: "(s \ r)\<^sup>@k2 \ (r \ s)\<^sup>@k1 = (u \ v)\<^sup>@(m + 1 + k)" unfolding add_exps pow_one rassoc by simp - have ineq: "2 \ Suc m + Suc 0 + Suc k" - by simp - consider (two_two) "2 \ Suc k1 \ 2 \ Suc k2"| - (one_one) "Suc k1 = 1 \ Suc k2 = 1" | - (two_one) "2 \ Suc k1 \ Suc k2 = 1" | - (one_two) "Suc k1 = 1 \ 2 \ Suc k2" - unfolding numerals One_nat_def Suc_le_mono by fastforce - then show "u \ v = v \ u" + have ineq: "2 \ m + 1 + k" + using \0 < k\ by simp + consider (two_two) "2 \ k1 \ 2 \ k2"| + (one_one) "k1 = 1 \ k2 = 1" | + (two_one) "2 \ k1 \ k2 = 1" | + (one_two) "k1 = 1 \ 2 \ k2" + using \0 < k1\ \0 < k2\ by linarith + then show "u \ v = v \ u" proof (cases) case (two_two) with Lyndon_Schutzenberger(1)[OF eq _ _ ineq] have "(s \ r) \ (r \ s) = (r \ s) \ (s \ r)" using eqd_eq[of "s \ r" "r \ s" "r \ s" "s \ r"] by fastforce - from comm_add_exps[OF this, of "Suc k2" "Suc k1", folded \?v = (r \ s)\<^sup>@Suc k1\ \?u = (s \ r)\<^sup>@Suc k2\, folded shift_pow, unfolded pow_Suc] - have "(u \ v) \ ((u \ v) \<^sup>@ m \ u) \ ((v \ u) \ (v \ u) \<^sup>@ k \ v) = (v \ u) \ (((v \ u) \<^sup>@ k) \ v) \ ((u \ v) \ (u \ v) \<^sup>@ m \ u)" - unfolding rassoc. - from eqd_eq[OF this, unfolded lenmorph] + from comm_add_exps[OF this, of k2 k1, folded \?v = (r \ s)\<^sup>@k1\ \?u = (s \ r)\<^sup>@k2\] show "u \ v = v \ u" - by fastforce + by mismatch next case (one_one) - hence "(s \ r) \<^sup>@ Suc k2 \ (r \ s) \<^sup>@ Suc k1 = (s \ r) \ (r \ s)" + hence "(s \ r) \<^sup>@ k2 \ (r \ s) \<^sup>@ k1 = (s \ r) \ (r \ 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 \ r" "r \ s", OF conjugI'] + from eq[unfolded conjunct1[OF one_one] conjunct2[OF one_one] pow_1] + pow_nemp_imprim[OF ineq, folded eq[unfolded this]] + Lyndon_Schutzenberger_conjug[of "s \ r" "r \ s", OF conjugI'] have "(s \ r) \ (r \ s) = (r \ s) \ (s \ r)" by metis - from comm_add_exps[OF this, of "Suc k2" "Suc k1", folded \?v = (r \ s)\<^sup>@Suc k1\ \?u = (s \ r)\<^sup>@Suc k2\, folded shift_pow, unfolded pow_Suc] - have "(u \ v) \ ((u \ v) \<^sup>@ m \ u) \ ((v \ u) \ (v \ u) \<^sup>@ k \ v) = (v \ u) \ (((v \ u) \<^sup>@ k) \ v) \ ((u \ v) \ (u \ v) \<^sup>@ m \ u)" - unfolding rassoc. - from eqd_eq[OF this, unfolded lenmorph] + from comm_add_exps[OF this, of k2 k1, folded \?v = (r \ s)\<^sup>@k1\ \?u = (s \ r)\<^sup>@k2\, folded shift_pow] show "u \ v = v \ u" - by fastforce + by mismatch next case (two_one) hence "?u = s \ r" - using \?u = (s \ r)\<^sup>@Suc k2\ 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 \?v = (r \ s)\<^sup>@Suc k1\[folded shift_pow, unfolded this] - have "(v \ u) \<^sup>@ Suc k \ v = (r \ s)\<^sup>@Suc (Suc l)". - from conj_pers_conj_comm_aux[OF \?u = s \ r\ this] - show "u \ v = v \ u". + using \?u = (s \ r)\<^sup>@k2\ + by simp + from \?v = (r \ s)\<^sup>@k1\[folded shift_pow, unfolded this] + have "(v \ u) \<^sup>@ k \ v = (r \ s)\<^sup>@k1". + from conj_pers_conj_comm_aux[OF \?u = s \ r\ this \0 < m\ \0 < k\ ] + show "u \ v = v \ u" + using two_one by auto next case (one_two) hence "?v = r \ s" - using \?v = (r \ s)\<^sup>@Suc k1\ 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 \?u = (s \ r)\<^sup>@Suc k2\[unfolded this] - have "(u \ v) \<^sup>@ Suc m \ u = (s \ r) \<^sup>@ Suc (Suc l)". - from conj_pers_conj_comm_aux[OF \?v = r \ s\[folded shift_pow] this, symmetric] - show "u \ v = v \ u". + using \?v = (r \ s)\<^sup>@k1\ by simp + from \?u = (s \ r)\<^sup>@k2\[unfolded this] + have "(u \ v) \<^sup>@ m \ u = (s \ r) \<^sup>@ k2". + from conj_pers_conj_comm_aux[OF \?v = r \ s\[folded shift_pow] this \0 < k\ \0 < m\] + show "u \ v = v \ u" + using one_two by argo qed qed hide_fact conj_pers_conj_comm_aux subsection \Covering uvvu\ lemma uv_fac_uvv: assumes "p \ u \ v \p u \ v \ v" and "p \ \" and "p \s w" and "w \ \{u,v}\" shows "u \ v = v \ u" proof (rule nemp_comm) - assume "u \ \" and "v \ \" + assume "u \ \" and "v \ \" obtain s where "u \ v \ v = p \ u \ v \ s" using \p \ u \ v \p u \ v \ v\ by (auto simp add: prefix_def) obtain p' where "u \ p' = p \ u" and "p' \ v \ s = v \ v" using eqdE[of u "v \ v" "p \ u" "v \ s", unfolded rassoc, OF \u \ v \ v = p \ u \ v \ s\ suf_len']. hence "p' \ \" using \p \ \\ by force have "p' \ v \ s = v \ v" using \u \ v \ v = p \ u \ v \ s\ \u \ p' = p \ u\ cancel rassoc by metis from mid_sq[OF this] - have "v \ p' = p' \ v" by simp - from this primroot_prim[OF \v \ \\] - obtain r where "r = \ v" and "r = \ p'" and "primitive r" - unfolding comm_primroots[OF \v \ \\ \p' \ \\] by blast+ - have "w \ \{u, v}\" by fact - obtain m where "p' = r\<^sup>@m \ r" - using primroot_expE[OF \p' \ \\, folded \r = \ p'\] power_Suc2 by metis - hence "(u \ r\<^sup>@m) \ r \s (r \ w) \ u" - using \u \ p' = p \ u\ \p \s w\ unfolding suf_def by force + have "v \ p' = p' \ v" by simp + from this comm_primroots[OF \v \ \\ \p' \ \\] + have "\ v = \ p'" + by simp + have "w \ \{u, \ v}\" + using gen_prim[OF \w \ \{u, v}\\]. + obtain m where "p' = \ v\<^sup>@m" "0 < m" + using primroot_expE unfolding \\ v = \ p'\ by metis + have "(u \ \ v\<^sup>@(m-1)) \ \ v \s (\ v \ w) \ u" + using \p \s w\ + unfolding rassoc pow_pos'[OF \0 < m\, symmetric] \p' = \ v\<^sup>@m\[symmetric] \u \ p' = p \ u\ suffix_def by force + hence "u \ \ v = \ v \ u" + using \w \ \{u, \ v}\\ by mismatch - note mismatch_rule = mismatch_suf_comm_len[OF _ _ _ this, of "u \ r\<^sup>@m"] - have "u \ r = r \ u" - proof (rule mismatch_rule) - have "w \ \{r, u}\" - using \w \ \{u, v}\\ \r = \ v\ \v \ \\ doubleton_eq_iff gen_prim by metis - thus "r \ w \ \{r, u}\" by blast - show "\<^bold>|u\<^bold>| \ \<^bold>|u \ r \<^sup>@ m\<^bold>|" by simp - show "u \ r\<^sup>@m \ \{r, u}\" - by (simp add: gen_in hull.prod_cl power_in) - qed simp thus "u \ v = v \ u" - using \r = \ v\ comm_primroot_conv by auto + unfolding comm_primroot_conv[symmetric]. qed lemmas uv_fac_uvv_suf = uv_fac_uvv[reversed, unfolded rassoc] -lemma assumes "p \ u \ v \ u \ q = u \ v \ v \ u" and "p \ \" and "q \ \" - shows "u \ v = v \ u" - oops \ \counterexample: v = abaaba, u = a, p = aab, q = baa; aab.a.abaaba.a.baa = a.abaaba.abaaba.a\ -lemma uvu_pref_uvv: assumes "p \ u \ v \ v \ s = u \ v \ u \ q" and - "p

p w" and "s \p w'" and + +lemma "u \p v \ u' \p v' \ u \\<^sub>p u' \ u \ u \\<^sub>p u' \ u' \ u \\<^sub>p u' = v \\<^sub>p v'" + using lcp.absorb2 lcp.orderE lcp_rulers pref_compE by metis + +lemma comm_puv_pvs_eq_uq: assumes "p \ u \ v = u \ v \ p" and "p \ v \ s = u \ q" and + "p \p u" "q \p w" and "s \p w'" and "w \ \{u,v}\" and "w' \ \{u,v}\" and "\<^bold>|u\<^bold>| \ \<^bold>|s\<^bold>|" shows "u \ v = v \ u" -proof(rule nemp_comm) - \ \Preliminaries\ - assume "u \ \" and "v \ \" - hence "u \ v \ \" by blast - have "\<^bold>|p \ u \ v\<^bold>| \ \<^bold>|u \ v \ u\<^bold>|" - using \p

unfolding lenmorph by (simp add: prefix_length_less less_imp_le) - -\ \p commutes with @{term "u \ v"}\ - have "p \ (u \ v) = (u \ v) \ p" - by (rule pref_marker[of "u \ v \ u"], simp, rule eq_le_pref, unfold rassoc, fact+) - -\ \equality which will yield the main result\ - have "p \ v \ s = u \ q" - proof- - have "((u \ v) \ p) \ v \ s = (u \ v) \ u \ q" - unfolding \p \ u \ v = (u \ v) \ p\[symmetric] unfolding rassoc by fact - from this[unfolded rassoc cancel] - show ?thesis. - qed - hence "p \ v \ s \p u \ w" - using \q \p w\ by force - - then show "u \ v = v \ u" - proof (cases "p = \") +proof (rule ccontr) + assume "u \ v \ v \ u" + then interpret binary_code u v + by unfold_locales + write bin_code_lcp ("\") and + bin_code_mismatch_fst ("c\<^sub>0") and + bin_code_mismatch_snd ("c\<^sub>1") + have "\<^bold>|\\<^bold>| < \<^bold>|v \ s\<^bold>|" + using \\<^bold>|u\<^bold>| \ \<^bold>|s\<^bold>|\ bin_lcp_short by force + show False + proof (cases) assume "p = \" - thm mismatch_pref_comm - note local_rule = mismatch_pref_comm_len[OF _ _ \s \p w'\ _ \\<^bold>|u\<^bold>| \ \<^bold>|s\<^bold>|\, of v w, symmetric] - show "u \ v = v \ u" - proof (rule local_rule) - show "w \ \{v, u}\" - using \w \ \{u,v}\\ by (simp add: insert_commute) - show "v \ s \p u \ w" - using \p = \\ \p \ v \ s = u \ q\ \q \p w\ by simp - show "w' \ \{v, u}\" - using \w' \ \{u, v}\\ insert_commute by metis - qed + hence "v \ s = u \ q" + using \p \ v \ s = u \ q\ by fastforce + with \\<^bold>|\\<^bold>| < \<^bold>|v \ s\<^bold>|\ \\<^bold>|\\<^bold>| < \<^bold>|v \ s\<^bold>|\[unfolded this] + have "\ \ [c\<^sub>1] \p v \ s" and "\ \ [c\<^sub>0] \p u \ q" + using \s \p w'\ \w' \ \{u,v}\\ \q \p w\ \w \ \{u,v}\\ + bin_lcp_mismatch_pref_all_snd bin_lcp_mismatch_pref_all_fst \v \ s = u \ q\ + by blast+ + thus False + unfolding \v \ s = u \ q\ using bin_mismatch_neq + by (simp add: same_sing_pref) next - assume "p \ \" - show "u \ v = v \ u" - proof (rule ccontr) - obtain r where "r = \ p" and "r = \ (u \ v)" - using \p \ u \ v = (u \ v) \ p\[symmetric, unfolded comm_primroots[OF \u \ v \ \\ \p \ \\]] by blast - obtain k m where "r\<^sup>@k = p" and "r\<^sup>@m = u \ v" - using \u \ v \ \\ \p \ \\ \r = \ p\ \r = \ (u \ v)\ primroot_expE by metis - \ \Idea: - maximal r-prefix of @{term "p \ v \ s"} is @{term "p \ bin_code_lcp"}, since the maximal r-prefix of - @{term "v \ u"} is @{term "v \ u \\<^sub>p u \ v"}; - on the other hand, maximal r-prefix of @{term "u \ w \ bin_code_lcp"} is at least @{term "u \ bin_code_lcp"}, - since this is, in particular, a prefix of @{term "u \ v \ u \ v \ r*"}\ - assume "u \ v \ v \ u" - then interpret binary_code u v - by (unfold_locales) - term "p \ v \ s = u \ q" - have "p \ bin_code_lcp \ [bin_code_mismatch_snd] \p u \ w \ bin_code_lcp" - proof- - have "p \ bin_code_lcp \ [bin_code_mismatch_snd] \p p \ v \ w' \ bin_code_lcp" - unfolding pref_cancel_conv - using pref_prolong[OF bin_snd_mismatch bin_lcp_pref_all_hull, OF \w' \ \{u,v}\\]. - note local_rule = ruler_le[OF this] - have "p \ bin_code_lcp \ [bin_code_mismatch_snd] \p p \ v \ s" - proof (rule local_rule) - show "p \ v \ s \p p \ v \ w' \ bin_code_lcp" - using \s \p w'\ by fastforce - show "\<^bold>|p \ bin_code_lcp \ [bin_code_mismatch_snd]\<^bold>| \ \<^bold>|p \ v \ s\<^bold>|" - using bin_lcp_short \\<^bold>|u\<^bold>| \ \<^bold>|s\<^bold>|\ by force + assume "p \ \" + show False + proof- + \ \Preliminaries\ + have "u \ \" and "v \ \" and "u \ v \ v \ u" + by (simp_all add: bin_fst_nemp bin_snd_nemp non_comm) + have "w \ u \ v \ \{u, v}\" + using \w \ \{u, v}\\ by blast + have "\<^bold>|w \ u \ v\<^bold>| \ \<^bold>|\\<^bold>|" + using bin_lcp_short by auto + \ \The main idea: compare maximum @{term p}-prefixes\ + \ \the maximum @{term p}-prefix of @{term "p \ v \ s"}\ + have p_pref1: "p \ v \ s \\<^sub>p p \ p \ v \ s = p \ \" + using bin_per_root_max_pref_short[of p s w', OF _ \s \p w'\ \w' \ \{u, v}\\] + \p \ \\ \p \ u \ v = u \ v \ p\ unfolding lcp_ext_left cancel take_all[OF less_imp_le[OF\\<^bold>|\\<^bold>| <\<^bold>|v \ s\<^bold>|\]] by force + \ \the maximum @{term p}-prefix of @{term "u \ w \ u \ v"} is at least @{term "u \ \"}\ + have p_pref2: "u \ \ \p u \ (w \ u \ v) \\<^sub>p p \ u \ (w \ u \ v)" + using bin_root_max_pref_long[OF \p \ u \ v = u \ v \ p\ self_pref \w \ u \ v \ \{u, v}\\ \\<^bold>|\\<^bold>| \ \<^bold>|w \ u \ v\<^bold>| \]. + \ \But those maximum @{term p}-prefixes are equal\ + have "u \ w \ u \ v \\<^sub>p p \ u \ w \ u \ v = p \ v \ s \\<^sub>p p \ p \ v \ s" + proof(rule lcp_rulers') + show "\ p \ v \ s \ p \ p \ v \ s" + proof (rule notI) + assume "p \ v \ s \ p \ p \ v \ s" + hence "p \ v \ s \\<^sub>p p \ p \ v \ s = p \ v \ s" + using \p \ \\ lcp.absorb1 pref_compE same_sufix_nil by meson + from this[unfolded p_pref1 cancel] + show False + using bin_lcp_short \\<^bold>|u\<^bold>| \ \<^bold>|s\<^bold>|\ by force qed - from pref_ext[OF pref_trans[OF this \p \ v \ s \p u \ w\]] - show "p \ bin_code_lcp \ [bin_code_mismatch_snd] \p u \ w \ bin_code_lcp" - by force + show "p \ v \ s \p u \ (w \ u \ v)" "p \ p \ v \ s \p p \ u \ w \ u \ v" + by (simp_all add: assms(2) assms(4)) qed - moreover - have "p \ bin_code_lcp \ [bin_code_mismatch_fst] \p u \ w \ bin_code_lcp" - proof (rule pref_trans[of _ "u \ bin_code_lcp"]) - show "u \ bin_code_lcp \p u \ w \ bin_code_lcp" - using bin_lcp_pref_all_hull[OF \w \ \{u,v}\\] by auto - show "p \ bin_code_lcp \ [bin_code_mismatch_fst] \p u \ bin_code_lcp" - proof (rule ruler_le) - show "\<^bold>|p \ bin_code_lcp \ [bin_code_mismatch_fst]\<^bold>| \ \<^bold>|u \ bin_code_lcp\<^bold>|" - unfolding lenmorph using prefix_length_less[OF \p

] by simp - show "u \ bin_code_lcp \p r \<^sup>@ (m + m)" - unfolding add_exps \r\<^sup>@m = u \ v\ rassoc pref_cancel_conv - using bin_lcp_pref_snd_fst pref_prolong prefix_def by metis - show "p \ bin_code_lcp \ [bin_code_mismatch_fst] \p r \<^sup>@ (m + m)" - proof (rule pref_trans) - show "p \ bin_code_lcp \ [bin_code_mismatch_fst] \p r\<^sup>@(k+m)" - unfolding power_add \r \<^sup>@ k = p\ \r \<^sup>@ m = u \ v\ pref_cancel_conv - using bin_fst_mismatch'. - show "r \<^sup>@ (k + m) \p r \<^sup>@ (m + m)" - unfolding power_add \r \<^sup>@ k = p\ \r \<^sup>@ m = u \ v\ \p \ u \ v = (u \ v) \ p\ - using \p

by force - qed - qed - qed - ultimately show False - using bin_mismatch_neq by (force simp add: prefix_def) + from p_pref2[unfolded rassoc this p_pref1] + have "p = u" + using \p \p u\ pref_cancel_right by force + thus False + using \p \ u \ v = u \ v \ p\ non_comm by blast qed qed qed + +lemma assumes "u \ v \ v \ u = p \ u \ v \ u \ q" and "p \ \" and "q \ \" + shows "u \ v = v \ u" + oops \ \counterexample: v = abaaba, u = a, p = aab, q = baa; aab.a.abaaba.a.baa = a.abaaba.abaaba.a\ + + +lemma uvu_pref_uvv: assumes "p \ u \ v \ v \ s = u \ v \ u \ q" and + "p \p u" and "q \p w" and "s \p w'" and + "w \ \{u,v}\" and "w' \ \{u,v}\" and "\<^bold>|u\<^bold>| \ \<^bold>|s\<^bold>|" +shows "u \ v = v \ u" +proof(rule nemp_comm) + have "\<^bold>|p \ u \ v\<^bold>| \ \<^bold>|u \ v \ u\<^bold>|" + using \p \p u\ unfolding lenmorph + by (simp add: prefix_length_le) + +\ \p commutes with @{term "u \ v"}\ + have "p \ (u \ v) = (u \ v) \ p" + by (rule pref_marker[of "u \ v \ u"], force) + (rule eq_le_pref, use assms in force, fact) + + have "p \ v \ s = u \ q" + proof- + have "((u \ v) \ p) \ v \ s = (u \ v) \ u \ q" + unfolding \p \ u \ v = (u \ v) \ p\[symmetric] unfolding rassoc by fact + from this[unfolded rassoc cancel] + show ?thesis. + qed + + from comm_puv_pvs_eq_uq[OF \p \ (u \ v) = (u \ v) \ p\[unfolded rassoc] this assms(2-)] + show "u \ v = v \ u". +qed + + lemma uvu_pref_uvvu: assumes "p \ u \ v \ v \ u = u \ v \ u \ q" and - "p

p w" and " w \ \{u,v}\" + "p \p u" and "q \p w" and " w \ \{u,v}\" shows "u \ v = v \ u" - using uvu_pref_uvv[OF \p \ u \ v \ v \ u = u \ v \ u \ q\ \p

\q \p w\ _ \w \ \{u,v}\\, of u] + using uvu_pref_uvv[OF \p \ u \ v \ v \ u = u \ v \ u \ q\ \p \p u\ \q \p w\ _ \w \ \{u,v}\\, of u] by blast -lemma uvu_pref_uvvu_interpret: assumes interp: "p u \ v \ v \ u s \\<^sub>\ ws" and +lemma uvu_pref_uvvu_interp: assumes interp: "p u \ v \ v \ u s \\<^sub>\ ws" and "[u, v, u] \p ws" and "ws \ lists {u,v}" shows "u \ v = v \ u" proof- - note fac_interpretE[OF interp] + note fac_interpD[OF interp] obtain ws' where "[u,v,u] \ ws' = ws" and "ws' \ lists {u,v}" using \[u, v, u] \p ws\ \ws \ lists {u,v}\ by (force simp add: prefix_def) have "p \ u \ v \ v \ u \ s = u \ v \ u \ concat ws'" using \p \ (u \ v \ v \ u) \ s = concat ws\[folded \[u,v,u] \ ws' = ws\, unfolded concat_morph rassoc] by simp from lenarg[OF this, unfolded lenmorph] have "\<^bold>|s\<^bold>| \ \<^bold>|concat ws'\<^bold>|" by auto - hence "s \s concat ws'" + hence "s \s concat ws'" using eqd[reversed, OF \p \ u \ v \ v \ u \ s = u \ v \ u \ concat ws'\[unfolded lassoc]] by blast note local_rule = uvu_pref_uvv[of p u v u "concat ws'\<^sup><\s" "concat ws'" u] show "u \ v = v \ u" proof (rule local_rule) - show "p

p u" using \p

pref_hd_eq[OF \[u, v, u] \p ws\ list.distinct(1)[of u "[v,u]", symmetric]] by force have "p \ u \ v \ v \ u \ s = u \ v \ u \ (concat ws'\<^sup><\s) \ s" - using \p \ u \ v \ v \ u \ s = u \ v \ u \ concat ws'\ unfolding rq_suf[OF \s \s concat ws'\]. - thus "p \ u \ v \ v \ u = u \ v \ u \ concat ws'\<^sup><\s" + using \p \ u \ v \ v \ u \ s = u \ v \ u \ concat ws'\ unfolding rq_suf[OF \s \s concat ws'\]. + thus "p \ u \ v \ v \ u = u \ v \ u \ concat ws'\<^sup><\s" by simp show "concat ws' \ \{u,v}\" using \ws' \ lists {u,v}\ by blast show "concat ws'\<^sup><\s \p concat ws'" using rq_suf[OF \s \s concat ws'\] by fast - qed auto + 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 \ v \ v \ u s \\<^sub>\ ws \ [u, v, u] \s ws \ ws \ lists {u,v} \ u \ v = v \ u" - by (rule uvu_pref_uvvu_interpret[reversed, unfolded rassoc clean_emp, symmetric, of p u v s ws], + by (rule uvu_pref_uvvu_interp[reversed, unfolded rassoc emp_simps, symmetric, of p u v s ws], simp, force, simp add: image_iff rev_in_lists rev_map) subsection \Conjugate words\ lemma conjug_pref_suf_mismatch: assumes "w1 \ \{r\s,s\r}\" and "w2 \ \{r\s,s\r}\" and "r \ w1 = w2 \ s" shows "r = s \ r = \ \ s = \" proof (rule ccontr) assume "\ (r = s \ r = \ \ s = \)" hence "r \ s" and "r \ \" and "s \ \" by simp_all from assms - show False + show False proof (induct "\<^bold>|w1\<^bold>|" arbitrary: w1 w2 rule: less_induct) case less have "w1 \ \{r,s}\" using \w1 \ \{r\s,s\r}\\ by force obtain w1' where "(w1 = \ \ w1 = r \ s \ w1' \ w1 = s \ r \ w1') \ w1' \ \{r\s,s\r}\" - using hull.cases[OF \w1 \ \{r\s,s\r}\\] empty_iff insert_iff mult_assoc \w1 \ \{r \ s, s \ r}\\ by metis + using hull.cases[OF \w1 \ \{r\s,s\r}\\] empty_iff insert_iff rassoc \w1 \ \{r \ s, s \ r}\\ by metis hence "w1' \ \{r\s,s\r}\" and cases1: "(w1 = \ \ w1 = r \ s \ w1' \ w1 = s \ r \ w1')" by blast+ hence "w1' \ \{r,s}\" by force obtain w2' where "(w2 = \ \ w2 = r \ s \ w2' \ w2 = s \ r \ w2') \ w2' \ \{r\s,s\r}\" - using hull.cases[OF \w2 \ \{r\s,s\r}\\] empty_iff insert_iff mult_assoc \w1 \ \{r \ s, s \ r}\\ by metis + using hull.cases[OF \w2 \ \{r\s,s\r}\\] empty_iff insert_iff rassoc \w1 \ \{r \ s, s \ r}\\ by metis hence "w2' \ \{r\s,s\r}\" and cases2: "(w2 = \ \ w2 = r \ s \ w2' \ w2 = s \ r \ w2')" by blast+ hence "w2' \ \{r,s}\" by force - consider (empty2) "w2 = \" | (sr2) "w2 = s \ r \ w2'" | (rs2) "w2 = r \ s \ w2'"using cases2 by blast + consider (empty2) "w2 = \" | (sr2) "w2 = s \ r \ w2'" | (rs2) "w2 = r \ s \ w2'"using cases2 by blast thus False proof (cases) case empty2 consider (empty1) "w1 = \" | (sr1) "w1 = s \ r \ w1'" | (rs1) "w1 = r \ s \ w1'" - using cases1 by blast + using cases1 by blast thus False proof (cases) case empty1 - show False + show False using \r \ w1 = w2 \ s\[unfolded empty1 empty2 rassoc] \r \ s\ by simp next case sr1 show False using \r \ w1 = w2 \ s\[unfolded sr1 empty2 rassoc] \r \ \\ fac_triv by auto next case rs1 show False - using \r \ w1 = w2 \ s\[unfolded rs1 empty2 rassoc clean_emp] \r \ \\ - fac_triv[of "r \ r" s w1', unfolded rassoc] by force + using \r \ w1 = w2 \ s\[unfolded rs1 empty2 rassoc emp_simps] \r \ \\ + fac_triv[of "r \ r" s w1', unfolded rassoc] by force qed next case sr2 have "r \ s = s \ r" - using \w2' \ \{r,s}\\ \w1 \ \{r,s}\\ \r \ w1 = w2 \ s\[unfolded sr2 rassoc] + using \w2' \ \{r,s}\\ \w1 \ \{r,s}\\ \r \ w1 = w2 \ s\[unfolded sr2 rassoc] by (mismatch) - consider (empty1) "w1 = \" | (sr1) "w1 = s \ r \ w1'" | (rs1) "w1 = r \ s \ w1'" using cases1 by blast + consider (empty1) "w1 = \" | (sr1) "w1 = s \ r \ w1'" | (rs1) "w1 = r \ s \ w1'" using cases1 by blast thus False proof (cases) case empty1 - then show False - using \r \ w1 = w2 \ s\[unfolded sr2 empty1 rassoc cancel clean_emp, symmetric] \s \ \\ fac_triv by blast + then show False + using \r \ w1 = w2 \ s\[unfolded sr2 empty1 rassoc cancel emp_simps, symmetric] \s \ \\ fac_triv by blast next case rs1 - then have "r \ s = s \ r" - using \w2' \ \{r,s}\\ \w1' \ \{r,s}\\ \r \ w1 = w2 \ s\[unfolded rs1 sr2 rassoc cancel] + then have "r \ s = s \ r" + using \w2' \ \{r,s}\\ \w1' \ \{r,s}\\ \r \ w1 = w2 \ s\[unfolded rs1 sr2 rassoc cancel] by mismatch - hence "r \ w1' = w2' \ s" + hence "r \ w1' = w2' \ s" using \r \ w1 = w2 \ s\[unfolded rs1 sr2] rassoc cancel by metis - from less.hyps[OF _ \w1' \ \{r \ s, s \ r}\\ \w2' \ \{r \ s, s \ r}\\ this] - show False + from less.hyps[OF _ \w1' \ \{r \ s, s \ r}\\ \w2' \ \{r \ s, s \ r}\\ this] + show False using lenarg[OF \w1 = r \ s \ w1'\, unfolded lenmorph] nemp_len[OF \s \ \\] by linarith next case sr1 - then have "r \ s = s \ r" - using \w2' \ \{r,s}\\ \w1' \ \{r,s}\\ \r \ w1 = w2 \ s\[unfolded sr1 sr2 rassoc cancel] + then have "r \ s = s \ r" + using \w2' \ \{r,s}\\ \w1' \ \{r,s}\\ \r \ w1 = w2 \ s\[unfolded sr1 sr2 rassoc cancel] by mismatch - hence "r \ w1' = w2' \ s" + hence "r \ w1' = w2' \ s" using \r \ w1 = w2 \ s\[unfolded sr1 sr2] rassoc cancel by metis - from less.hyps[OF _ \w1' \ \{r \ s, s \ r}\\ \w2' \ \{r \ s, s \ r}\\ this] - show False - using less.hyps[OF _ \w1' \ \{r \ s, s \ r}\\ \w2' \ \{r \ s, s \ r}\\ \r \ w1' = w2' \ s\] + from less.hyps[OF _ \w1' \ \{r \ s, s \ r}\\ \w2' \ \{r \ s, s \ r}\\ this] + show False + using less.hyps[OF _ \w1' \ \{r \ s, s \ r}\\ \w2' \ \{r \ s, s \ r}\\ \r \ w1' = w2' \ s\] lenarg[OF \w1 = s \ r \ w1'\, unfolded lenmorph] nemp_len[OF \s \ \\] by linarith qed next case rs2 - consider (empty1) "w1 = \" | (sr1) "w1 = s \ r \ w1'" | (rs1) "w1 = r \ s \ w1'" using cases1 by blast + consider (empty1) "w1 = \" | (sr1) "w1 = s \ r \ w1'" | (rs1) "w1 = r \ s \ w1'" using cases1 by blast thus False proof (cases) case empty1 - then show False + then show False using \r \ w1 = w2 \ s\[unfolded rs2 empty1 rassoc cancel] \s \ \\ by blast next case rs1 - then have "r \ s = s \ r" - using \w2' \ \{r,s}\\ \w1' \ \{r,s}\\ \r \ w1 = w2 \ s\[unfolded rs2 rs1 rassoc cancel] + then have "r \ s = s \ r" + using \w2' \ \{r,s}\\ \w1' \ \{r,s}\\ \r \ w1 = w2 \ s\[unfolded rs2 rs1 rassoc cancel] by mismatch - hence "r \ w1' = w2' \ s" + hence "r \ w1' = w2' \ s" using \r \ w1 = w2 \ s\[unfolded rs1 rs2] rassoc cancel by metis - from less.hyps[OF _ \w1' \ \{r \ s, s \ r}\\ \w2' \ \{r \ s, s \ r}\\ this] - show False - using less.hyps[OF _ \w1' \ \{r \ s, s \ r}\\ \w2' \ \{r \ s, s \ r}\\ \r \ w1' = w2' \ s\] + from less.hyps[OF _ \w1' \ \{r \ s, s \ r}\\ \w2' \ \{r \ s, s \ r}\\ this] + show False + using less.hyps[OF _ \w1' \ \{r \ s, s \ r}\\ \w2' \ \{r \ s, s \ r}\\ \r \ w1' = w2' \ s\] lenarg[OF \w1 = r \ s \ w1'\, unfolded lenmorph] nemp_len[OF \s \ \\] by linarith next case sr1 - then show False - using less.hyps[OF _ \w1' \ \{r \ s, s \ r}\\ \w2' \ \{r \ s, s \ r}\\ \r \ w1 = w2 \ s\[unfolded rs2 sr1 rassoc cancel]] + then show False + using less.hyps[OF _ \w1' \ \{r \ s, s \ r}\\ \w2' \ \{r \ s, s \ r}\\ \r \ w1 = w2 \ s\[unfolded rs2 sr1 rassoc cancel]] lenarg[OF \w1 = s \ r \ w1'\, unfolded lenmorph] nemp_len[OF \s \ \\] by linarith qed qed qed qed lemma conjug_conjug_primroots: assumes "u \ \" and "r \ \" and "\ (u \ v) = r \ s" and "\ (v \ u) = s \ r" obtains k m where "(r \ s)\<^sup>@k \ r = u" and "(s \ r)\<^sup>@m \ s = v" proof- have "v \ u \ \" and "u \ v \ \" using \u \ \\ by blast+ have "\ (s \ r) = s \ r" - using primroot_idemp[OF \v \ u \ \\, unfolded \\ (v \ u) = s \ r\]. - obtain n where "(r \ s)\<^sup>@Suc n = u \ v" - using primroot_expE[OF \u \ v \ \\, unfolded \\ (u \ v) = r \ s\]. - obtain n' where "(s \ r)\<^sup>@Suc n' = v \ u" - using primroot_expE[OF \v \ u \ \\, unfolded \\ (v \ u) = s \ r\]. + using primroot_idemp[of "v \ u", unfolded \\ (v \ u) = s \ r\]. + obtain n where "(r \ s)\<^sup>@n = u \ v" "0 < n" + using primroot_expE[unfolded \\ (u \ v) = r \ s\] + using assms(3) by metis + obtain n' where "(s \ r)\<^sup>@ n' = v \ u" "0 < n'" + using primroot_expE[of "v \ u",unfolded \\ (v \ u) = s \ r\]. have "(s \ u) \ (s \ r) = (s \ r) \ (s \ u)" proof (rule pref_marker) - show "(s \ u) \ s \ r \p s \ (r \ s)\<^sup>@(Suc n+ Suc n)" - unfolding rassoc add_exps \(r \ s)\<^sup>@Suc n = u \ v\ - unfolding lassoc \(s \ r)\<^sup>@Suc n' = v \ u\[symmetric] pow_Suc by force - have aux: "(s \ r) \ s \ (r \ s) \<^sup>@ (Suc n + Suc n) = s \ (r \ s)\<^sup>@(Suc n + Suc n) \ (r \ s)" - by (simp add: pow_comm) - show "s \ (r \ s) \<^sup>@ (Suc n + Suc n) \p (s \ r) \ s \ (r \ s) \<^sup>@ (Suc n + Suc n)" - unfolding aux pref_cancel_conv by blast + show "(s \ u) \ s \ r \p s \ (r \ s)\<^sup>@(n+ n)" + unfolding rassoc add_exps \(r \ s)\<^sup>@n = u \ v\ + unfolding lassoc \(s \ r)\<^sup>@n' = v \ u\[symmetric] using \0 < n'\ by comparison + show "s \ (r \ s) \<^sup>@ (n + n) \p (s \ r) \ s \ (r \ s) \<^sup>@ (n + n)" + by comparison qed from comm_primroot_exp[OF primroot_nemp[OF \v \ u \ \\, unfolded \\ (v \ u) = s \ r\] this] - obtain k where "(s \ r)\<^sup>@Suc k = s \ u" - using nemp_pow_SucE[OF suf_nemp[OF \u \ \\, of s]] \\ (s \ r) = s \ r\ by metis - hence u: "(r \ s)\<^sup>@k \ r = u" - unfolding pow_Suc rassoc cancel shift_pow by fast - from exp_pref_cancel[OF \(r \ s)\<^sup>@Suc n = u \ v\[folded this, unfolded rassoc, symmetric]] - have "r \ v = (r \ s) \<^sup>@ (Suc n - k)". - from nemp_pow_SucE[OF _ this] - obtain m where "r \ v = (r \ s)\<^sup>@Suc m" - using \r \ \\ by blast - from this[unfolded pow_Suc rassoc cancel shift_pow[symmetric], symmetric] - have v: "(s \ r)\<^sup>@m \ s = v". + obtain k where "(s \ r)\<^sup>@k = s \ u" + unfolding \\ (s \ r) = s \ r\. + from suf_nemp[OF \u \ \\, of s, folded this] + have "0 < k" + by blast + have u: "(r \ s)\<^sup>@(k-1) \ r = u" + using \(s \ r)\<^sup>@k = s \ u\ unfolding pow_pos[OF \0 < k\] rassoc cancel shift_pow by fast + from exp_pref_cancel[OF \(r \ s)\<^sup>@n = u \ v\[folded this, unfolded rassoc, symmetric]] + have "r \ v = (r \ s) \<^sup>@ (n + 1 - k)" + using \0 < k\ by fastforce + from pref_nemp[OF \r \ \\, of v, unfolded this] + have "0 < n + 1 - k" + by blast + from \r \ v = (r \ s) \<^sup>@ (n + 1 - k)\[unfolded pow_pos[OF \0 < n + 1 - k\] rassoc cancel shift_pow[symmetric], symmetric] + have v: "(s \ r)\<^sup>@(n + 1 - k - 1) \ s = v". show thesis using that[OF u v]. -qed +qed subsection \Predicate ``commutes''\ definition commutes :: "'a list set \ bool" where "commutes A = (\x y. x \ A \ y \ A \ x\y = y\x)" lemma commutesE: "commutes A \ x \ A \ y \ A \ x\y = y\x" using commutes_def by blast lemma commutes_root: assumes "commutes A" obtains r where "\x. x \ A \ x \ 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 "\x. x \ A \ x \ r*" and "primitive r" - using commutes_root[OF assms] emp_all_roots prim_sing + using commutes_root[OF assms] emp_all_roots prim_sing primroot_is_root primroot_prim root_trans by metis lemma commutesI [intro]: "(\x y. x \ A \ y \ A \ x\y = y\x) \ commutes A" unfolding commutes_def by blast lemma commutesI': assumes "x \ \" and "\y. y \ A \ x\y = y\x" shows "commutes A" proof- have "\x' y'. x' \ A \ y' \ A \ x'\y' = y'\x'" proof- fix x' y' assume "x' \ A" "y' \ A" hence "x'\x = x\x'" and "y'\x = x\y'" using assms(2) by auto+ from comm_trans[OF this assms(1)] show "x'\y' = y'\x'". qed thus ?thesis by (simp add: commutesI) qed -lemma commutesI_root: "\x \ A. x \ t* \ commutes A" +lemma commutesI_root[intro]: "\x \ A. x \ t* \ commutes A" by (meson comm_root commutesI) lemma commutes_sub: "commutes A \ B \ A \ commutes B" by (simp add: commutes_def subsetD) lemma commutes_insert: "commutes A \ x \ A \ x \ \ \ x\y = y\x \ commutes (insert y A)" using commutesE[of A x] commutesI'[of x "insert y A"] insertE by blast lemma commutes_emp [simp]: "commutes {\, w}" by (simp add: commutes_def) -lemma commutes_emp'[simp]: "commutes {w, \}" +lemma commutes_emp'[simp]: "commutes {w, \}" by (simp add: commutes_def) -lemma commutes_cancel: "commutes (insert y (insert (x \ y) A)) \ commutes (insert y (insert x A))" -proof - fix u v - assume com: "commutes (insert y (insert (x \ y) A))" and - "u \ insert y (insert x A)" "v \ insert y (insert x A)" - then consider "u = y" | "u = x" | "u \ A" - by blast - note u_cases = this - consider "v = y" | "v = x" | "v \ A" - using \v \ insert y (insert x A)\ by blast - note v_cases = this - have "y \ (x \ y) = (x \ y) \ y" - using \commutes (insert y (insert (x \ y) A))\ commutesE by blast - hence "x \ y = y \ x" - by simp - have[simp]: "w \ A \ y \ w = w \ y" for w - using com by (simp add: commutesE) - hence[simp]: "w \ A \ x \ w = w \ x" for w - using \x \ y = y \ x\ com commutesE - comm_trans insertCI shifts_rev(37) by metis - have[simp]: "u \ A \ v \ A \ u \ v = v \ u" - using com commutesE by blast - show "u \ v = v \ u" - by (rule u_cases, (rule v_cases, simp_all add: \x \ y = y \ x\ com)+) +lemma commutes_cancel: assumes "y \ A" and "x \ y \ A" and "commutes A" + shows "commutes (insert x A)" +proof- + from commutes_root[OF \commutes A\] + obtain r where "(\x. x \ A \ x \ r*)" + by metis + hence "y \ r*" and "x \ y \ r*" + using \y \ A\ \x \ y \ A\ by blast+ + hence "x \ r*" + using root_suf_cancel by auto + thus "commutes (insert x A)" + using \\x. x \ A \ x \ r*\ by blast qed +lemma commutes_cancel': assumes "x \ A" and "x \ y \ A" and "commutes A" + shows "commutes (insert y A)" +proof- + from commutes_root[OF \commutes A\] + obtain r where "(\x. x \ A \ x \ r*)" + by metis + hence "x \ r*" and "x \ y \ r*" + using \x \ A\ \x \ y \ A\ by blast+ + hence "y \ r*" + using root_pref_cancel by auto + thus "commutes (insert y A)" + using \\x. x \ A \ x \ r*\ by blast +qed + + + subsection \Strong elementary lemmas\ text\Discovered by smt\ lemma xyx_per_comm: assumes "x\y\x \p q\x\y\x" and "q \ \" and "q \p y \ q" shows "x\y = y\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) + proof(cases) assume "x \ y \p q" from pref_marker[OF \q \p y \ q\ this] show "x \ y = y \ x". -next +next have "(x \ y) \ x \p q \ x \ y \ x" unfolding rassoc by fact assume "\ x \ y \p q" - hence "q \p x \ y" + hence "q \p x \ y" using ruler_prefE[OF \(x \ y) \ x \p q \ x \ y \ x\] by argo from pref_prolong[OF \q \p y \ q\ this, unfolded lassoc] have"q \p (y \ x) \ y". from ruler_pref'[OF this, THEN disjE] \q \p x \ y\ - have "q \p y \ x" - using pref_trans[OF _ \q \p x \ y\, of "y \ x", THEN pref_comm_eq] by metis + have "q \p y \ x" + using pref_trans[OF _ \q \p x \ y\, of "y \ x", THEN pref_comm_eq] by metis from pref_cancel'[OF this, of x] have "x \ q = q \ x" - using pref_marker[OF \x \ y \ x \p q \ x \ y \ x\, of x] by blast + using pref_marker[OF \x \ y \ x \p q \ x \ y \ x\, of x] by blast hence "x \ y \ x \p x \ x \ y \ x" using root_comm_root[OF _ _ \q \ \\, of "x \ y \ x" x] \x \ y \ x \p q \ x \ y \ x\ by fast thus "x\y = y\x" by mismatch qed lemma two_elem_root_suf_comm: assumes "u \p v \ u" and "v \s p \ u" and "p \ \{u,v}\" shows "u \ v = v \ u" using root_suf_comm[OF \u \p v \ u\ two_elem_suf[OF \v \s p \ u\ \p \ \{u,v}\\], symmetric]. -lemma two_elem_root_suf_comm': assumes "u \p v \ u" and "q \s p" and "q \ u \ v = v \ q \ u" and "p \ \{u,v}\" - shows "u \ v = v \ u" -proof (rule nemp_comm) - assume "u \ \" and "v \ \" - have "p \ \{u, \ v}\" - using gen_prim[OF \v \ \\ \p \ \{u,v}\\]. - - have "(q \ u) \ v = v \ (q \ u)" - using \q \ u \ v = v \ q \ u\ by fastforce - hence "(q \ u) \ \ v = \ v \ (q \ u)" - unfolding comm_primroot_conv[OF \v \ \\]. - have "u \p \ v \ u" - using \u \p v \ u\ \v \ \\ comm_primroot_conv root_comm_root by metis - have "\ v \s q \ u" - using suf_nemp[OF \u \ \\] primroot_suf \(q \ u) \ v = v \ q \ u\ \v \ \\ comm_primroots by metis - hence "\ v \s p \ u" - using suf_trans \q \s p\ by (auto simp add: suf_def) - from two_elem_root_suf_comm[OF \u \p \ v \ u\ this \p \ \{u,\ v}\\] - have "u \ \ v = \ v \ u". - thus "u \ v = v \ u" - using \v \ \\ comm_primroot_conv by metis -qed + subsection \Binary words without a letter square\ -lemma no_repetition_list: +lemma no_repetition_list: assumes "set ws \ {a,b}" and not_per: "\ ws \p [a,b] \ ws" "\ ws \p [b,a] \ ws" - and not_square: "\ [a,a] \f ws" and "\ [b,b] \f ws" + and not_square: "\ [a,a] \f ws" and "\ [b,b] \f ws" shows False using assms -proof (induction ws, simp) +proof (induction ws) case (Cons d ws) - show ?case + show ?case proof (rule "Cons.IH") - show "set ws \ {a,b}" + show "set ws \ {a,b}" using \set (d # ws) \ {a, b}\ by auto have "ws \ \" using "Cons.IH" Cons.prems by force from hd_tl[OF this] - have "hd ws \ d" - using Cons.prems(1,4-5) hd_pref[OF \ws \ \\] by force - thus "\ [a, a] \f ws" and "\ [b, b] \f ws" + have "hd ws \ d" + using Cons.prems(1,4-5) hd_pref[OF \ws \ \\] by force + thus "\ [a, a] \f ws" and "\ [b, b] \f ws" using Cons.prems(4-5) unfolding sublist_code(3) by blast+ show "\ ws \p [a, b] \ ws" proof (rule notI) assume "ws \p [a, b] \ ws" from pref_hd_eq[OF this \ws \ \\] have "hd ws = a" by simp hence "d = b" using \set (d # ws) \ {a, b}\ \hd ws \ d\ by auto show False using \ws \p [a, b] \ ws\ \\ d # ws \p [b, a] \ d # ws\[unfolded \d = b\] by force qed show "\ ws \p [b, a] \ ws" proof (rule notI) assume "ws \p [b, a] \ ws" from pref_hd_eq[OF this \ws \ \\] have "hd ws = b" by simp hence "d = a" using \set (d # ws) \ {a, b}\ \hd ws \ d\ by auto show False using \ws \p [b, a] \ ws\ \\ d # ws \p [a, b] \ d # ws\[unfolded \d = a\] by force qed qed -qed +qed simp -lemma hd_Cons_append[intro,simp]: "hd ((a#v) \ u) = a" +lemma hd_Cons_append[intro,simp]: "hd ((a#v) \ u) = a" by simp -lemma no_repetition_list_bin: +lemma no_repetition_list_bin: fixes ws :: "binA list" - assumes not_square: "\ c. \ [c,c] \f ws" + assumes not_square: "\ c. \ [c,c] \f ws" shows "ws \p [hd ws, 1-(hd ws)] \ ws" -proof (cases "ws = \", simp) +proof (cases "ws = \") assume "ws \ \" have set: "set ws \ {hd ws, 1-hd ws}" - using swap_UNIV by auto + using swap_UNIV by auto have "\ ws \p [1 - hd ws, hd ws] \ ws" using pref_hd_eq[OF _ \ws \ \\, of "[1 - hd ws, hd ws] \ ws"] bin_swap_neq' - unfolding hd_Cons_append by blast - from no_repetition_list[OF set _ this not_square not_square] - show "ws \p [hd ws, 1-(hd ws)] \ ws" by blast -qed + unfolding hd_Cons_append by blast + from no_repetition_list[OF set _ this not_square not_square] + show "ws \p [hd ws, 1-(hd ws)] \ ws" by blast +qed simp -lemma per_root_hd_last_root: assumes "ws \p [a,b] \ ws" and "hd ws \ last ws" +lemma per_root_hd_last_root: assumes "ws \p [a,b] \ ws" and "hd ws \ last ws" shows "ws \ [a,b]*" using assms proof (induction "\<^bold>|ws\<^bold>|" arbitrary: ws rule: less_induct) case less then show ?case - proof (cases "ws = \", simp) + proof (cases "ws = \") assume "ws \ \" with \hd ws \ last ws\ have *: "[hd ws, hd (tl ws)] \ tl (tl ws) = ws" - using append_Cons last_ConsL[of "tl ws" "hd ws"] list.exhaust_sel[of ws] hd_tl by metis + 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 \ws \ \\ by auto have "[hd ws, hd (tl ws)] \ tl (tl ws) \p [a,b] \ ws " unfolding * using \ws \p [a, b] \ ws\. hence "[a,b] = [hd ws, hd (tl ws)]" by simp hence "hd ws = a" by simp - have "tl (tl ws) \p [a,b] \ tl (tl ws)" + have "tl (tl ws) \p [a,b] \ tl (tl ws)" unfolding pref_cancel_conv[of "[a,b]" "tl (tl ws)", symmetric] \[a,b] = [hd ws, hd (tl ws)]\ * - using \ws \p [a, b] \ ws\[unfolded \[a,b] = [hd ws, hd (tl ws)]\]. + using \ws \p [a, b] \ ws\[unfolded \[a,b] = [hd ws, hd (tl ws)]\]. have "tl (tl ws) \ [a, b]*" - proof (cases "tl (tl ws) = \", simp) + proof (cases "tl (tl ws) = \") assume "tl (tl ws) \ \" from pref_hd_eq[OF \tl (tl ws) \p [a, b] \ tl (tl ws)\ this] have "hd (tl (tl ws)) = a" by simp have "last (tl (tl ws)) = last ws" - using \tl (tl ws) \ \\ last_tl tl_Nil by metis + using \tl (tl ws) \ \\ last_tl tl_Nil by metis from \hd ws \ last ws\[unfolded \hd ws =a\, folded this \hd (tl (tl ws)) = a\] have "hd (tl (tl ws)) \ last (tl (tl ws))". from less.hyps[OF ind \tl (tl ws) \p [a,b] \ tl (tl ws)\ this] show "tl (tl ws) \ [a, b]*". - qed + qed simp thus "ws \ [a,b]*" unfolding add_root[of "[a,b]" "tl(tl ws)", symmetric] *[folded \[a,b] = [hd ws, hd (tl ws)]\ ]. - qed + qed simp qed -lemma no_cyclic_repetition_list: +lemma no_cyclic_repetition_list: assumes "set ws \ {a,b}" "ws \ [a,b]*" "ws \ [b,a]*" "hd ws \ last ws" - "\ [a,a] \f ws" "\ [b,b] \f ws" + "\ [a,a] \f ws" "\ [b,b] \f ws" shows False using per_root_hd_last_root[OF _ \hd ws \ last ws\] \ws \ [a,b]*\ \ws \ [b,a]*\ no_repetition_list[OF assms(1) _ _ assms(5-6)] by blast subsection \Three covers\ \ \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)$ \ -lemma three_covers_example: - assumes - v: "v = [0::nat]" and - t: "t = ([1] \ [0]\<^sup>@Suc j)\<^sup>@Suc (m + l) \ [1,0] " and - r: "r = [0,1] \ ([0]\<^sup>@Suc j \ [1])\<^sup>@Suc (m + l)" and - t': "t' = ([1] \ [0]\<^sup>@Suc j)\<^sup>@m \ [1,0] " and - r': "r' = [0,1] \ ([0]\<^sup>@Suc j \ [1])\<^sup>@l" and - w: "w = [0] \ ([1] \ [0]\<^sup>@Suc j)\<^sup>@Suc (m + l) \ [1,0]" - shows "w = v \ t" and "w = r \ v" and "w = r' \ v\<^sup>@Suc j \ t'" and "t'

" and + t: "t = (\ \ \\<^sup>@(j+1))\<^sup>@(m + l + 1) \ \ \ \ " and + r: "r = \ \ \ \ (\\<^sup>@(j+1) \ \)\<^sup>@(m + l + 1)" and + t': "t' = (\ \ \\<^sup>@(j + 1))\<^sup>@m \ \ \ \ " and + r': "r' = \ \ \ \ (\\<^sup>@(j + 1) \ \)\<^sup>@l" and + w: "w = \ \ (\ \ \\<^sup>@(j + 1))\<^sup>@(m + l + 1) \ \ \ \ " + shows "w = v \ t" and "w = r \ v" and "w = r' \ v\<^sup>@(j + 1) \ t'" and "t'

t" unfolding w v t.. show "w = r \ v" unfolding w r v by comparison + find_theorems "?u \ ?u\<^sup>@?j = ?u\<^sup>@?j \ ?u" show "t'

([0]\<^sup>@Suc j \ [1])\<^sup>@ m \ [0]\<^sup>@j \ r'" + unfolding t t' unfolding add.assoc unfolding add.commute[of l] + unfolding add_exps rassoc spref_cancel_conv unfolding pow_1 + unfolding rassoc spref_cancel_conv + unfolding lassoc shifts(20) + unfolding rassoc by blast + have "r = \ \ \ \ (\\<^sup>@Suc j \ \)\<^sup>@ m \ \\<^sup>@j \ r'" unfolding r' r by comparison - thus "r' v\<^sup>@Suc j \ t'" - unfolding w r' v t' - by comparison + show "w = r' \ v\<^sup>@(j + 1) \ t'" + unfolding w r' v t' + by comparison qed lemma three_covers_pers: \ \alias Old Good Lemma\ - assumes "w = v \ t" and "w = r' \ v\<^sup>@Suc j \ t'" and "w = r \ v" and + assumes "w = v \ t" and "w = r' \ v\<^sup>@j \ t'" and "w = r \ v" and "0 < j" and "r' |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>|" + "(\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|) + (\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|) = \<^bold>|w\<^bold>| + 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 ?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 \ \" - using \w = v \ t\ \t'

by auto + using \w = v \ t\ \t'

by auto obtain "r''" where "r'' \ r' = r" and "r'' \ \" - using ssufD[OF \r' ] sufD by blast - hence "w \p r'' \ w" - using assms unfolding pow_Suc using rassoc triv_pref by metis + using ssufD[OF \r' ] sufD by blast + have "w

w" + using per_rootI[OF _ \r'' \ \\, of w] \w = r \ v\ \w = r' \ v \<^sup>@ j \ t'\ \r'' \ r' = r\ + unfolding pow_pos[OF \0 < j\] using rassoc triv_pref by metis thus "period w ?per_r" - using lenarg[OF \r'' \ r' = r\] period_I[OF \w \ \\ \r'' \ \\ \w \p r'' \ w\] unfolding lenmorph - by (metis add_diff_cancel_right') + using lenarg[OF \r'' \ r' = r\] periodI[OF \w \ \\ \w

w\] + unfolding lenmorph + by (metis add_diff_cancel_right') have "\<^bold>|r'\<^bold>| < \<^bold>|r\<^bold>|" using suffix_length_less[OF \r' ]. - obtain "t''" where "t' \ t'' = t" and "t'' \ \" - using sprefD[OF \t'

] prefD by blast - hence "w \s w \ t''" - using assms unfolding pow_Suc2 using rassoc triv_suf by metis have "\<^bold>|t'\<^bold>| < \<^bold>|t\<^bold>|" using prefix_length_less[OF \t'

]. - show "period w ?per_t" - using lenarg[OF \t' \ t'' = t\] period_I[reversed, OF \w \ \\ \t'' \ \\ \w \s w \ t''\ ] 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 \w = r' \ v\<^sup>@Suc j \ t'\] + obtain t'' where "t' \ t'' = t" and "t'' \ \" + using \t'

by (blast elim: spref_exE) + have "w t''" + using per_rootI[reversed, OF _ \t'' \ \\, of w] + \w = v \ t\ \w = r' \ v \<^sup>@ j \ t'\ \t' \ t'' = t\ + unfolding pow_pos'[OF \0 < j\] using rassoc triv_suf by metis + thus "period w ?per_t" + using lenarg[OF \t' \ t'' = t\] periodI[reversed, OF \w \ \\ \w t''\] + unfolding lenmorph + by (metis add_diff_cancel_left') + show eq: "?per_t + ?per_r = \<^bold>|w\<^bold>| + j*\<^bold>|v\<^bold>| - 2*\<^bold>|v\<^bold>|" + using lenarg[OF \w = r' \ v\<^sup>@ j \ t'\] lenarg[OF \w = v \ t\] lenarg[OF \w = r \ v\] \\<^bold>|t'\<^bold>| < \<^bold>|t\<^bold>|\ \\<^bold>|r'\<^bold>| < \<^bold>|r\<^bold>|\ unfolding pow_len lenmorph by force qed -lemma three_covers_per0: assumes "w = v \ t" and "w = r' \ v\<^sup>@Suc j \ t'" and "w = r \ v" and - "r' |t'\<^bold>| \ \<^bold>|r'\<^bold>|" +lemma three_covers_per0: assumes "w = v \ t" and "w = r' \ v\<^sup>@ j \ t'" and "w = r \ v" and "0 < j" + "r' |t'\<^bold>| \ \<^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 ?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 \ \" using prim_nemp[OF \primitive v\]. - have "w \ \" using \w = v \ t\ \t'

by blast - note prefix_length_less[OF \t'

] prefix_length_less[reversed, OF \r' ] + have "w \ \" + using \w = v \ t\ \v \ \\ by blast + note prefix_length_less[OF \t'

] prefix_length_less[reversed, OF \r' ] have "?gcd \ 0" - using \\<^bold>|t'\<^bold>| < \<^bold>|t\<^bold>|\ 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 \w = v \ t\ \w = r' \ v \<^sup>@ Suc j \ t'\ \w = r \ v\ \r' \t'

]. + using gcd_eq_0_iff zero_less_diff'[OF \\<^bold>|t'\<^bold>| < \<^bold>|t\<^bold>|\] by simp + have "period w ?per_t" and "period w ?per_r" + and eq: "?per_t + ?per_r = \<^bold>|w\<^bold>| + j*\<^bold>|v\<^bold>| - 2*\<^bold>|v\<^bold>|" + using three_covers_pers[OF \w = v \ t\ \w = r' \ v \<^sup>@ j \ t'\ \w = r \ v\ \0 < j\ \r' \t'

]. obtain "r''" where "r'' \ r' = r" and "r'' \ \" - using ssufD[OF \r' ] sufD by blast - hence "w \p r'' \ w" - using less.prems unfolding pow_Suc using rassoc triv_pref by metis - obtain "t''" where "t' \ t'' = t" and "t'' \ \" + using ssufD[OF \r' ] sufD by blast + hence "w \p r'' \ w" + using less.prems unfolding pow_pos[OF \0 < j\] using rassoc triv_pref by metis + obtain "t''" where "t' \ t'' = t" and "t'' \ \" using sprefD[OF \t'

] prefD by blast show "period w ?gcd" proof (cases) have local_rule: "a - c \ b \ k + a - c - b \ k" for a b c k :: nat by simp - assume "Suc j*\<^bold>|v\<^bold>| - 2*\<^bold>|v\<^bold>| \ ?gcd" \ \Condition allowing to use the Periodicity lemma\ - from local_rule[OF this] + assume "j*\<^bold>|v\<^bold>| - 2*\<^bold>|v\<^bold>| \ ?gcd" \ \Condition allowing to use the Periodicity lemma\ + from local_rule[OF this] have len: "?per_t + ?per_r - ?gcd \ \<^bold>|w\<^bold>|" - unfolding eq. + unfolding eq. show "period w ?gcd" using per_lemma[OF \period w ?per_t\ \period w ?per_r\ len]. - next - assume "\ Suc j*\<^bold>|v\<^bold>| - 2*\<^bold>|v\<^bold>| \ ?gcd" \ \Periods are too long for the Periodicity lemma\ - hence "?gcd \ \<^bold>|v\<^sup>@Suc j\<^bold>| - 2*\<^bold>|v\<^bold>|" \ \But then we have a potential for using the Periodicity lemma on the power of v's\ + next + assume "\ j*\<^bold>|v\<^bold>| - 2*\<^bold>|v\<^bold>| \ ?gcd" \ \Periods are too long for the Periodicity lemma\ + hence "?gcd \ \<^bold>|v\<^sup>@j\<^bold>| - 2*\<^bold>|v\<^bold>|" \ \But then we have a potential for using the Periodicity lemma on the power of v's\ unfolding pow_len by linarith - have "\<^bold>|v \<^sup>@ Suc j\<^bold>| - Suc (Suc 0) * \<^bold>|v\<^bold>| + \<^bold>|v\<^bold>| \ \<^bold>|v \<^sup>@ Suc j\<^bold>|" - by simp - with add_le_mono1[OF \?gcd \ \<^bold>|v\<^sup>@Suc j\<^bold>| - 2*\<^bold>|v\<^bold>|\, of "\<^bold>|v\<^bold>|"] - have "?gcd + \<^bold>|v\<^bold>| \ \<^bold>|v \<^sup>@ Suc j\<^bold>|" - unfolding numerals using le_trans by blast + hence "?gcd + \<^bold>|v\<^bold>| \ \<^bold>|v \<^sup>@ j\<^bold>|" + using \?gcd \ 0\ by linarith + show "period w ?gcd" proof (cases) assume "\<^bold>|r'\<^bold>| = \<^bold>|t'\<^bold>|" \ \The trivial case\ hence "\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>| = \<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|" using conj_len[OF \w = v \ t\[unfolded \w = r \ v\]] by force show "period w (gcd (\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|) (\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|))" unfolding \\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>| = \<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|\ gcd_idem_nat using \period w (\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|)\. next assume "\<^bold>|r'\<^bold>| \ \<^bold>|t'\<^bold>|" \ \The nontrivial case\ - hence "\<^bold>|t'\<^bold>| < \<^bold>|r'\<^bold>|" using \\<^bold>|t'\<^bold>| \ \<^bold>|r'\<^bold>|\ by force - have "r' \ v

\<^bold>|r'\<^bold>| < \<^bold>|r\<^bold>|\ \r'' \ r' = r\ \w \p r'' \ w\ \w = r \ v\ by force - obtain p where "r' \ v = v \ p" - using ruler_le[OF triv_pref[of v t , folded \w = v \ t\], of "r' \ v"] - unfolding lenmorph \w = r' \ v\<^sup>@Suc j \ t'\[unfolded pow_Suc] rassoc + hence "\<^bold>|t'\<^bold>| < \<^bold>|r'\<^bold>|" + using \\<^bold>|t'\<^bold>| \ \<^bold>|r'\<^bold>|\ by force + have "r' \ v

\<^bold>|r'\<^bold>| < \<^bold>|r\<^bold>|\ \r'' \ r' = r\ \w \p r'' \ w\ \w = r \ v\ by force + obtain p where "r' \ v = v \ p" + using ruler_le[OF triv_pref[of v t , folded \w = v \ t\], of "r' \ v"] + unfolding lenmorph \w = r' \ v\<^sup>@j \ t'\[unfolded pow_pos[OF \0 < j\]] rassoc by (force simp add: prefix_def) - from \w = r' \ v\<^sup>@Suc j \ t'\[unfolded pow_Suc lassoc this \w = v \ t\, unfolded rassoc cancel] + from \w = r' \ v\<^sup>@j \ t'\[unfolded pow_pos[OF \0 < j\] lassoc this \w = v \ t\, unfolded rassoc cancel] have "p \p t" - by blast + by blast have "\<^bold>|v \ p\<^bold>| < \<^bold>|w\<^bold>|" using prefix_length_less[OF \r' \ v

, unfolded \r' \ v = v \ p\]. have "v \ p \s w" \ \r'v is a long border of w\ using \r' \ v = v \ p\ \w = r \ v\ \r' same_suffix_suffix ssufD by metis have "\<^bold>|r'\<^bold>| = \<^bold>|p\<^bold>|" using conj_len[OF \r' \ v = v \ p\]. - note \\<^bold>|t'\<^bold>| \ \<^bold>|r'\<^bold>|\[unfolded \\<^bold>|r'\<^bold>| = \<^bold>|p\<^bold>|\] + note \\<^bold>|t'\<^bold>| \ \<^bold>|r'\<^bold>|\[unfolded \\<^bold>|r'\<^bold>| = \<^bold>|p\<^bold>|\] hence "t'

t = p \ v \<^sup>@ j \ t'\ \t' \ t'' = t\ \\<^bold>|r'\<^bold>| = \<^bold>|p\<^bold>|\ \\<^bold>|t'\<^bold>| < \<^bold>|r'\<^bold>|\ \p \p t\ pref_prod_long_less by metis + using \t = p \ v \<^sup>@ (j - 1) \ t'\ \t' \ t'' = t\ \\<^bold>|r'\<^bold>| = \<^bold>|p\<^bold>|\ \\<^bold>|t'\<^bold>| < \<^bold>|r'\<^bold>|\ \p \p t\ pref_prod_long_less by metis + hence "p \ \" + by auto show ?thesis - proof (cases) - assume "\<^bold>|v \ p\<^bold>| \ \<^bold>|v\<^sup>@Suc j \ t'\<^bold>|" \ \The border does not cover the whole power of v's. + proof (cases) + assume "\<^bold>|v \ p\<^bold>| \ \<^bold>|v\<^sup>@j \ t'\<^bold>|" \ \The border does not cover the whole power of v's. In this case, everything commutes\ have "\ (rev v) = rev (\ v)" using \v \ \\ primroot_rev by auto from pref_marker_ext[reversed, OF \\<^bold>|t'\<^bold>| \ \<^bold>|p\<^bold>|\ \v \ \\] - suf_prod_le[OF \v \ p \s w\[unfolded \w = r' \ v\<^sup>@Suc j \ t'\] \\<^bold>|v \ p\<^bold>| \ \<^bold>|v\<^sup>@Suc j \ t'\<^bold>|\] - obtain k where "p = v\<^sup>@k \ t'" + suf_prod_le[OF \v \ p \s w\[unfolded \w = r' \ v\<^sup>@j \ t'\] \\<^bold>|v \ p\<^bold>| \ \<^bold>|v\<^sup>@j \ t'\<^bold>|\] + obtain k where "p = v\<^sup>@k \ t'" unfolding prim_self_root[OF \primitive v\]. hence "p \p v\<^sup>@k \ p" using \t'

by simp - from root_comm_root[OF this power_commutes[symmetric]] + from root_comm_root[OF this pow_comm[symmetric]] have "p \p v \ p" - using \\<^bold>|r'\<^bold>| = \<^bold>|p\<^bold>|\ \\<^bold>|r'\<^bold>| \ \<^bold>|t'\<^bold>|\ \p = v \<^sup>@ k \ t'\ by force - hence "p = r'" + using \\<^bold>|r'\<^bold>| = \<^bold>|p\<^bold>|\ \\<^bold>|r'\<^bold>| \ \<^bold>|t'\<^bold>|\ \p = v \<^sup>@ k \ t'\ by force + hence "p = r'" using \\<^bold>|r'\<^bold>| = \<^bold>|p\<^bold>|\ \r' \ v = v \ p\ pref_prod_eq by metis note \r' \ v = v \ p\[folded this] \r' \ v = v \ p\[unfolded this] then obtain er' where "r' = v\<^sup>@er'" using \primitive v\ by auto from \p \ v = v \ p\[unfolded \p = v\<^sup>@k \ t'\ lassoc pow_comm[symmetric], unfolded rassoc cancel] have "t' \ v = v \ t'". then obtain et' where "t' = v\<^sup>@et'" - using \primitive v\ by auto + using \primitive v\ by auto have "t \ v = v \ t" - by (simp add: pow_comm \p = r'\ \r' \ v = v \ r'\ \t = p \ v \<^sup>@ j \ t'\ \t' \ v = v \ t'\) + by (simp add: pow_comm \p = r'\ \r' \ v = v \ r'\ \t = p \ v \<^sup>@ (j - 1) \ t'\ \t' \ v = v \ t'\) then obtain et where "t = v\<^sup>@et" - using \primitive v\ by auto + using \primitive v\ by auto have "r \ v = v \ r" using \t \ v = v \ t\ cancel_right \w = v \ t\ \w = r \ v\ by metis then obtain er where "r = v\<^sup>@er" - using \primitive v\ by auto + using \primitive v\ by auto have "w \ v = v \ w" by (simp add: \r \ v = v \ r\ \w = r \ v\) then obtain ew where "w = v\<^sup>@ew" - using \primitive v\ by auto + using \primitive v\ by auto hence "period w \<^bold>|v\<^bold>|" - using \v \ \\ \w \ v = v \ w\ \w \ \\ by blast + using \v \ \\ \w \ v = v \ w\ \w \ \\ by blast have dift: "\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>| = (et - et')*\<^bold>|v\<^bold>|" using lenarg[OF \t = v\<^sup>@et\] lenarg[OF \t' = v\<^sup>@et'\] unfolding lenmorph pow_len - by (simp add: diff_mult_distrib) + by (simp add: diff_mult_distrib) have difr: "(\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|) = (er - er')*\<^bold>|v\<^bold>|" using lenarg[OF \r = v\<^sup>@er\] lenarg[OF \r' = v\<^sup>@er'\] unfolding lenmorph pow_len - by (simp add: diff_mult_distrib) + 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 \ 0" - using nemp_len[OF \v \ \\] per_positive[OF \period w (\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|)\] gcd_nat.neutr_eq_iff mult_is_0 by metis + hence "0 < g" + using nemp_len[OF \v \ \\] per_not_zero[OF \period w (\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|)\] + gcd_nat.neutr_eq_iff[of "\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|" "\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|"] mult_is_0[of g "\<^bold>|v\<^bold>|"] + by force from per_mult[OF \period w \<^bold>|v\<^bold>|\ this] show ?thesis - unfolding g. + unfolding g. next - assume "\ \<^bold>|v \ p\<^bold>| \ \<^bold>|v \<^sup>@ Suc j \ t'\<^bold>|" \ \The border covers the whole power. An induction is available.\ - then obtain ri' where "v \ p = ri'\v\<^sup>@Suc j \ t'" and "ri' \s r'" - using \v \ p \s w\ unfolding \w = r' \ v\<^sup>@Suc j \ t'\ - using suffix_append suffix_length_le by blast - hence "ri' r' \ v = v \ p\ cancel_right less.prems(2) less.prems(3) less.prems(4) suffix_order.le_neq_trans by metis + assume "\ \<^bold>|v \ p\<^bold>| \ \<^bold>|v \<^sup>@ j \ t'\<^bold>|" \ \The border covers the whole power. An induction is available.\ + then obtain ri' where "v \ p = ri'\ v\<^sup>@j \ t'" and "ri' \s r'" + using \v \ p \s w\ unfolding \w = r' \ v\<^sup>@j \ t'\ + using suffix_append suffix_length_le by blast + from len_less_neq[OF \\<^bold>|v \ p\<^bold>| < \<^bold>|w\<^bold>|\, unfolded this(1) \w = r' \ v\<^sup>@j \ t'\] this(2) + have "ri' |p\<^bold>| - \<^bold>|t'\<^bold>|) (\<^bold>|r'\<^bold>| - \<^bold>|ri'\<^bold>|) = ?gcd" \ \The two gcd's are the same\ proof- have "\<^bold>|r'\<^bold>| \ \<^bold>|r\<^bold>|" - by (simp add: \\<^bold>|r'\<^bold>| < \<^bold>|r\<^bold>|\ dual_order.strict_implies_order) + by (simp add: \\<^bold>|r'\<^bold>| < \<^bold>|r\<^bold>|\ dual_order.strict_implies_order) have "\<^bold>|t\<^bold>| = \<^bold>|r\<^bold>|" using lenarg[OF \w = v \ t\] unfolding lenarg[OF \w = r \ v\] lenmorph by auto have e1: "\<^bold>|r'\<^bold>| - \<^bold>|ri'\<^bold>| = \<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|" - using lenarg[OF \v \ p = ri'\v\<^sup>@Suc j \ t'\[folded \r' \ v = v \ p\]] - lenarg[OF \w = r \ v\[unfolded \w = r' \ v\<^sup>@Suc j \ t'\]] + using lenarg[OF \v \ p = ri'\v\<^sup>@ j \ t'\[folded \r' \ v = v \ p\]] + lenarg[OF \w = r \ v\[unfolded \w = r' \ v\<^sup>@ j \ t'\]] 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 \ri' \s r'\], unfolded e1, symmetric] - \\<^bold>|t\<^bold>| = \<^bold>|r\<^bold>|\ unfolding \\<^bold>|r'\<^bold>| = \<^bold>|p\<^bold>|\ + \\<^bold>|t\<^bold>| = \<^bold>|r\<^bold>|\ unfolding \\<^bold>|r'\<^bold>| = \<^bold>|p\<^bold>|\ using \\<^bold>|r'\<^bold>| < \<^bold>|r\<^bold>|\[unfolded \\<^bold>|r'\<^bold>| = \<^bold>|p\<^bold>|\] by linarith - (* TODO *) hence e2: "\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>| = (\<^bold>|p\<^bold>| - \<^bold>|t'\<^bold>|) + (\<^bold>|r'\<^bold>| - \<^bold>|ri'\<^bold>|)" - using \\<^bold>|t'\<^bold>| \ \<^bold>|p\<^bold>|\ diff_commute \ri' \s r'\ \\<^bold>|r'\<^bold>| = \<^bold>|p\<^bold>|\ \\<^bold>|r'\<^bold>| \ \<^bold>|r\<^bold>|\ \\<^bold>|t\<^bold>| = \<^bold>|r\<^bold>|\ - by linarith - show ?thesis + unfolding add_diff_assoc2[OF \\<^bold>|t'\<^bold>| \ \<^bold>|p\<^bold>|\] \\<^bold>|t\<^bold>| = \<^bold>|p\<^bold>| + \<^bold>|r'\<^bold>| - \<^bold>|ri'\<^bold>|\ + using suf_len[OF \ri' \s r'\] by force + show ?thesis unfolding e2 e1 gcd_add1.. qed - have per_vp: "period (v \ p) ?gcd" + have per_vp: "period (v \ p) ?gcd" proof (cases) - assume "\<^bold>|t'\<^bold>| \ \<^bold>|ri'\<^bold>|" + assume "\<^bold>|t'\<^bold>| \ \<^bold>|ri'\<^bold>|" \ \By induction.\ - from less.hyps[OF \\<^bold>|v \ p\<^bold>| < \<^bold>|w\<^bold>|\ refl \v \ p = ri'\v\<^sup>@Suc j \ t'\ \r' \ v = v \ p\[symmetric] \ri' \t'

this \primitive v\] + from less.hyps[OF \\<^bold>|v \ p\<^bold>| < \<^bold>|w\<^bold>|\ refl \v \ p = ri'\v\<^sup>@ j \ t'\ \r' \ v = v \ p\[symmetric] \0 < j\ + \ri' \t'

this \primitive v\] show "period (v \ p) ?gcd" unfolding gcd_eq by blast next \ \...(using symmetry)\ assume "\ \<^bold>|t'\<^bold>| \ \<^bold>|ri'\<^bold>|" hence "\<^bold>|ri'\<^bold>| \ \<^bold>|t'\<^bold>|" by simp have "period (rev p \ 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 \ rev v\<^bold>| < \<^bold>|w\<^bold>|" - using \\<^bold>|v \ p\<^bold>| < \<^bold>|w\<^bold>|\ by simp + using \\<^bold>|v \ p\<^bold>| < \<^bold>|w\<^bold>|\ by simp show "rev p \ rev v = rev v \ rev r'" - using \r' \ v = v \ p\ unfolding rev_append[symmetric] by simp - show "rev p \ rev v = rev t' \ rev v \<^sup>@ Suc j \ rev ri'" - using \v \ p = ri'\v\<^sup>@Suc j \ t'\ unfolding rev_append[symmetric] rev_pow[symmetric] rassoc by simp + using \r' \ v = v \ p\ unfolding rev_append[symmetric] by simp + show "rev p \ rev v = rev t' \ rev v \<^sup>@ j \ rev ri'" + using \v \ p = ri'\v\<^sup>@ j \ t'\ unfolding rev_append[symmetric] rev_pow[symmetric] rassoc by simp show "rev t' t'

by (auto simp add: prefix_def) + using \t'

by (auto simp add: prefix_def) show "rev ri'

ri' strict_suffix_to_prefix by blast show "\<^bold>|rev ri'\<^bold>| \ \<^bold>|rev t'\<^bold>|" - by (simp add: \\<^bold>|ri'\<^bold>| \ \<^bold>|t'\<^bold>|\) + by (simp add: \\<^bold>|ri'\<^bold>| \ \<^bold>|t'\<^bold>|\) show "primitive (rev v)" by (simp add: \primitive v\ prim_rev_iff) - qed + qed fact thus ?thesis - unfolding length_rev rev_append[symmetric] period_rev_conv gcd.commute[of "\<^bold>|r'\<^bold>| - \<^bold>|ri'\<^bold>|"] gcd_eq. + 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)" + have "period (v\<^sup>@ 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>|)) \ \<^bold>|v \<^sup>@ Suc j\<^bold>|" - using \?gcd + \<^bold>|v\<^bold>| \ \<^bold>|v \<^sup>@ Suc j\<^bold>|\ by linarith - show "period (v \<^sup>@ Suc j) \<^bold>|v\<^bold>|" - using \v \ \\ pow_per by blast - have "v \<^sup>@ Suc j \ \" - using \v \ \\ by auto - from period_fac[OF per_vp[unfolded \v \ p = ri' \ v \<^sup>@ Suc j \ t'\] this] - show "period (v \<^sup>@ Suc j) ?gcd". + show " \<^bold>|v\<^bold>| + ?gcd - gcd \<^bold>|v\<^bold>| (gcd (\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|) (\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|)) \ \<^bold>|v \<^sup>@ j\<^bold>|" + using \?gcd + \<^bold>|v\<^bold>| \ \<^bold>|v \<^sup>@ j\<^bold>|\ by linarith + show "period (v \<^sup>@ j) \<^bold>|v\<^bold>|" + using \v \ \\ \0 < j\ + by blast + find_theorems "?v\<^sup>@?n" "?w = \" + have "v \<^sup>@ j \ \" + using \0 < j\ \v \ \\ by blast + from period_fac[OF per_vp[unfolded \v \ p = ri' \ v \<^sup>@ j \ t'\] this] + show "period (v \<^sup>@ j) ?gcd". qed have per_vp': "period (v \ p) (gcd \<^bold>|v\<^bold>| ?gcd)" proof (rule refine_per) show "gcd \<^bold>|v\<^bold>| ?gcd dvd ?gcd" by blast - show "?gcd \ \<^bold>|v\<^sup>@Suc j\<^bold>|" - using \?gcd + \<^bold>|v\<^bold>| \ \<^bold>|v \<^sup>@ Suc j\<^bold>|\ add_leE by blast - show "v \<^sup>@ Suc j \f v \ p" - using facI'[OF \v \ p = ri' \ v \<^sup>@ Suc j \ t'\[symmetric]]. + show "?gcd \ \<^bold>|v\<^sup>@j\<^bold>|" + using \?gcd + \<^bold>|v\<^bold>| \ \<^bold>|v \<^sup>@ j\<^bold>|\ add_leE by blast + show "v \<^sup>@ j \f v \ p" + using facI'[OF \v \ p = ri' \ v \<^sup>@ j \ t'\[symmetric]]. qed fact+ have "period w (gcd \<^bold>|v\<^bold>| ?gcd)" proof (rule per_glue) show "v \ p \p w" using \p \p t\ \w = v \ t\ by auto - have "\<^bold>|v \<^sup>@ Suc j\<^bold>| + \<^bold>|t'\<^bold>| \ \<^bold>|v\<^bold>| + \<^bold>|p\<^bold>|" - using \\ \<^bold>|v \ p\<^bold>| \ \<^bold>|v \<^sup>@ Suc j \ t'\<^bold>|\ by auto + have "\<^bold>|v \<^sup>@ j\<^bold>| + \<^bold>|t'\<^bold>| \ \<^bold>|v\<^bold>| + \<^bold>|p\<^bold>|" + using \\ \<^bold>|v \ p\<^bold>| \ \<^bold>|v \<^sup>@ j \ t'\<^bold>|\ by auto moreover have "\<^bold>|r'\<^bold>| + gcd \<^bold>|v\<^bold>| ?gcd \ \<^bold>|v\<^bold>| + \<^bold>|p\<^bold>|" using lenarg[OF \r' \ v = v \ p\, unfolded lenmorph] - \v \ \\ gcd_le1_nat length_0_conv nat_add_left_cancel_le by metis + \v \ \\ gcd_le1_nat length_0_conv nat_add_left_cancel_le by metis ultimately show "\<^bold>|w\<^bold>| + gcd \<^bold>|v\<^bold>| ?gcd \ \<^bold>|v \ p\<^bold>| + \<^bold>|v \ p\<^bold>|" - unfolding lenarg[OF \w = r' \ v \<^sup>@ Suc j \ t'\] lenmorph add.commute[of "\<^bold>|r'\<^bold>|"] by linarith + unfolding lenarg[OF \w = r' \ v \<^sup>@ j \ t'\] 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 \ 0" using \?gcd \ 0\ by algebra - from per_mult[OF \period w (gcd \<^bold>|v\<^bold>| ?gcd)\ this, folded k] + from per_mult[OF \period w (gcd \<^bold>|v\<^bold>| ?gcd)\ this[unfolded neq0_conv], folded k] show ?thesis. qed qed qed qed qed -lemma three_covers_per: assumes "w = v \ t" and "w = r' \ v\<^sup>@Suc j \ t'" and "w = r \ v" and - "r' t" and "w = r' \ v\<^sup>@j \ t'" and "w = r \ v" + "r' |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 ?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 \w = v \ t\ \w = r' \ v \<^sup>@ Suc j \ t'\ \w = r \ v\ \r' \t'

] by blast+ + 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>| + j*\<^bold>|v\<^bold>| - 2*\<^bold>|v\<^bold>|" + using three_covers_pers[OF \w = v \ t\ \w = r' \ v \<^sup>@ j \ t'\ \w = r \ v\ \0 < j\ \r' \t'

] by blast+ + show ?thesis proof(cases) assume "v = \" have "\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>| + (\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|) = \<^bold>|w\<^bold>|" - using \w = v \ t\ \w = r' \ v\<^sup>@Suc j \ t'\ \w = r \ v\ unfolding \v = \\ emp_pow clean_emp by force + using \w = v \ t\ \w = r' \ v\<^sup>@j \ t'\ \w = r \ v\ unfolding \v = \\ emp_pow emp_simps by force from per_lemma[OF \period w ?per_t\ \period w ?per_r\, unfolded this] show "period w ?gcd" - by fastforce + by fastforce next assume "v \ \" show ?thesis proof (cases) assume "j \ 1" hence "(j = 0 \ P) \ (j = 1 \ P) \ P" for P by force - hence "\<^bold>|w\<^bold>| + Suc j*\<^bold>|v\<^bold>| - 2*\<^bold>|v\<^bold>| - ?gcd \ \<^bold>|w\<^bold>|" \ \Condition allowing to use the Periodicity lemma\ - by (cases, simp_all) + hence "\<^bold>|w\<^bold>| + j*\<^bold>|v\<^bold>| - 2*\<^bold>|v\<^bold>| - ?gcd \ \<^bold>|w\<^bold>|" \ \Condition allowing to use the Periodicity lemma\ + by (cases, simp_all) thus "period w ?gcd" using per_lemma[OF \period w ?per_t\ \period w ?per_r\] unfolding len by blast - next + next assume "\ j \ 1" hence "2 \ j" by simp - obtain e where "v = \ v\<^sup>@Suc e" - using \v \ \\ 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 \2 \ j\ by auto - finally have calc: "e + (Suc e * (Suc j - 2) + 2 + e) = Suc e * Suc j". - have "w = \ v \ (\ v\<^sup>@e \ t)" - using \v = \ v \<^sup>@ Suc e\ \w = v \ t\ by fastforce - have "w = (r \ \ v\<^sup>@e) \ \ v" - unfolding rassoc pow_Suc2[symmetric] \v = \ v \<^sup>@ Suc e\[symmetric] by fact - obtain e' where e': "Suc e' = Suc e * (Suc j - 2) + 2" - by auto - have "w = (r' \ \ v\<^sup>@e) \ \ v \<^sup>@Suc e' \ (\ v\<^sup>@e \ t')" - unfolding e'\w = r' \ v\<^sup>@Suc j \ t'\ rassoc cancel unfolding lassoc cancel_right add_exps[symmetric] calc - pow_mult \v = \ v\<^sup>@Suc e\[symmetric].. - - show ?thesis + obtain e where "v = \ v\<^sup>@e" "0 < e" + using primroot_expE by metis + have "w = \ v \ \ v\<^sup>@(e -1) \ t" + unfolding lassoc pow_pos[OF \0 < e\, symmetric] \v = \ v\<^sup>@e\[symmetric] by fact + have "w = (r \ \ v\<^sup>@(e - 1)) \ \ v" + unfolding rassoc pow_pos'[OF \0 < e\, symmetric] \v = \ v\<^sup>@e\[symmetric] by fact + note aux = add_less_mono[OF diff_less[OF zero_less_one \0 < e\] diff_less[OF zero_less_one \0 < e\]] + have "(e-1) + (e-1) < j*e" + using less_le_trans[OF aux mult_le_mono1[OF \2 \ j\, unfolded mult_2]]. + then obtain e' where "(e-1) + (e-1) + e' = j*e" "0 < e'" + using less_imp_add_positive by blast + hence aux_sum: "(e - 1) + e' + (e - 1) = j*e" + by presburger + have cover3: "w = (r' \ (\ v)\<^sup>@(e-1)) \ (\ v) \<^sup>@e' \ ((\ v)\<^sup>@(e-1) \ t')" + unfolding \w = r' \ v\<^sup>@ j \ t'\ rassoc cancel unfolding lassoc cancel_right + unfolding add_exps[symmetric] + pow_mult unfolding aux_sum unfolding mult.commute[of j] + pow_mult \v = \ v\<^sup>@e\[symmetric].. + show ?thesis proof(cases) assume "\<^bold>|t'\<^bold>| \ \<^bold>|r'\<^bold>|" - have dif1: "\<^bold>|\ v \<^sup>@ e \ t\<^bold>| - \<^bold>|\ v \<^sup>@ e \ t'\<^bold>| = \<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|" + have dif1: "\<^bold>|\ v \<^sup>@ (e -1) \ t\<^bold>| - \<^bold>|\ v \<^sup>@ (e - 1) \ t'\<^bold>| = \<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|" unfolding lenmorph by simp - have dif2: "\<^bold>|r \ \ v \<^sup>@ e\<^bold>| - \<^bold>|r' \ \ v \<^sup>@ e\<^bold>| = \<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|" + have dif2: "\<^bold>|r \ \ v \<^sup>@ (e-1)\<^bold>| - \<^bold>|r' \ \ v \<^sup>@ (e-1)\<^bold>| = \<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|" unfolding lenmorph by simp + show ?thesis - proof (rule three_covers_per0[OF \w = \ v \ (\ v\<^sup>@e \ t)\ - \w = (r' \ \ v\<^sup>@e) \ \ v \<^sup>@Suc e' \ (\ v\<^sup>@e \ t')\ \w = (r \ \ v\<^sup>@e) \ \ v\, unfolded dif1 dif2]) - show "r' \ \ v \<^sup>@ e \ v \<^sup>@ e" - using \r' by auto - show "\ v \<^sup>@ e \ t'

v \<^sup>@ e \ t" - using \t'

by auto - show "\<^bold>|\ v \<^sup>@ e \ t'\<^bold>| \ \<^bold>|r' \ \ v \<^sup>@ e\<^bold>|" - unfolding lenmorph using \\<^bold>|t'\<^bold>| \ \<^bold>|r'\<^bold>|\ by auto - show "primitive (\ v)" - using primroot_prim[OF \v \ \\]. + proof (rule three_covers_per0[OF \w = \ v \ (\ v\<^sup>@(e -1) \ t)\ + cover3 \w = (r \ \ v\<^sup>@(e - 1)) \ \ v\ \0 < e'\ _ _ _ primroot_prim[OF \v \ \\], + unfolded dif1 dif2]) + show "r' \ \ v \<^sup>@ (e -1) \ v \<^sup>@ (e -1)" + using \r' by auto + show "\ v \<^sup>@ (e - 1) \ t'

v \<^sup>@ (e - 1) \ t" + using \t'

by auto + show "\<^bold>|\ v \<^sup>@ (e -1) \ t'\<^bold>| \ \<^bold>|r' \ \ v \<^sup>@ (e - 1)\<^bold>|" + unfolding lenmorph using \\<^bold>|t'\<^bold>| \ \<^bold>|r'\<^bold>|\ by auto qed next let ?w = "rev w" and ?r = "rev t" and ?t = "rev r" and ?\ = "rev (\ v)" and ?r' = "rev t'" and ?t' = "rev r'" - assume "\ \<^bold>|t'\<^bold>| \ \<^bold>|r'\<^bold>|" + assume "\ \<^bold>|t'\<^bold>| \ \<^bold>|r'\<^bold>|" hence "\<^bold>|?t'\<^bold>| \ \<^bold>|?r'\<^bold>|" by auto - have "?w = (?r \ ?\\<^sup>@e) \ ?\" - unfolding rev_pow[symmetric] rev_append[symmetric] \w = \ v \ (\ v\<^sup>@e \ t)\ rassoc.. - have "?w = ?\ \ (?\\<^sup>@e \ ?t)" - unfolding rev_pow[symmetric] rev_append[symmetric] \w = (r \ \ v\<^sup>@e) \ \ v\.. - have "?w = (?r' \ ?\\<^sup>@e) \ ?\\<^sup>@Suc e' \ (?\\<^sup>@e \ ?t')" - unfolding rev_pow[symmetric] rev_append[symmetric] \w = (r' \ \ v\<^sup>@e) \ \ v \<^sup>@Suc e' \ (\ v\<^sup>@e \ t')\ rassoc.. - have dif1: "\<^bold>|?\ \<^sup>@ e \ ?t\<^bold>| - \<^bold>|?\ \<^sup>@ e \ ?t'\<^bold>| = \<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|" + have "?w = (?r \ ?\\<^sup>@(e-1)) \ ?\" + unfolding rev_pow[symmetric] rev_append[symmetric] \w = \ v \ (\ v\<^sup>@(e-1) \ t)\ rassoc.. + have "?w = ?\ \ (?\\<^sup>@(e-1) \ ?t)" + unfolding rev_pow[symmetric] rev_append[symmetric] \w = (r \ \ v\<^sup>@(e-1)) \ \ v\.. + have "?w = (?r' \ ?\\<^sup>@(e-1)) \ ?\\<^sup>@e' \ (?\\<^sup>@(e-1) \ ?t')" + unfolding rev_pow[symmetric] rev_append[symmetric] \w = (r' \ \ v\<^sup>@(e-1)) \ \ v \<^sup>@e' \ (\ v\<^sup>@(e-1) \ t')\ rassoc.. + have dif1: "\<^bold>|?\ \<^sup>@ (e-1) \ ?t\<^bold>| - \<^bold>|?\ \<^sup>@ (e-1) \ ?t'\<^bold>| = \<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|" unfolding lenmorph by simp - have dif2: "\<^bold>|?r \ ?\ \<^sup>@ e\<^bold>| - \<^bold>|?r' \ ?\ \<^sup>@ e\<^bold>| = \<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|" + have dif2: "\<^bold>|?r \ ?\ \<^sup>@ (e-1)\<^bold>| - \<^bold>|?r' \ ?\ \<^sup>@ (e-1)\<^bold>| = \<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>|" unfolding lenmorph by simp show ?thesis - proof (rule three_covers_per0[OF \?w = ?\ \ (?\\<^sup>@e \ ?t)\ - \?w = (?r' \ ?\\<^sup>@e) \ ?\\<^sup>@Suc e' \ (?\\<^sup>@e \ ?t')\ \?w = (?r \ ?\\<^sup>@e) \ ?\\, + proof(rule three_covers_per0[OF \?w = ?\ \ (?\\<^sup>@(e-1) \ ?t)\ + \?w = (?r' \ ?\\<^sup>@(e-1)) \ ?\\<^sup>@e' \ (?\\<^sup>@(e-1) \ ?t')\ \?w = (?r \ ?\\<^sup>@(e-1)) \ ?\\ \0 < e'\, unfolded dif1 dif2 period_rev_conv gcd.commute[of "\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>|"]]) - show "?r' \ ?\ \<^sup>@ e ?\ \<^sup>@ e" - using \t'

by (auto simp add: prefix_def) - show "?\ \<^sup>@ e \ ?t'

\<^sup>@ e \ ?t" - using \r' by (auto simp add: suf_def) - show "\<^bold>|?\ \<^sup>@ e \ ?t'\<^bold>| \ \<^bold>|?r' \ ?\ \<^sup>@ e\<^bold>|" - unfolding lenmorph using \\<^bold>|?t'\<^bold>| \ \<^bold>|?r'\<^bold>|\ by auto + show "?r' \ ?\ \<^sup>@ (e-1) ?\ \<^sup>@ (e-1)" + using \t'

by (auto simp add: prefix_def) + show "?\ \<^sup>@ (e-1) \ ?t'

\<^sup>@ (e-1) \ ?t" + using \r' by (auto simp add: suffix_def) + show "\<^bold>|?\ \<^sup>@ (e-1) \ ?t'\<^bold>| \ \<^bold>|?r' \ ?\ \<^sup>@ (e-1)\<^bold>|" + unfolding lenmorph using \\<^bold>|?t'\<^bold>| \ \<^bold>|?r'\<^bold>|\ by auto show "primitive ?\" - using primroot_prim[OF \v \ \\] by (simp add: prim_rev_iff) + using primroot_prim[OF \v \ \\] by (simp add: prim_rev_iff) qed qed qed qed qed -hide_fact three_covers_per0 +thm per_root_modE' + +lemma assumes "w

w" + obtains p q i where "w = (p \ q)\<^sup>@i \ p" "p \ q = r" + using assms by blast + + + + + + + + + +lemma three_coversE: assumes "w = v \ t" and "w = r' \ v \ t'" and "w = r \ v" and + "r' p)\<^sup>@(m+k)" and "r = (p \ q)\<^sup>@(m+k)" and + "t' = (q \ p)\<^sup>@k" and "r' = (p \ q)\<^sup>@m" and "v = (p \ q)\<^sup>@i \ p" and + "w = (p \ q)\<^sup>@(m + i + k) \ p" and "primitive (p \ q)" and "q \ \" + and "0 < m" and "0 < k" +proof- + let ?d = "gcd \<^bold>|r'\<^bold>| \<^bold>|t'\<^bold>|" + have "r' \ \" "t' \ \" + using assms by force+ + have "0 < ?d" + using nemp_len[OF \r' \ \\] by simp + have "\<^bold>|t\<^bold>| - \<^bold>|t'\<^bold>| = \<^bold>|r'\<^bold>|" "\<^bold>|r\<^bold>| - \<^bold>|r'\<^bold>| = \<^bold>|t'\<^bold>|" + using lenarg[OF \w = v \ t\] lenarg[OF \w = r \ v\] + unfolding lenarg[OF \w = r' \ v \ t'\] lenmorph by simp_all + note three_covers_per[of _ _ _ _1, unfolded cow_simps, OF assms order.refl, unfolded this period_def] + from per_root_mod_primE[OF \w

|r'\<^bold>| \<^bold>|t'\<^bold>|) w \ w\] + obtain l p q where "p \ q = \ (take ?d w)" "(p \ q)\<^sup>@l \ p = w" "q \ \". + hence "primitive (p \ q)" by auto + define e where "e = e\<^sub>\ (take ?d w)" + have "e \ 0" + unfolding e_def + using \w

|r'\<^bold>| \<^bold>|t'\<^bold>|) w \ w\ primroot_exp_nemp by blast + have "(p \ q)\<^sup>@e = take ?d w" + unfolding e_def \p \ q = \ (take ?d w)\ by force + have "\<^bold>|(p \ q)\<^sup>@e\<^bold>| \ \<^bold>|w\<^bold>|" + unfolding \(p \ q)\<^sup>@e = take ?d w\ + using len_take2 by blast + have swap_e: "\<^bold>|(p \ q)\<^sup>@e\<^bold>| = \<^bold>|(q \ p)\<^sup>@e\<^bold>|" + unfolding pow_len swap_len.. + have "\<^bold>|(p \ q)\<^sup>@e\<^bold>| = ?d" + unfolding \(p \ q)\<^sup>@e = take ?d w\ + by (rule take_len, unfold lenarg[OF \w = r' \ v \ t'\, unfolded lenmorph], + use gcd_le1_nat[OF nemp_len[OF \r' \ \\]] trans_le_add1 in blast) + + hence "(p \ q)\<^sup>@e \p r'" + using \\<^bold>|(p \ q)\<^sup>@e\<^bold>| = ?d\ + unfolding pref_take_conv[of "(p \ q)\<^sup>@e" r', symmetric] using \w = r' \ v \ t'\ + \(p \ q)\<^sup>@e = take ?d w\[symmetric] gcd_le1_nat nemp_len[OF \r' \ \\] short_take_append by metis + hence "(p \ q)\<^sup>@e = take ?d r'" + using pref_take_conv \\<^bold>|(p \ q)\<^sup>@e\<^bold>| = ?d\ by metis + have "r' \p (p \ q)\<^sup>@e \ r'" + using pref_keeps_per_root[OF sprefD1[OF \w

w\]] + unfolding \(p \ q)\<^sup>@e = take (gcd \<^bold>|r'\<^bold>| \<^bold>|t'\<^bold>|) w\ + using \w = r' \ v \ t'\ by blast + then obtain m where "r' = (p \ q)\<^sup>@m" + using per_div[OF gcd_dvd1 period_I', OF \r' \ \\ \0 < ?d\, folded \(p \ q)\<^sup>@e = take ?d r'\] + unfolding pow_mult[symmetric] by metis + + have "p \s (q \ p) \<^sup>@ e" + unfolding pow_Suc'[of "q \ p" "e-1", unfolded Suc_minus[OF \e \ 0\] lassoc] by blast + note \\<^bold>|(p \ q)\<^sup>@e\<^bold>| \ \<^bold>|w\<^bold>|\[unfolded swap_e, folded \(p \ q)\<^sup>@l \ p = w\, unfolded shift_pow] + have "(q \ p)\<^sup>@e \s (r' \ v) \ t'" + unfolding rassoc \w = r' \ v \ t'\[symmetric, folded \(p \ q)\<^sup>@l \ p = w\, unfolded shift_pow] + using suf_prod_suf_short[OF _ \p \s (q \ p) \<^sup>@ e\ \ \<^bold>|(q \ p) \<^sup>@ e\<^bold>| \ \<^bold>|p \ (q \ p) \<^sup>@ l\<^bold>|\] + unfolding pows_comm[of "(q \ p)" e l] by blast + have "\<^bold>|(q \ p) \<^sup>@ e\<^bold>| \ \<^bold>|t'\<^bold>|" + using gcd_le2_nat[OF nemp_len[OF \t' \ \\], of "\<^bold>|r'\<^bold>|", folded \\<^bold>|(p \ q)\<^sup>@e\<^bold>| = ?d\] + unfolding swap_len[of p q] pow_len. + have "(q \ p)\<^sup>@e \s t'" + unfolding \w = r' \ v \ t'\[unfolded lassoc] + using suf_prod_le[OF \(q \ p)\<^sup>@e \s (r' \ v) \ t'\ \\<^bold>|(q \ p) \<^sup>@ e\<^bold>| \ \<^bold>|t'\<^bold>|\]. + have "t' \s t' \ (q \ p)\<^sup>@e" + proof (rule pref_keeps_per_root[reversed, of w]) + show "w \s w \ (q \ p)\<^sup>@e" + unfolding \(p \ q)\<^sup>@l \ p = w\[symmetric, unfolded shift_pow] rassoc pows_comm + unfolding lassoc shift_pow[symmetric] + unfolding rassoc unfolding shift_pow by blast + show "t' \s w" + unfolding \w = r' \ v \ t'\ lassoc by blast + qed + have t_drop: "(q \ p)\<^sup>@e = drop (\<^bold>|t'\<^bold>| - ?d) t'" + using \\<^bold>|(p \ q)\<^sup>@e\<^bold>| = ?d\[unfolded swap_e, symmetric] \(q \ p)\<^sup>@e \s t'\[unfolded suf_drop_conv, symmetric] + by argo + obtain k where "t' = (q \ p)\<^sup>@k" + using per_div[reversed, OF gcd_dvd2 period_I'[reversed], OF \t'\ \\ \0 < ?d\, + folded t_drop, OF \t' \s t' \ (q \ p)\<^sup>@e\ ] pow_mult by metis + + have "m + k \ l" + unfolding linorder_not_less[symmetric] + proof (rule notI) + assume "l < m + k" + hence "l + 1 \ m + k" + by force + from trans_le_add1[OF mult_le_mono1[OF this]] + have "(l + 1)* \<^bold>|p \ q\<^bold>| \ (m + k) * \<^bold>|p\q\<^bold>| + \<^bold>|v\<^bold>|". + with lenarg[OF \w = r' \ v \ t'\[folded \(p \ q)\<^sup>@l \ p = w\, unfolded \t' = (q \ p)\<^sup>@k\ \r' = (p \ q)\<^sup>@m\], + unfolded lenmorph, unfolded pow_len add.assoc[symmetric], symmetric] + show False + unfolding distrib_right add.commute[of _ "\<^bold>|v\<^bold>|"] lenmorph + unfolding distrib_left using nemp_len[OF \q \ \\] by linarith + qed + then obtain i where "l = m + i + k" + by (metis add.assoc add.commute le_Suc_ex) + + have "v = (p \ q)\<^sup>@i \ p" + using \w = r' \ v \ t'\ + unfolding \(p \ q)\<^sup>@l \ p = w\[symmetric] \t' = (q \ p)\<^sup>@k\ \r' = (p \ q)\<^sup>@m\ \l = m + i + k\ add_exps + rassoc cancel cancel_right + unfolding lassoc shift_pow cancel_right by simp + + have "r = (p \ q)\<^sup>@(m + k)" + using \w = r \ v\ unfolding \(p \ q)\<^sup>@l \ p = w\[symmetric] \v = (p \ q)\<^sup>@i \ p\ \l = m + i + k\ + unfolding lassoc cancel_right add.commute[of _ k] add.assoc[symmetric] add_exps by simp + + have "t = (q \ p)\<^sup>@(m + k)" + using \w = v \ t\ unfolding \(p \ q)\<^sup>@l \ p = w\[symmetric] \v = (p \ q)\<^sup>@i \ p\ \l = m + i + k\ + unfolding rassoc cancel add.commute[of m] add.assoc[symmetric] add_exps + unfolding shift_pow unfolding lassoc shift_pow unfolding rassoc cancel + unfolding pows_comm by simp + + have "0 < m" + using \r' = (p \ q)\<^sup>@m\ \r' \ \\ by blast + + have "0 < k" + using \t' = (q \ p)\<^sup>@k\ \t' \ \\ by blast + thm that + from that[OF \t = (q \ p)\<^sup>@(m + k)\ \r = (p \ q)\<^sup>@(m + k)\ \t' = (q \ p)\<^sup>@k\ \r' = (p \ q)\<^sup>@m\ \v = (p \ q)\<^sup>@i \ p\ + \(p \ q)\<^sup>@l \ p = w\[symmetric, unfolded \l = m + i + k\] \primitive (p \ q)\ \q \ \\ \0 < m\ \0 < k\] + show thesis. +qed + + lemma three_covers_pref_suf_pow: assumes "x \ y \p w" and "y \ x \s w" and "w \f y\<^sup>@k" and "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" - shows "x \ y = y \ x" + shows "x \ y = y \ x" using fac_marker_suf[OF fac_trans[OF pref_fac[OF \x \ y \p w\] \w \f y\<^sup>@k\]] fac_marker_pref[OF fac_trans[OF suf_fac[OF \y \ x \s w\] \w \f y\<^sup>@k\]] - root_suf_comm'[OF _ suf_prod_long, OF _ _ \\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|\, of x] by presburger + root_suf_comm'[OF _ suf_prod_long, OF _ _ \\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|\, of x] by presburger subsection \Binary Equality Words\ -(*rudimentary material for classification of binary equality words *) \ \translation of a combinatorial lemma into the language of "something is not BEW"\ definition binary_equality_word :: "binA list \ bool" where "binary_equality_word w = (\ (g :: binA list \ nat list) h. binary_code_morphism g \ binary_code_morphism h \ g \ h \ w \ g =\<^sub>M h)" -lemma not_bew_baiba: assumes "\<^bold>|y\<^bold>| < \<^bold>|v\<^bold>|" and "x \s y" and "u \s v" and +lemma not_bew_baiba: assumes "\<^bold>|y\<^bold>| < \<^bold>|v\<^bold>|" and "x \s y" and "u \s v" and "y \ x \<^sup>@ k \ y = v \ u \<^sup>@ k \ v" -shows "commutes {x,y,u,v}" +shows "commutes {x,y,u,v}" proof- obtain p where "y\p = v" using eqdE[OF \y \ x \<^sup>@ k \ y = v \ u \<^sup>@ k \ v\ less_imp_le[OF \\<^bold>|y\<^bold>| < \<^bold>|v\<^bold>|\]] by blast have "\<^bold>|u \<^sup>@ k \ v\<^bold>| \ \<^bold>|x \<^sup>@ k \ y\<^bold>|" using lenarg[OF \y \ x \<^sup>@ k \ y = v \ u \<^sup>@ k \ v\] \\<^bold>|y\<^bold>| < \<^bold>|v\<^bold>|\ unfolding lenmorph - by linarith + by linarith obtain s where "s\y = v" - using eqdE[reversed, OF \y \ x \<^sup>@ k \ y = v \ u \<^sup>@ k \ v\[unfolded lassoc] less_imp_le[OF \\<^bold>|y\<^bold>| < \<^bold>|v\<^bold>|\]]. + using eqdE[reversed, OF \y \ x \<^sup>@ k \ y = v \ u \<^sup>@ k \ v\[unfolded lassoc] less_imp_le[OF \\<^bold>|y\<^bold>| < \<^bold>|v\<^bold>|\]]. have "s \ \" using \\<^bold>|y\<^bold>| < \<^bold>|v\<^bold>|\ \s \ y = v\ by force have "p \ \" using \\<^bold>|y\<^bold>| < \<^bold>|v\<^bold>|\ \y \ p = v\ by force have "s \ y = y \ p" by (simp add: \s \ y = v\ \y \ p = v\) - obtain w w' q t where p_def: "p = (w'\w)\<^sup>@Suc q" and s_def: "s = (w\w')\<^sup>@Suc q" and y_def: "y = (w\w')\<^sup>@t\w" and "w' \ \" and "primitive (w\w')" + obtain w w' q t where p_def: "p = (w'\w)\<^sup>@q" and s_def: "s = (w\w')\<^sup>@q" + and y_def: "y = (w\w')\<^sup>@t\w" and "w' \ \" and "primitive (w\w')" and \0 < q\ using conjug_eq_primrootE[OF \s \ y = y \ p\ \s \ \\, of thesis] by blast have "primitive (w'\w)" using \primitive (w \ w')\ prim_conjug by auto have "y \ x \<^sup>@ k \ y = y\ p \ u \<^sup>@ k \ s \ y" using \s \ y = v\ \y \ p = v\ \y \ x \<^sup>@ k \ y = v \ u \<^sup>@ k \ v\ by auto hence "x\<^sup>@k = p\u\<^sup>@k\s" by auto hence "x \ \" using \p \ \\ by force have "w\w' \s x\<^sup>@k" using \x \<^sup>@ k = p \ u \<^sup>@ k \ s\[unfolded s_def] - unfolding CoWBasic.power_Suc2 - using sufI[of "p \ u \<^sup>@ k \ (w \ w') \<^sup>@ q" "w \ w'" "x\<^sup>@k", unfolded rassoc] + unfolding pow_pos'[OF \0 < q\] + using sufI[of "p \ u \<^sup>@ k \ (w \ w') \<^sup>@ (q - 1)" "w \ w'" "x\<^sup>@k", unfolded rassoc] by argo have "\<^bold>|w\w'\<^bold>| \ \<^bold>|x\<^bold>|" proof(intro leI notI) - assume "\<^bold>|x\<^bold>| < \<^bold>|w \ w'\<^bold>|" + assume "\<^bold>|x\<^bold>| < \<^bold>|w \ w'\<^bold>|" have "x \s (w\w')\y" - using \x \s y\ by (auto simp add: suf_def) + using \x \s y\ by (auto simp add: suffix_def) have "(w'\w) \s (w\w')\y" unfolding \y = (w\w')\<^sup>@t\w\ lassoc pow_comm[symmetric] suf_cancel_conv by blast - - from ruler_le[reversed, OF \x \s (w\w')\y\ this + + from ruler_le[reversed, OF \x \s (w\w')\y\ this less_imp_le[OF \\<^bold>|x\<^bold>| < \<^bold>|w \ w'\<^bold>|\[unfolded swap_len]]] have "x \s w'\ w". hence "x \s p" - unfolding p_def pow_Suc2 suffix_append by blast + unfolding p_def pow_pos'[OF \0 < q\] suffix_append by blast from root_suf_comm[OF _ suf_ext[OF this]] have "x\p = p\x" using pref_prod_root[OF prefI[OF \x \<^sup>@ k = p \ u \<^sup>@ k \ s\[symmetric]]] by blast - from comm_drop_exp[OF _ this[unfolded \p = (w' \ w) \<^sup>@ Suc q\]] + from comm_drop_exp[OF _ this[unfolded \p = (w' \ w) \<^sup>@ q\]] have "x \ (w' \ w) = (w' \ w) \ x" - by force + using \0 < q\ by force from prim_comm_short_emp[OF \primitive (w'\w)\ this \\<^bold>|x\<^bold>| < \<^bold>|w\w'\<^bold>|\[unfolded swap_len]] - show False + show False using \x \ \\ by blast qed hence "w\w' \s x" using suf_prod_le[OF suf_prod_root[OF \w \ w' \s x \<^sup>@ k\]] by blast from suffix_order.trans[OF this \x \s y\] have "w \ w' \s y". hence "\<^bold>|w \ w'\<^bold>| \ \<^bold>|y\<^bold>|" - using suffix_length_le by blast + using suffix_length_le by blast then obtain t' where "t = Suc t'" unfolding y_def lenmorph pow_len \w' \ \\ add.commute[of _ "\<^bold>|w\<^bold>|"] nat_add_left_cancel_le using \w' \ \\ 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 \w \ w' \s y\ _ swap_len, unfolded y_def this pow_Suc2 rassoc] + from ruler_eq_len[reversed, OF \w \ w' \s y\ _ swap_len, unfolded y_def this pow_Suc' rassoc] have "w \ w' = w'\ w" - unfolding lassoc suf_cancel_conv by blast + unfolding lassoc suf_cancel_conv by blast from comm_not_prim[OF _ \w' \ \\ this] - have "w = \" + have "w = \" using \primitive (w \ w')\ by blast hence "primitive w'" using \primitive (w' \ w)\ by auto - have "k \ 0" + have "0 < k" using \\<^bold>|y\<^bold>| < \<^bold>|v\<^bold>|\ lenarg[OF \y \ x \<^sup>@ k \ y = v \ u \<^sup>@ k \ v\, unfolded lenmorph pow_len] - not_add_less1 by fastforce + gr_zeroI by fastforce have "y = w'\<^sup>@t" - using y_def \w = \\ by force + using y_def \w = \\ by force hence "y \ w'*" using rootI by blast have "s \ w'*" using s_def \w = \\ rootI by force hence "v \ w'*" using \s \ y = v\ \y \ w'*\ add_roots by blast - have "w' \p x" - using \x\<^sup>@k = p\u\<^sup>@k\s\ eq_le_pref[OF _ \\<^bold>|w\w'\<^bold>| \ \<^bold>|x\<^bold>|\, of "w' \<^sup>@ q \ u \ u \<^sup>@ (k - 1) \ s" "x \<^sup>@ (k - 1)"] - unfolding p_def \w = \\ clean_emp pop_pow_one[OF \k \ 0\] pow_Suc rassoc - by argo + using \x\<^sup>@k = p\u\<^sup>@k\s\[symmetric] eq_le_pref[OF _ \\<^bold>|w\w'\<^bold>| \ \<^bold>|x\<^bold>|\, of "w' \<^sup>@ (q -1) \ u \ u \<^sup>@ (k - 1) \ s" "x \<^sup>@ (k - 1)"] + unfolding p_def \w = \\ emp_simps pow_pos[OF \0 < k\] pow_pos[OF \0 < q\] pow_pos rassoc by argo have "x \ w' = w' \ x" - using \x \s y\ \w' \p x\ y_def[unfolded \w = \\ \t = Suc t'\ clean_emp] - pref_suf_pows_comm[of w' x 0 0 0 t', unfolded pow_zero clean_emp, folded y_def[unfolded \w = \\ \t = Suc t'\, unfolded clean_emp]] + using \x \s y\ \w' \p x\ y_def[unfolded \w = \\ \t = Suc t'\ emp_simps] + pref_suf_pows_comm[of w' x 0 0 0 t', unfolded pow_zero emp_simps, folded y_def[unfolded \w = \\ \t = Suc t'\, unfolded emp_simps]] by force hence "x \ w'*" using prim_comm_exp[OF \primitive w'\, of x] unfolding root_def by metis have "p \ w'*" using \s \ w'*\ \y \ w'*\ \s \ y = v\[folded \y \ p = v\] by (simp add: \s \ y = y \ p\ \s \ w'*\ \y \ w'*\ \w \ w' = w' \ w\ p_def s_def) - obtain k' where "k = Suc k'" using \k \ 0\ not0_implies_Suc by auto have "u\<^sup>@k \ w'*" - using root_suf_cancel[OF \s \ w'*\, of "p \ u \<^sup>@ k", THEN root_pref_cancel[OF _ \p \ w'*\], unfolded rassoc, folded \x\<^sup>@k = p\u\<^sup>@k\s\, OF root_pow_root[OF \x \ w'*\]]. - from prim_root_drop_exp[OF \k \ 0\ \primitive w'\ this] - have "u \ w'*". + using root_pow_root[OF \x \ w'*\, of k, unfolded \x\<^sup>@k = p\u\<^sup>@k\s\] + root_pref_cancel[OF _ \p \ w'*\] root_suf_cancel[OF _ \s \ w'*\] by blast + from prim_root_drop_exp[OF this \0 < k\ \primitive w'\] + have "u \ w'*". show "commutes {x,y,u,v}" by (intro commutesI_root[of _ w'], unfold Set.ball_simps(7), simp add: \x \ w'*\ \y \ w'*\ \u \ w'*\ \v \ w'*\) qed -lemma not_bew_baibaib: assumes "\<^bold>|x\<^bold>| < \<^bold>|u\<^bold>|" and "1 < i" and +lemma not_bew_baibaib: assumes "\<^bold>|x\<^bold>| < \<^bold>|u\<^bold>|" and "1 < i" and "x \ y\<^sup>@i\ x \ y\<^sup>@i \ x = u \ v\<^sup>@i\ u \ v\<^sup>@i \ u" shows "commutes {x,y,u,v}" proof- - have "i \ 0" + have "0 < i" using assms(2) by auto from lenarg[OF \x \ y\<^sup>@i\ x \ y\<^sup>@i \ x = u \ v\<^sup>@i\ u \ v\<^sup>@i \ u\] have "2*\<^bold>|x \ y\<^sup>@i\<^bold>| + \<^bold>|x\<^bold>| = 2*\<^bold>|u \ v\<^sup>@i\<^bold>| + \<^bold>|u\<^bold>|" by auto hence "\<^bold>|u \ v\<^sup>@i\<^bold>| < \<^bold>|x \ y\<^sup>@i\<^bold>|" using \\<^bold>|x\<^bold>| < \<^bold>|u\<^bold>|\ by fastforce hence "u \ v\<^sup>@i

y\<^sup>@i" - using assms(3) eq_le_pref less_or_eq_imp_le mult_assoc sprefI2 by metis + using assms(3) eq_le_pref less_or_eq_imp_le rassoc sprefI2 by metis have "x\y\<^sup>@i \ \" by (metis \u \ v \<^sup>@ i

y \<^sup>@ i\ strict_prefix_simps(1)) have "u\v\<^sup>@i \ \" using assms(1) gr_implies_not0 by blast have "(u\v\<^sup>@i) \ (x\y\<^sup>@i) = (x\y\<^sup>@i) \ (u\v\<^sup>@i)" proof(rule sq_short_per) have eq: "(x \ y \<^sup>@ i) \ (x \ y \<^sup>@ i) \ x = (u \ v \<^sup>@ i) \ (u \ v \<^sup>@ i) \ u" using assms(3) by auto - from lenarg[OF this] + from lenarg[OF this] have "\<^bold>|u \ v\<^sup>@i \ u\<^bold>| < \<^bold>|x \ y\<^sup>@i \ x \ y\<^sup>@i\<^bold>|" unfolding lenmorph using \\<^bold>|x\<^bold>| < \<^bold>|u\<^bold>|\ by linarith from eq_le_pref[OF _ less_imp_le[OF this]] have "(u \ v\<^sup>@i)\u \p (x \ y\<^sup>@i) \ (x \ y\<^sup>@i)" - using eq[symmetric] unfolding rassoc by blast + using eq[symmetric] unfolding rassoc by blast hence "(u \ v \<^sup>@ i) \ (u \ v\<^sup>@i) \ u \p (u \ v \<^sup>@ i) \ ((x \ y\<^sup>@i) \ (x \ y\<^sup>@i))" - unfolding same_prefix_prefix. + unfolding same_prefix_prefix. from pref_trans[OF prefI[of "(x \ y \<^sup>@ i) \ (x \ y \<^sup>@ i)" x "(x \ y \<^sup>@ i) \ (x \ y \<^sup>@ i) \ x"] this[folded \(x \ y \<^sup>@ i) \ (x \ y \<^sup>@ i) \ x = (u \ v \<^sup>@ i) \ (u \ v \<^sup>@ i) \ u\], unfolded rassoc, OF refl] show "(x \ y\<^sup>@i)\(x \ y\<^sup>@i) \p (u \ v\<^sup>@i) \ ((x \ y\<^sup>@i) \ (x \ y\<^sup>@i))" by fastforce show "\<^bold>|u \ v \<^sup>@ i\<^bold>| \ \<^bold>|x \ y \<^sup>@ i\<^bold>|" using less_imp_le_nat[OF \\<^bold>|u \ v \<^sup>@ i\<^bold>| < \<^bold>|x \ y \<^sup>@ i\<^bold>|\]. qed obtain r m k where "x\y\<^sup>@i = r\<^sup>@k" "u\v\<^sup>@i = r\<^sup>@m" "primitive r" - using \(u \ v \<^sup>@ i) \ x \ y \<^sup>@ i = (x \ y \<^sup>@ i) \ u \ v \<^sup>@ i\[unfolded + using \(u \ v \<^sup>@ i) \ x \ y \<^sup>@ i = (x \ y \<^sup>@ i) \ u \ v \<^sup>@ i\[unfolded comm_primroots[OF \u \ v \<^sup>@ i \ \\ \x \ y \<^sup>@ i \ \\]] \u \ v \<^sup>@ i \ \\ \x \ y \<^sup>@ i \ \\ primroot_expE primroot_prim by metis have "m < k" using \\<^bold>|u \ v \<^sup>@ i\<^bold>| < \<^bold>|x \ y \<^sup>@ i\<^bold>|\ unfolding strict_prefix_def \u \ v \<^sup>@ i = r \<^sup>@ m\ \x \ y \<^sup>@ i = r \<^sup>@ k\ pow_len by simp have "x\y\<^sup>@i = u\v\<^sup>@i\r\<^sup>@(k-m)" by (simp add: \m < k\ \u \ v \<^sup>@ i = r \<^sup>@ m\ \x \ y \<^sup>@ i = r \<^sup>@ k\ 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>| \ \<^bold>|y\<^sup>@(i-1)\<^bold>|" proof- have "\<^bold>|x \ y\<^sup>@i\<^bold>| = \<^bold>|r\<^sup>@(k-m)\<^bold>| + \<^bold>|u \ v\<^sup>@i\<^bold>|" using lenarg[OF \x\y\<^sup>@i = u\v\<^sup>@i\r\<^sup>@(k-m)\] by auto have "\<^bold>|u\<^bold>| = 2 * \<^bold>|r \<^sup>@ (k - m)\<^bold>| + \<^bold>|x\<^bold>|" using \2*\<^bold>|x \ y\<^sup>@i\<^bold>| + \<^bold>|x\<^bold>| = 2*\<^bold>|u \ v\<^sup>@i\<^bold>| + \<^bold>|u\<^bold>|\ unfolding \\<^bold>|x \ y\<^sup>@i\<^bold>| = \<^bold>|r\<^sup>@(k-m)\<^bold>| + \<^bold>|u \ v\<^sup>@i\<^bold>|\ 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 \x \ y\<^sup>@i\ x \ y\<^sup>@i \ x = u \ v\<^sup>@i\ u \ v\<^sup>@i \ u\] 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 \2*\<^bold>|y\<^sup>@i\<^bold>| + 3*\<^bold>|x\<^bold>| = 2*\<^bold>|v\<^sup>@i\<^bold>| + 3*\<^bold>|u\<^bold>|\ unfolding \\<^bold>|u\<^bold>| = 2 * \<^bold>|r \<^sup>@ (k - m)\<^bold>| + \<^bold>|x\<^bold>|\ 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>| \ \<^bold>|y \<^sup>@ i\<^bold>|" using le_add2 by presburger moreover have "\<^bold>|r\<^bold>| \ \<^bold>|r \<^sup>@ (k - m)\<^bold>|" - by (metis CoWBasic.power.power_Suc CoWBasic.power_Suc2 \primitive r\ \u \ v \<^sup>@ i

y \<^sup>@ i\ \x \ y \<^sup>@ i = u \ v \<^sup>@ i \ r \<^sup>@ (k - m)\ not_le prim_comm_short_emp self_append_conv strict_prefix_def) + by (metis pow_Suc pow_Suc' \primitive r\ \u \ v \<^sup>@ i

y \<^sup>@ i\ + \x \ y \<^sup>@ i = u \ v \<^sup>@ i \ r \<^sup>@ (k - m)\ not_le prim_comm_short_emp + self_append_conv strict_prefix_def) ultimately have "3 * \<^bold>|r\<^bold>| \ \<^bold>|y \<^sup>@ i\<^bold>|" by (meson le_trans mult_le_mono2) hence "3 * \<^bold>|r\<^bold>| \ i*\<^bold>|y\<^bold>|" by (simp add: pow_len) moreover have "i \ 3*(i-1)" using assms(2) by linarith ultimately have "3*\<^bold>|r\<^bold>| \ 3*((i-1)*\<^bold>|y\<^bold>|)" by (metis (no_types, lifting) le_trans mult.assoc mult_le_mono1) hence "\<^bold>|r\<^bold>| \ (i-1)*\<^bold>|y\<^bold>|" by (meson nat_mult_le_cancel1 zero_less_numeral) thus "\<^bold>|r\<^bold>| \ \<^bold>|y\<^sup>@(i-1)\<^bold>|" unfolding pow_len. qed have "\<^bold>|r\<^bold>| + \<^bold>|y\<^bold>| \ \<^bold>|y \<^sup>@ i\<^bold>|" - using \\<^bold>|r\<^bold>| \ \<^bold>|y\<^sup>@(i-1)\<^bold>|\ + using \\<^bold>|r\<^bold>| \ \<^bold>|y\<^sup>@(i-1)\<^bold>|\ unfolding pow_len nat_add_left_cancel_le[of "\<^bold>|y\<^bold>|" "\<^bold>|r\<^bold>|", symmetric] - using add.commute \i \ 0\ mult_eq_if + using add.commute \0 < i\ mult_eq_if by force have "y\<^sup>@i \s y\<^sup>@i\r" using triv_suf[of "y \<^sup>@ i" x, unfolded \x \ y \<^sup>@ i = r \<^sup>@ k\, THEN suf_prod_root]. have "y\<^sup>@i \s y\<^sup>@i\y" by (simp add: suf_pow_ext') from two_pers[reversed, OF \y\<^sup>@i \s y\<^sup>@i\r\ \y\<^sup>@i \s y\<^sup>@i\y\ \\<^bold>|r\<^bold>| + \<^bold>|y\<^bold>| \ \<^bold>|y \<^sup>@ i\<^bold>|\] have "y \ r = r \ y". have "x \ y \<^sup>@ i \ r = r \ x \ y \<^sup>@ i" - by (simp add: power_commutes \x \ y \<^sup>@ i = r \<^sup>@ k\ lassoc) + by (simp add: pow_comm \x \ y \<^sup>@ i = r \<^sup>@ k\ lassoc) hence "x \ r \ y \<^sup>@ i = r \ x \ y \<^sup>@ i" by (simp add: \y \ r = r \ y\ comm_add_exp) hence "x \ r = r \ x" by auto obtain n where "y = r\<^sup>@n" using \primitive r\ \y \ r = r \ y\ 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 \\<^bold>|y \<^sup>@ i\<^bold>| = \<^bold>|v \<^sup>@ i\<^bold>| + 3 * \<^bold>|r \<^sup>@ (k - m)\<^bold>|\ diff_add_inverse2 by presburger hence "\<^bold>|v \<^sup>@ i\<^bold>| = (i*n - 3*(k-m))*\<^bold>|r\<^bold>|" by (simp add: \\<^bold>|v \<^sup>@ i\<^bold>| = i * n * \<^bold>|r\<^bold>| - 3 * \<^bold>|r \<^sup>@ (k - m)\<^bold>|\ ab_semigroup_mult_class.mult_ac(1) left_diff_distrib' pow_len) have "v\<^sup>@i \ r*" using per_exp_eq[reversed, OF _ \\<^bold>|v \<^sup>@ i\<^bold>| = (i*n - 3*(k-m))*\<^bold>|r\<^bold>|\] \u \ v \<^sup>@ i = r \<^sup>@ m\ suf_prod_root triv_suf by metis have "u \ r = r \ u" - using root_suf_cancel[OF \v \<^sup>@ i \ r*\ rootI[of r m, folded \u \ v \<^sup>@ i = r \<^sup>@ m\]] + using root_suf_cancel[OF rootI[of r m, folded \u \ v \<^sup>@ i = r \<^sup>@ m\] \v \<^sup>@ i \ r*\] self_root[of r] unfolding comm_root by blast have "v \ r = r \ v" - using comm_drop_exp[OF \i \ 0\, + thm comm_drop_exp + using comm_drop_exp[OF \0 < i\, OF comm_rootI[OF self_root \v\<^sup>@i \ r*\]]. show ?thesis using commutesI_root[of "{x, y, u, v}" r] prim_comm_root[OF \primitive r\ \u \ r = r \ u\] prim_comm_root[OF \primitive r\ \v \ r = r \ v\] prim_comm_root[OF \primitive r\ \x \ r = r \ x\] prim_comm_root[OF \primitive r\ \y \ r = r \ y\] by auto qed -theorem "\ binary_equality_word (\ \ \\<^sup>@Suc k \ \ \ \)" +theorem "\ binary_equality_word (\ \ \\<^sup>@Suc k \ \ \ \)" proof - assume "binary_equality_word (\ \ \ \<^sup>@ Suc k \ \ \ \)" - then obtain g' h' where g'_morph: "binary_code_morphism (g' :: binA list \ nat list)" and h'_morph: "binary_code_morphism h'" and "g' \ h'" and - msol': "(\ \ \ \<^sup>@ Suc k \ \ \ \) \ g' =\<^sub>M h'" + assume "binary_equality_word (\ \ \ \<^sup>@ Suc k \ \ \ \)" + then obtain g' h' where g'_morph: "binary_code_morphism (g' :: binA list \ nat list)" and h'_morph: "binary_code_morphism h'" and "g' \ h'" and + msol': "(\ \ \ \<^sup>@ Suc k \ \ \ \) \ g' =\<^sub>M h'" using binary_equality_word_def by blast interpret g': binary_code_morphism g' - by fact + by fact interpret h': binary_code_morphism h' - by fact + by fact interpret gh: two_morphisms g' h' by (simp add: g'.morphism_axioms h'.morphism_axioms two_morphisms_def) - have "\<^bold>|g'(\ \ \)\<^bold>| \ \<^bold>|h'(\ \ \)\<^bold>|" + have "\<^bold>|g'(\ \ \)\<^bold>| \ \<^bold>|h'(\ \ \)\<^bold>|" proof - assume len: "\<^bold>|g'(\ \ \)\<^bold>| = \<^bold>|h'(\ \ \)\<^bold>|" - hence eq1: "g'(\ \ \) = h'(\ \ \)" and eq2: "g' (\\<^sup>@k \ \ \ \) = h' (\\<^sup>@k \ \ \ \)" - using msol' eqd_eq[OF _ len, of "g' (\\<^sup>@k \ \ \ \)" "h' (\\<^sup>@k \ \ \ \) "] - unfolding minsoldef pow_Suc pow_one g'.morph[symmetric] h'.morph[symmetric] rassoc + assume len: "\<^bold>|g'(\ \ \)\<^bold>| = \<^bold>|h'(\ \ \)\<^bold>|" + hence eq1: "g'(\ \ \) = h'(\ \ \)" and eq2: "g' (\\<^sup>@k \ \ \ \) = h' (\\<^sup>@k \ \ \ \)" + using msol' eqd_eq[OF _ len, of "g' (\\<^sup>@k \ \ \ \)" "h' (\\<^sup>@k \ \ \ \) "] + unfolding min_sol_def pow_Suc pow_one g'.morph[symmetric] h'.morph[symmetric] rassoc by blast+ - hence "g' (\\<^sup>@k) = h' (\\<^sup>@k)" + hence "g' (\\<^sup>@k) = h' (\\<^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 \k = 0\ pow_one] + from min_solD_min[OF msol' _ _ eq1, unfolded \k = 0\ pow_one] show False by simp next assume "k \ 0" - hence "g' (\) = h' (\)" - using \g' (\\<^sup>@k) = h' (\\<^sup>@k)\ + hence "g' (\) = h' (\)" + using \g' (\\<^sup>@k) = h' (\\<^sup>@k)\ unfolding g'.pow_morph h'.pow_morph using pow_eq_eq by blast - hence "g' (\) = h' (\)" - using \g'(\ \ \) = h'(\ \ \)\ unfolding g'.morph h'.morph + hence "g' (\) = h' (\)" + using \g'(\ \ \) = h'(\ \ \)\ unfolding g'.morph h'.morph by simp - show False - using gh.def_on_sings_eq[OF finite_2.induct[of "\ a. g'[a] = h'[a]", OF \g' (\) = h' (\)\ \g' (\) = h' (\)\]] + show False + using gh.def_on_sings_eq[OF finite_2.induct[of "\ a. g'[a] = h'[a]", OF \g' (\) = h' (\)\ \g' (\) = h' (\)\]] \g' \ h'\ by blast qed qed - then have less': "\<^bold>|(if \<^bold>|g' (\ \ \)\<^bold>| < \<^bold>|h' (\ \ \)\<^bold>| then g' else h') (\ \ \)\<^bold>| - < \<^bold>|(if \<^bold>|g' (\ \ \)\<^bold>| < \<^bold>|h' (\ \ \)\<^bold>| then h' else g') (\ \ \)\<^bold>|" - by simp + then have less': "\<^bold>|(if \<^bold>|g' (\ \ \)\<^bold>| < \<^bold>|h' (\ \ \)\<^bold>| then g' else h') (\ \ \)\<^bold>| + < \<^bold>|(if \<^bold>|g' (\ \ \)\<^bold>| < \<^bold>|h' (\ \ \)\<^bold>| then h' else g') (\ \ \)\<^bold>|" + by simp obtain g h where g_morph: "binary_code_morphism (g :: binA list \ nat list)" and h_morph: "binary_code_morphism h" - and msol: "g (\ \ \ \<^sup>@ Suc k \ \ \ \) = h (\ \ \ \<^sup>@ Suc k \ \ \ \)" and less: "\<^bold>|g(\ \ \)\<^bold>| < \<^bold>|h(\ \ \)\<^bold>|" - using that[of "(if \<^bold>|g' (\ \ \)\<^bold>| < \<^bold>|h' (\ \ \)\<^bold>| then g' else h')" "(if \<^bold>|g' (\ \ \)\<^bold>| < \<^bold>|h' (\ \ \)\<^bold>| then h' else g')", OF _ _ _ less'] - g'_morph h'_morph minsolD[OF msol'] by presburger + and msol: "g (\ \ \ \<^sup>@ Suc k \ \ \ \) = h (\ \ \ \<^sup>@ Suc k \ \ \ \)" and less: "\<^bold>|g(\ \ \)\<^bold>| < \<^bold>|h(\ \ \)\<^bold>|" + using that[of "(if \<^bold>|g' (\ \ \)\<^bold>| < \<^bold>|h' (\ \ \)\<^bold>| then g' else h')" "(if \<^bold>|g' (\ \ \)\<^bold>| < \<^bold>|h' (\ \ \)\<^bold>| then h' else g')", OF _ _ _ less'] + g'_morph h'_morph min_solD[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 \ \s g (\ \ \)" and "h \ \s h (\ \ \)" + have "g \ \s g (\ \ \)" and "h \ \s h (\ \ \)" unfolding g.morph h.morph by blast+ from not_bew_baiba[OF less this, of k] msol - have "commutes {g \, g (\ \ \), h \, h (\ \ \)}" + have "commutes {g \, g (\ \ \), h \, h (\ \ \)}" unfolding g.morph h.morph g.pow_morph h.pow_morph pow_Suc rassoc by blast - hence "g \ \ g (\ \ \) = g (\ \ \) \ g \" + hence "g \ \ g (\ \ \) = g (\ \ \) \ g \" 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 +end 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,1201 +1,1298 @@ (* 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 Submonoids Periodicity_Lemma begin +chapter \Lyndon-Schützenberger Equation\ + +section \The original result\ + +text\The Lyndon-Schützenberger equation is the following equation: +\[ +x^ay^b = z^c, +\] +in this formalization denoted as @{term "x\<^sup>@a\y\<^sup>@b = z\<^sup>@c"}. + +We formalize here a complete solution of this equation. + +The main result, proved by Lyndon and Schützenberger is that the equation has periodic solutions only in free groups if $2 \leq a,b,c$ +In this formalization we consider the equation in words only. Then the original result can be formulated as saying that all words +$x$, $y$ and $z$ satisfying the equality ith $2 \leq a,b,c$ pairwise commute. + +The result in free groups was first proved in @{cite LySch62}. +For words, there are several proofs to be found in the literature (for instance @{cite Lo83 and Dmsi2006}). +The presented proof is the authors' proof. + +In addition, we give a full parametric solution of the equation for any $a$, $b$ and $c$. +\ + +section "The original result" + text\If $x^a$ or $y^b$ is sufficiently long, then the claim follows from the Periodicity Lemma.\ -lemma LS_per_lemma_case: - assumes eq: "x\<^sup>@a\y\<^sup>@b = z\<^sup>@c" and "a \ 0" and "b \ 0" and "\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| \ \<^bold>|x\<^sup>@a\<^bold>|" - shows "x\y=y\x" -proof (cases "x = \") - assume "x = \" - thus "x\y=y\x" by simp -next - assume "x \ \" - hence "z\<^sup>@c \ \" - using eq assms emp_pow[of c] by auto - hence "x\<^sup>@a \p (z\<^sup>@c)\<^sup>\" - 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 \p x\<^sup>\" - using \x \ \\ \a \ 0\ root_self[THEN per_drop_exp] by blast - from two_pers_root[OF per_drop_exp[OF \x\<^sup>@a \p (z\<^sup>@c)\<^sup>\\] this \\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| \ \<^bold>|x \<^sup>@ a\<^bold>|\ ] - have "z \ x = x \ z". +lemma LS_per_lemma_case1: + assumes eq: "x\<^sup>@a\y\<^sup>@b = z\<^sup>@c" and "0 < a" and "0 < b" and "\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| - 1 \ \<^bold>|x\<^sup>@a\<^bold>|" + shows "x \ y = y \ x" and "x \ z = z \ x" +proof + have "x\<^sup>@a \p (z\<^sup>@c) \ x\<^sup>@a" "x \<^sup>@ a \p x \ x \<^sup>@ a" + unfolding eq[symmetric] shifts_rev by blast+ + hence "x\<^sup>@a \p z \ x\<^sup>@a" + using eq pref_prod_root triv_pref by metis + from two_pers_1[OF this \x \<^sup>@ a \p x \ x \<^sup>@ a\ \\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| - 1 \ \<^bold>|x \<^sup>@ a\<^bold>|\, symmetric] + show "x \ z = z \ x". hence "z\<^sup>@c\x\<^sup>@a = x\<^sup>@a\z\<^sup>@c" by (simp add: comm_add_exps) from this[folded eq, unfolded rassoc cancel, symmetric] have "x\<^sup>@a \ y\<^sup>@b = y\<^sup>@b \ x\<^sup>@a". - from this[unfolded comm_pow_roots[OF \a \ 0\ \b \ 0\]] + from this[unfolded comm_pow_roots[OF \0 < a\ \0 < b\]] show "x \ y = y \ x". qed -chapter \Lyndon-Schützenberger Equation\ - -section \The original result\ - -text\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\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 -$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. -\ - -text\We set up a locale representing the Lyndon-Schützenberger Equation.\ - +text \A weaker version will be often more convenient\ +lemma LS_per_lemma_case: + assumes eq: "x\<^sup>@a\y\<^sup>@b = z\<^sup>@c" and "0 < a" and "0 < b" and "\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| \ \<^bold>|x\<^sup>@a\<^bold>|" + shows "x \ y = y \ x" and "x \ z = z \ x" + using LS_per_lemma_case1[OF assms(1-3)] assms(4) by force+ text\The most challenging case is when $c = 3$.\ lemma LS_core_case: - assumes + assumes eq: "x\<^sup>@a \ y\<^sup>@b = z\<^sup>@c" and "2 \ a" and "2 \ b" and "2 \ c" and - "c = 3" and - "b*\<^bold>|y\<^bold>| \ a*\<^bold>|x\<^bold>|" and "x \ \" and "y \ \" and + "c = 3" and + "b*\<^bold>|y\<^bold>| \ a*\<^bold>|x\<^bold>|" and "x \ \" and "y \ \" 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\y = y\x" -proof- - have "a \ 0" and "b \ 0" + shows "x\y = y\x" +proof- + have "0 < a" and "0 < b" using \2 \ a\ \2 \ b\ by auto \\We first show that a = 2\ have "a*\<^bold>|x\<^bold>|+b*\<^bold>|y\<^bold>| = 3*\<^bold>|z\<^bold>|" using \c = 3\ eq lenmorph[of "x\<^sup>@a" "y\<^sup>@b"] by (simp add: pow_len) hence "3*\<^bold>|z\<^bold>| \ a*\<^bold>|x\<^bold>| + a*\<^bold>|x\<^bold>|" using \b*\<^bold>|y\<^bold>| \ a*\<^bold>|x\<^bold>|\ 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 \2 \ a\ by force - hence "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" using \b*\<^bold>|y\<^bold>| \ a*\<^bold>|x\<^bold>|\ \2 \ b\ + hence "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" using \b*\<^bold>|y\<^bold>| \ a*\<^bold>|x\<^bold>|\ \2 \ 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 by auto have "x\x\y\<^sup>@b = z\z\z" using \2 \ a\ eq \c=3\ \a=2\ - by (simp add: numeral_2_eq_2 numeral_3_eq_3) + by (simp add: numeral_2_eq_2 numeral_3_eq_3) \ \Find words u, v, w\ have "\<^bold>|z\<^bold>| < \<^bold>|x\x\<^bold>|" - using \\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| < 3 * \<^bold>|x\<^bold>|\ add.commute by auto + using \\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| < 3 * \<^bold>|x\<^bold>|\ add.commute by auto from ruler_le[THEN prefD, OF triv_pref[of z "z\z"] _ less_imp_le[OF this]] - obtain w where "z\w = x\x" - using prefI[of "x\x" "y\<^sup>@b" "z\z\z", unfolded rassoc, OF \x\x\y\<^sup>@b = z\z\z\] by fastforce + obtain w where "z\w = x\x" + using prefI[of "x\x" "y\<^sup>@b" "z\z\z", unfolded rassoc, OF \x\x\y\<^sup>@b = z\z\z\] by fastforce have "\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|" using \a = 2\ lenx by auto from ruler_le[THEN prefD, OF _ _ less_imp_le[OF this], of "x\x\y\<^sup>@b", OF triv_pref, unfolded \x\x\y\<^sup>@b = z\z\z\, OF triv_pref] - obtain u :: "'a list" where "x\u=z" + obtain u :: "'a list" where "x\u=z" by blast have "u \ \" - using \\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|\ \x\u = z\ by auto + using \\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|\ \x\u = z\ by auto have "x = u\w" using \z\w = x\x\ \x\u = z\ by auto have "\<^bold>|x\x\<^bold>| < \<^bold>|z\z\<^bold>|" by (simp add: \\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|\ add_less_mono) from ruler_le[OF triv_pref[of "x\x" "y\<^sup>@b", unfolded rassoc \x\x\y\<^sup>@b = z\z\z\, unfolded lassoc] triv_pref, OF less_imp_le[OF this]] have "z\w \p z\z" unfolding \z\w = x\x\. obtain v :: "'a list" where "w \ v = x" - using lq_pref[of w x] - pref_prod_pref'[OF pref_cancel[OF \z\w \p z\z\, folded \x \ u = z\, unfolded \x = u \ w\ rassoc], folded \x = u \ w\] by blast + using lq_pref[of w x] + pref_prod_pref'[OF pref_cancel[OF \z\w \p z\z\, folded \x \ u = z\, unfolded \x = u \ w\ rassoc], folded \x = u \ w\] by blast have "u\w\v \ \" by (simp add: \u \ \\) \ \Express x, y and z in terms of u, v and w\ hence "z = w\v\u" using \w \ v = x\ \x \ u = z\ by auto from \x \ x \ y\<^sup>@b = z \ z \ z\[unfolded this lassoc, folded \z \ w = x \ x\, unfolded this rassoc] have "w\v \ u\w \ y\<^sup>@b = w\v\u\w\v\u\w\v\u". hence "y\<^sup>@b = v\u\w\v\u" using pref_cancel by auto \ \Double period of uwv\ from period_fac[OF _ \u\w\v \ \\, of v u "\<^bold>|y\<^bold>|", unfolded rassoc, folded this] have "period (u\w\v) \<^bold>|y\<^bold>|" - using pow_per[OF \y \ \\ \b \ 0\] by blast + using pow_per[OF \y \ \\ \0 < b\] by blast have "u\w\v = x \v" - by (simp add: \x = u \ w\) + by (simp add: \x = u \ w\) have "u\w\v = u\ x" by (simp add: \w \ v = x\) - have "u\w\v \p u\<^sup>\" - unfolding period_root_def + have "u\w\v

(u\w\v)" using \u \ w \ v = u \ x\[unfolded \x = u \ w\] \u \ \\ triv_pref[of "u \ u \ w" v] by force have "period (u\w\v) \<^bold>|u\<^bold>|" - using \u \ w \ v \p u \<^sup>\\ by auto + using \u\w\v

(u\w\v)\ by auto \ \Common period d\ obtain d::nat where "d=gcd \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|" by simp have "\<^bold>|y\<^bold>| + \<^bold>|u\<^bold>| \ \<^bold>|u\w\v\<^bold>|" using \\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|\ lenmorph \u\w\v = u\ x\ by simp - hence "period (u\w\v) d" + hence "period (u\w\v) d" using \period (u \ w \ v) \<^bold>|u\<^bold>|\ \period (u \ w \ v) \<^bold>|y\<^bold>|\ \d = gcd \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|\ two_periods by blast \ \Divisibility\ have "v\u\z=y\<^sup>@b" by (simp add: \y\<^sup>@b = v \ u \ w \ v \ u\ \z = w \ v \ u\) have "\<^bold>|u\<^bold>| = \<^bold>|v\<^bold>|" using \x = u \ w\ \w \ v = x\ 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: \d = gcd \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|\) have "d dvd \<^bold>|u\<^bold>|" by (simp add: \d = gcd \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|\) have "\<^bold>|z\<^bold>| + \<^bold>|u\<^bold>| + \<^bold>|v\<^bold>| = b*\<^bold>|y\<^bold>|" using lenarg[OF \v\u\z=y\<^sup>@b\, unfolded lenmorph pow_len] by auto from dvd_add_left_iff[OF \d dvd \<^bold>|v\<^bold>|\, of "\<^bold>|z\<^bold>|+\<^bold>|u\<^bold>|", unfolded this dvd_add_left_iff[OF \d dvd \<^bold>|u\<^bold>|\, of "\<^bold>|z\<^bold>|"]] - have "d dvd \<^bold>|z\<^bold>|" - using \d = gcd \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|\ dvd_mult by blast + have "d dvd \<^bold>|z\<^bold>|" + using \d = gcd \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|\ dvd_mult by blast from lenarg[OF \z = w \ v \ u\, unfolded lenmorph pow_len] have "d dvd \<^bold>|w\<^bold>|" using \d dvd \<^bold>|z\<^bold>|\ \d dvd \<^bold>|u\<^bold>|\ \d dvd \<^bold>|v\<^bold>|\ by (simp add: dvd_add_left_iff) hence "d dvd \<^bold>|x\<^bold>|" using \d dvd \<^bold>|v\<^bold>|\ \w \ v = x\ by force \ \x and y commute\ have "x \p u\w\v" - by (simp add: \x = u \ w\) + by (simp add: \x = u \ w\) have "period x d" using per_pref'[OF \x\\\ \period (u\w\v) d \ \x \p u \w\v\]. hence "x \ (take d x)*" using \d dvd \<^bold>|x\<^bold>|\ - using root_divisor by blast + using root_divisor by blast hence "period u d " using \x = u \ w\ per_pref' using \period x d\ \u \ \\ by blast have " take d x = take d u" using \u\\\ \x = u \ w\ pref_share_take by (simp add: \d = gcd \<^bold>|y\<^bold>| \<^bold>|u\<^bold>|\) from root_divisor[OF \period u d\ \d dvd \<^bold>|u\<^bold>|\, folded this] have "u \ (take d x)*". - hence "z \ (take d x)*" + hence "z \ (take d x)*" using \x\u=z\ \x \ (take d x)*\ add_roots by blast from root_pref_cancel[OF _ root_pow_root[OF \x \ take d x*\, of a],of "y\<^sup>@b", unfolded eq, OF root_pow_root[OF this, of c]] - have "y\<^sup>@b \ (take d x)*". - from comm_rootI[OF root_pow_root[OF \x \ take d x*\, of a] this] - show "x \ y = y \ x" - unfolding comm_pow_roots[OF \a \ 0\ \b \ 0\, of x y]. + have "y\<^sup>@b \ (take d x)*". + from comm_rootI[OF root_pow_root[OF \x \ take d x*\, of a] this] + show "x \ y = y \ x" + unfolding comm_pow_roots[OF \0 < a\ \0 < b\, of x y]. qed -text\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\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|$. \ lemma Lyndon_Schutzenberger': "\ x\<^sup>@a\y\<^sup>@b = z\<^sup>@c; 2 \ a; 2 \ b; 2 \ c \ \ x\y = y\x" proof (induction "\<^bold>|z\<^bold>| + b* \<^bold>|y\<^bold>|" arbitrary: x y z a b c rule: less_induct) case less - have "a \ 0" and "b \ 0" + have "0 < a" and "0 < b" using \2 \ a\ \2 \ b\ by auto have LSrev_eq: "rev y \<^sup>@ b \ rev x \<^sup>@ a = rev z \<^sup>@ c" - using \x\<^sup>@a\y\<^sup>@b = z\<^sup>@c\ + using \x\<^sup>@a\y\<^sup>@b = z\<^sup>@c\ unfolding rev_append[symmetric] rev_pow[symmetric] by blast have leneq: "a * \<^bold>|x\<^bold>| + b*\<^bold>|y\<^bold>| = c * \<^bold>|z\<^bold>|" using lenarg[OF \x\<^sup>@a\y\<^sup>@b = z\<^sup>@c\] unfolding pow_len lenmorph. show "x \ y = y \ x" proof assume "x \ \" and "y \ \" show "x \ y = y \ x" proof (cases "\<^bold>|x \<^sup>@ a\<^bold>| < \<^bold>|y \<^sup>@ b\<^bold>|") \ \WLOG assumption\ 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 \\<^bold>|x\<^sup>@a\<^bold>| < \<^bold>|y\<^sup>@b\<^bold>|\ by (simp add: pow_len) from "less.hyps"[OF this LSrev_eq \2 \ b\ \2 \ a\ \2 \ c\, symmetric] show "x \ y = y \ x" - unfolding rev_append[symmetric] rev_is_rev_conv by simp + unfolding rev_append[symmetric] rev_is_rev_conv by simp next assume " \ \<^bold>|x\<^sup>@a\<^bold>| < \<^bold>|y\<^sup>@b\<^bold>|" hence "\<^bold>|y\<^sup>@b\<^bold>| \ \<^bold>|x\<^sup>@a\<^bold>|" by force \ \case solved by the Periodicity lemma\ - note minus = Suc_minus2[OF \2 \ a\] Suc_minus2[OF \2 \ b\] + note minus = Suc_minus2[OF \2 \ a\] Suc_minus2[OF \2 \ b\] consider (with_Periodicity_lemma) "\<^bold>|z\<^bold>| + \<^bold>|x\<^bold>| \ \<^bold>|x \<^sup>@ Suc(Suc (a-2))\<^bold>| \ \<^bold>|z\<^bold>| + \<^bold>|y\<^bold>| \ \<^bold>|y \<^sup>@ Suc(Suc (b-2))\<^bold>|" | - (without_Periodicity_lemma) + (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 + using not_le_imp_less by blast thus "x \ y = y \ x" proof (cases) case with_Periodicity_lemma have "x = \ \ rev y = \ \ x \ y = y \ x" by auto thus "x \ y = y \ x" - using LS_per_lemma_case[OF \x\<^sup>@a\y\<^sup>@b = z\<^sup>@c\ \a \ 0\ \b \ 0\] - LS_per_lemma_case[OF LSrev_eq \b \ 0\ \a \ 0\] with_Periodicity_lemma[unfolded minus] + using LS_per_lemma_case[OF \x\<^sup>@a\y\<^sup>@b = z\<^sup>@c\ \0 < a\ \0 < b\] + LS_per_lemma_case[OF LSrev_eq \0 < b\ \0 < a\] 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>@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>|" + 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 \c < 4\ \2 \ c\ by linarith then show "x \ y = y \ x" proof(cases) - case c_is_3 - show "x \ y = y \ x" - using + case c_is_3 + show "x \ y = y \ x" + using LS_core_case[OF \x\<^sup>@a\y\<^sup>@b = z\<^sup>@c\ \2 \ a\ \2 \ b\ \2 \ c\ \c = 3\ \\<^bold>|y\<^sup>@b\<^bold>| \ \<^bold>|x\<^sup>@a\<^bold>|\[unfolded pow_len] - _ _ lenx[unfolded pow_len minus] leny[unfolded pow_len minus]] - \x \ \\ \y \ \\ + _ _ lenx[unfolded pow_len minus] leny[unfolded pow_len minus]] + \x \ \\ \y \ \\ by blast - next - assume "c = 2" + next + assume "c = 2" hence eq2: "x\<^sup>@a \ y\<^sup>@b = z \ z" by (simp add: \x\<^sup>@a\y\<^sup>@b = z\<^sup>@c\) - from dual_order.trans le_cases[of "\<^bold>|x\<^sup>@a\<^bold>|" "\<^bold>|z\<^bold>|" "\<^bold>|z\<^bold>| \ \<^bold>|x\<^sup>@a\<^bold>|", unfolded eq_len_iff[OF this]] - have "\<^bold>|z\<^bold>| \ \<^bold>|x\<^sup>@a\<^bold>|" - using \\<^bold>|y\<^sup>@b\<^bold>| \ \<^bold>|x\<^sup>@a\<^bold>|\ by blast - obtain a' where "Suc a' = a" and "1 \ a'" - using \2 \ a\ minus by auto - from eq2[folded \Suc a' = a\, unfolded pow_Suc2 rassoc] pow_Suc2[of x a', unfolded this, symmetric] + from dual_order.trans le_cases[of "\<^bold>|x\<^sup>@a\<^bold>|" "\<^bold>|z\<^bold>|" "\<^bold>|z\<^bold>| \ \<^bold>|x\<^sup>@a\<^bold>|", unfolded eq_len_iff[OF this]] + have "\<^bold>|z\<^bold>| \ \<^bold>|x\<^sup>@a\<^bold>|" + using \\<^bold>|y\<^sup>@b\<^bold>| \ \<^bold>|x\<^sup>@a\<^bold>|\ by blast + define a' where "a' \ a - 1" + have "Suc a' = a" and "1 \ a'" + using \2 \ a\ unfolding a'_def by auto + from eq2[folded \Suc a' = a\, unfolded pow_Suc' rassoc] pow_Suc'[of x a', unfolded this, symmetric] have eq3: "x \<^sup>@ a' \ x \ y \<^sup>@ b = z \ z" and aa':"x \<^sup>@ a' \ x = x \<^sup>@ a ". - hence "\<^bold>|x\<^sup>@a'\<^bold>| < \<^bold>|z\<^bold>|" - using \Suc a' = a\ 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 \1 \ a'\, THEN leD] unfolding pow_len + hence "\<^bold>|x\<^sup>@a'\<^bold>| < \<^bold>|z\<^bold>|" + using \Suc a' = a\ 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 \1 \ a'\, THEN leD] unfolding pow_len by linarith obtain u w where "x\<^sup>@a'\u = z" and "w \ y\<^sup>@b = z" using eqdE[OF eq3[unfolded rassoc] less_imp_le[OF \\<^bold>|x\<^sup>@a'\<^bold>| < \<^bold>|z\<^bold>|\], of thesis] eqdE[OF eq2[symmetric] \\<^bold>|z\<^bold>| \ \<^bold>|x\<^sup>@a\<^bold>|\, of thesis] by fast have "x\<^sup>@a'\x\y\<^sup>@b = x\<^sup>@a'\u\w\y\<^sup>@b" unfolding lassoc \x \<^sup>@ a' \ u = z\ \w \ y\<^sup>@b = z\ aa' eq2 cancel.. hence "u\w=x" by auto hence "\<^bold>|w\u\<^bold>| = \<^bold>|x\<^bold>|" using swap_len by blast \ \Induction step: new equation with shorter z\ have "w\<^sup>@2\y\<^sup>@b = (w\u)\<^sup>@a" unfolding pow_two using \w \ y \<^sup>@ b = z\ \x \<^sup>@ a' \ u = z\ \u\w=x\ pow_slide[of w u a', unfolded \Suc a' = a\] by simp from "less.hyps"[OF _ this _ \2 \ b\ \2 \ a\, unfolded \\<^bold>|w\u\<^bold>| = \<^bold>|x\<^bold>|\] - have "y\w = w\y" + have "y\w = w\y" using \\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|\ by force have "y \ z = z \ y" unfolding \w \ y\<^sup>@b = z\[symmetric] lassoc \y\w = w\y\ - by (simp add: pow_comm) + by (simp add: pow_comm) hence "z\<^sup>@c\y\<^sup>@b = y\<^sup>@b\z\<^sup>@c" - by (simp add: comm_add_exps) + by (simp add: comm_add_exps) from this[folded \x\<^sup>@a\y\<^sup>@b = z\<^sup>@c\, unfolded lassoc] have "x\<^sup>@a\y\<^sup>@b = y\<^sup>@b\x\<^sup>@a" using cancel_right by blast - from this[unfolded comm_pow_roots[OF \a \ 0\ \b \ 0\]] + from this[unfolded comm_pow_roots[OF \0 < a\ \0 < b\]] show "x \ y = y \ x". qed qed qed qed qed theorem Lyndon_Schutzenberger: assumes "x\<^sup>@a\y\<^sup>@b = z\<^sup>@c" and "2 \ a" and "2 \ b" and "2 \ c" shows "x\y = y\x" and "x\z = z\x" and "y\z = z\y" proof- show "x \ y = y \ x" using Lyndon_Schutzenberger'[OF assms]. - have "c \ 0" and "b \ 0" using \2 \ c\ \2 \ b\ by auto + have "0 < c" and "0 < b" + using \2 \ c\ \2 \ b\ by auto have "x \ x\<^sup>@a \ y\<^sup>@b = x\<^sup>@a \ y\<^sup>@b \ x" and "y \ x\<^sup>@a \ y\<^sup>@b = x\<^sup>@a \ y\<^sup>@b \ y" - unfolding comm_add_exp[OF \x \ y = y \ x\[symmetric], of b] comm_add_exp[OF \x \ y = y \ x\, symmetric, of a] - lassoc power_commutes by blast+ + unfolding comm_add_exp[OF \x \ y = y \ x\[symmetric], of b] + unfolding lassoc pow_comm comm_add_exp[OF \x \ y = y \ x\, symmetric, of a] by blast+ thus "x\z = z\x" and "y\z = z\y" - using comm_drop_exp[OF \c \ 0\] unfolding lassoc \x\<^sup>@a\y\<^sup>@b = z\<^sup>@c\ by metis+ + using comm_drop_exp[OF \0 < c\] unfolding lassoc \x\<^sup>@a\y\<^sup>@b = z\<^sup>@c\ by metis+ qed -hide_fact Lyndon_Schutzenberger' +hide_fact Lyndon_Schutzenberger' LS_core_case + +subsection "Some alternative formulations." lemma Lyndon_Schutzenberger_conjug: assumes "u \ v" and "\ primitive (u \ v)" shows "u \ v = v \ u" proof- obtain r s where "u = r \ s" and "v = s \ r" using \u \ v\ by blast have "u \ v \ r\<^sup>@2 \ s\<^sup>@2" using conjugI'[of "r \ s \ s" r] unfolding \u = r \ s\ \v = s \ r\ pow_two rassoc. hence "\ primitive (r\<^sup>@2 \ s\<^sup>@2)" using \\ primitive (u \ v)\ prim_conjug by auto - from not_prim_pow[OF this, of "r \ s = s \ r"] + from not_prim_primroot_expE[OF this, of "r \ s = s \ r"] have "r \ s = s \ r" - using Lyndon_Schutzenberger(1)[of r 2 s 2, OF _ order.refl order.refl] by metis + using Lyndon_Schutzenberger(1)[of r 2 s 2, OF _ order.refl order.refl] by metis thus "u \ v = v \ u" using \u = r \ s\ \v = s \ r\ by presburger qed -lemma Lyndon_Schutzenberger_prim: assumes "\ primitive x" and "\ primitive y" and "\ primitive (x \ y)" - shows "x \ y = y \ x" +lemma Lyndon_Schutzenberger_prim: assumes "\ primitive x" and "\ primitive y" and "\ primitive (x \ y)" + shows "x \ y = y \ x" proof - assume "x \ \" and "y \ \" - from not_prim_primroot_expE'[OF \\ primitive y\ \y \ \\] - obtain m r where "r\<^sup>@m = y" and "2 \ m" and "\ y = r" by metis - from not_prim_primroot_expE'[OF \\ primitive x\ \x \ \\] - obtain k s where "s\<^sup>@k = x" and "2 \ k" and "\ x = s" by metis - from not_prim_primroot_expE'[OF \\ primitive (x \ y)\ pref_nemp[OF \x \ \\]] - obtain l z where "z\<^sup>@l = x \ y" and "2 \ l". - from Lyndon_Schutzenberger(1)[OF this(1)[symmetric, - folded \r\<^sup>@m = y\ \s\<^sup>@k = x\, folded \\ x = s\ \\ y = r\] \2 \ k\ \2 \ m\ \2 \l\] - show "x \ y = y \ x" - unfolding comp_primroot_conv'[OF \x \ \\ \y \ \\, symmetric]. + assume "x \ \" and "y \ \" + from not_prim_primroot_expE[OF \\ primitive y\] + obtain m where "\ y\<^sup>@m = y" and "2 \ m". + from not_prim_primroot_expE[OF \\ primitive x\] + obtain k where "\ x\<^sup>@k = x" and "2 \ k". + from not_prim_primroot_expE[OF \\ primitive (x \ y)\] + obtain l where "\(x \ y)\<^sup>@l = x \ y" and "2 \ l". + from Lyndon_Schutzenberger(1)[of "\ x" k "\ y" m "\ (x \ y)" l, + OF _ \2 \ k\ \2 \ m\ \2 \ l\] + show "x \ y = y \ x" + unfolding \\ y\<^sup>@m = y\ \\ x\<^sup>@k = x\ \\(x \ y)\<^sup>@l = x \ y\ + comp_primroot_conv'[of x y] by blast qed -lemma Lyndon_Schutzenberger_rotate: assumes "x\<^sup>@k = r \<^sup>@ Suc q \ u\<^sup>@k \ r \<^sup>@ Suc q" - and "1 < k" and "u \ \" -shows "u \ r = r \ u" and "u \ x = x \ u" and "x \ r = r \ x" -proof- - have "2 \ k" - using One_nat_def assms(2) by presburger - have "2 \ Suc q + Suc q" - by simp - - have "r \<^sup>@ Suc q \p x \ r \<^sup>@ Suc q" - by (metis assms(1) prefI pref_prod_root) - have "u\<^sup>@k \ r \<^sup>@ (Suc q + Suc q) = ((r \<^sup>@ Suc q)\\<^sup>>(x \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)] \r \<^sup>@ Suc q \p x \ r \<^sup>@ Suc q\ - by force - - from Lyndon_Schutzenberger(1)[OF \u\<^sup>@k \ r \<^sup>@ (Suc q + Suc q) = ((r \<^sup>@ Suc q)\\<^sup>>(x \r\<^sup>@Suc q))\<^sup>@k\ \2 \k\ \2 \ Suc q + Suc q\ \2 \k\] - show "u \ r = r \ u". - - have "x\<^sup>@k \ r = r \ x\<^sup>@k" - unfolding assms(1) lassoc pow_comm[of r "Suc q", symmetric] - unfolding rassoc power_commuting_commutes[OF \u \ r = r \ u\, 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 \ r = r \ x". - show "u \ x = x \ u" - proof(cases "r = \") - case True - with Lyndon_Schutzenberger(2)[OF \u\<^sup>@k \ r \<^sup>@ (Suc q + Suc q) = ((r \<^sup>@ Suc q)\\<^sup>>(x \r\<^sup>@Suc q))\<^sup>@k\ \2 \k\ \2 \ Suc q + Suc q\ \2 \k\] - show ?thesis - by force - next - case False - from comm_trans[OF \u \ r = r \ u\ \x \ r = r \ x\ this] - show ?thesis. +lemma Lyndon_Schutzenberger_rotate: assumes "x\<^sup>@c = r \<^sup>@ k \ u\<^sup>@b \ r \<^sup>@ k'" + and "2 \ b" and "2 \ c" and "0 < k" and "0 < k'" +shows "u \ r = r \ u" +proof(rule comm_drop_exps) + show "u\<^sup>@b \ r\<^sup>@(k' + k) = r\<^sup>@(k' + k) \ u\<^sup>@b" + proof(rule Lyndon_Schutzenberger_prim) + have "2 \ (k' + k)" + using \0 < k\ \0 < k'\ by simp + from pow_nemp_imprim[OF \2 \ b\] pow_nemp_imprim[OF this] + show "\ primitive (u\<^sup>@b)" and "\ primitive (r \<^sup>@ (k' + k))" + unfolding Suc_minus2[OF \2 \ b\]. + from pow_nemp_imprim[OF \2 \ c\] + have "\ primitive (r \<^sup>@ k \ u\<^sup>@b \ r \<^sup>@ k')" + unfolding assms(1)[symmetric]. + from this[unfolded conjug_prim_iff[OF conjugI'[of "r \<^sup>@ k" "u \<^sup>@ b \ r \<^sup>@ k'"]] rassoc] + show "\ primitive (u \<^sup>@ b \ r \<^sup>@ (k' + k))" + unfolding add_exps[symmetric] by force qed -qed +qed (use assms in force)+ section \Parametric solution of the equation @{term "x\<^sup>@j\y\<^sup>@k = z\<^sup>@l"}\ subsection \Auxiliary lemmas\ -lemma xjy_imprim: assumes "x \ y \ y \ x" and eq: "x\<^sup>@j \ y = z\<^sup>@l" and "2 \ j" and "2 \ l" +lemma xjy_imprim_len: assumes "x \ y \ y \ x" and eq: "x\<^sup>@j \ y = z\<^sup>@l" and "2 \ j" and "2 \ 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 \2 \ j\ using at_least2_Suc by metis - have "j \ 0" - using \2 \ j\ by force+ - from LS_per_lemma_case[of _ _ _ 1, unfolded pow_one', OF eq this] + define j' where "j' \ j - 2" + have "0 < j" "j = Suc(Suc j')" + unfolding j'_def using \2 \ j\ by force+ + from LS_per_lemma_case[of _ _ _ 1, unfolded pow_1, OF eq \0 < j\] show "\<^bold>|x\<^sup>@j\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|x\<^bold>|" using \x \ y \ y \ x\ 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 \2 \ l\, unfolded mult_2, of "\<^bold>|z\<^bold>|"] by linarith with \\<^bold>|x\<^sup>@j\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|x\<^bold>|\ show "\<^bold>|x\<^sup>@j\<^bold>| < \<^bold>|y\<^bold>| + 2*\<^bold>|x\<^bold>|" and "\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|" unfolding \j = Suc (Suc j')\ pow_Suc lenmorph mult_2 by linarith+ qed +lemma case_j1k1: assumes + eq: "x\y = z\<^sup>@l" and + non_comm: "x \ y \ y \ x" and + l_min: "2 \ l" + obtains r q m n where + "x = (r\q)\<^sup>@m\r" and + "y = q\ (r \ q)\<^sup>@n" and + "z = r\q" and + "l = m + n + 1" and "r\q \ q\r" and "\<^bold>|x\<^bold>| + \<^bold>|y\<^bold>| \ 4" +proof- + have "0 < l" "y \ \" + using l_min non_comm by force+ + from split_pow[OF eq this] + obtain r q m n where + x: "x = (r \ q) \<^sup>@ m \ r" and + y: "y = (q \ r)\<^sup>@ n \ q" and + z: "z = r \ q" and + l: "l = m + n + 1". + from non_comm[unfolded x y] + have "r \ q \ q \ r" + unfolding shifts + unfolding lassoc add_exps[symmetric] pow_Suc[symmetric] add.commute[of m] + by force + hence "r \ \" and "q \ \" + by blast+ + have "2 \ \<^bold>|r \ q\<^bold>|" + using nemp_pos_len[OF \r \ \\] nemp_pos_len[OF \q \ \\] + unfolding lenmorph by linarith + have "\<^bold>|x\<^bold>| + \<^bold>|y\<^bold>| \ 4" + unfolding x y lenmorph[symmetric] shifts + unfolding add_exps[symmetric] lassoc lenmorph[of "r \ q"] + mult_Suc[symmetric] pow_len Suc_eq_plus1 l[symmetric] + using mult_le_mono[OF \2 \ l\ \2 \ \<^bold>|r \ q\<^bold>|\] + by presburger + from that[OF x y[unfolded shift_pow] z l \r \ q \ q \ r\ this] + show thesis. +qed + + + + subsection \@{term x} is longer\ +text\We set up a locale representing the Lyndon-Schützenberger Equation + with relaxed exponents and a length assumption breaking the symmetry.\ + locale LS_len_le = binary_code x y for x y + fixes j k l z - assumes - y_le_x: "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" + assumes + y_le_x: "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" and eq: "x\<^sup>@j \ y\<^sup>@k = z\<^sup>@l" and l_min: "2 \ l" and j_min: "1 \ j" and k_min: "1 \ 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 j_min] le_neq_implies_less[OF k_min] non_comm unfolding One_less_Two_le_iff by blast -subsubsection \case @{term "j = 2"}\ +subsubsection \case @{term "2 \ j"}\ lemma case_j2k1: assumes "2 \ j" "k = 1" obtains r q t where - "(r \ q) \<^sup>@ (Suc (Suc t)) \ r = x" and + "(r \ q) \<^sup>@ t \ r = x" and "q \ r \ r \ q = y" and - "(r \ q) \<^sup>@ (Suc (Suc t)) \ r \ r \ q = z" and + "(r \ q) \<^sup>@ t \ r \ r \ q = z" and "2 \ t" "j = 2" and "l = 2" and "r\q \ q\r" and "primitive x" and "primitive y" proof- - note eq' = eq[unfolded \k = 1\ pow_one'] - note xjy_imprim[OF non_comm eq[unfolded \k = 1\ pow_one'] \2 \ j\ l_min] + note eq' = eq[unfolded \k = 1\ pow_1] + note xjy_imprim_len[OF non_comm eq[unfolded \k = 1\ pow_1] \2 \ j\ l_min] obtain j' where "j = Suc (Suc j')" using \2 \ j\ using at_least2_Suc by metis - hence "j \ 0" by blast + hence "0 < j" by blast from lenarg[OF eq', unfolded lenmorph, unfolded pow_len] add_less_mono1[OF \\<^bold>|x\<^sup>@j\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|x\<^bold>|\, of "\<^bold>|y\<^bold>|", unfolded pow_len] have "l*\<^bold>|z\<^bold>| < 3*\<^bold>|z\<^bold>|" using \\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|\ y_le_x by linarith hence "l = 2" using l_min by simp from \\<^bold>|x \<^sup>@ j\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|x\<^bold>|\ add_less_mono1[OF \\<^bold>|z\<^bold>| < \<^bold>|x\<^bold>| + \<^bold>|y\<^bold>|\, of "\<^bold>|x\<^bold>|"] y_le_x have "j' * \<^bold>|x\<^bold>| < \<^bold>|x\<^bold>|" unfolding \j = Suc (Suc j')\ pow_Suc lenmorph pow_len by linarith hence "j = 2" using \j = Suc (Suc j')\ by simp - note eq[ unfolded \k = 1\ pow_one' \j = 2\ \l = 2\ pow_two rassoc] + note eq[ unfolded \k = 1\ pow_1 \j = 2\ \l = 2\ pow_two rassoc] from eqd[OF this less_imp_le[OF \\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|\]] obtain p where "x \ p = z" and "p \ z = x \ y" by blast from eqd[OF \p \ z = x \ y\[folded \x \ p = z\, unfolded lassoc, symmetric]] obtain s where "x \ s = p \ x" and "s \ p = y" by auto have "p \ \" using \x \ p = z\ \\<^bold>|x\<^bold>| < \<^bold>|z\<^bold>|\ by fastforce have "s \ \" - using \p \ \\ \x \ s = p \ x\ by force + using \p \ \\ \x \ s = p \ x\ by force from conjug_eqE[OF \x \ s = p \ x\[symmetric] \p \ \\] - obtain r q t' where "r \ q = p" and "q \ r = s" and "(r \ q)\<^sup>@t'\r = x" and "q \ \". + obtain r q t where "r \ q = p" and "q \ r = s" and "(r \ q)\<^sup>@t\r = x" and "q \ \". note \s \ p = y\[folded \q \ r = s\ \r \ q = p\, unfolded rassoc] - from y_le_x[folded this \(r \ q)\<^sup>@t'\r = x\, unfolded lenmorph pow_len] nemp_len[OF \q \ \\] - 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 \ t'" + from y_le_x[folded this \(r \ q)\<^sup>@t\r = x\, unfolded lenmorph pow_len] nemp_len[OF \q \ \\] + 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 \ t" by linarith - then obtain t where "t' = Suc (Suc t)" - using at_least2_Suc by blast - from \p \ z = x \ y\[folded \q \ r \ r \ q = y\ \(r \ q)\<^sup>@t'\r = x\ \r \ q = p\, unfolded \t' = Suc (Suc t)\ pow_Suc rassoc cancel, symmetric] - have z: "(r \ q) \<^sup>@ Suc (Suc t) \ r \ r \ q = z" - unfolding pow_Suc2[of _ "Suc t"] unfolding pow_Suc rassoc. + from \p \ z = x \ y\[folded \q \ r \ r \ q = y\ \(r \ q)\<^sup>@t\r = x\ \r \ q = p\, symmetric] + have z: "(r \ q) \<^sup>@ t \ r \ r \ q = z" + by comparison \ \y is primitive due to the Lyndon-Schutzenberger\ - from comm_drop_exp[OF \j \ 0\, of y x j, unfolded eq'] + from comm_drop_exp[OF \0 < j\, of y x j, unfolded eq'] have "primitive y" using Lyndon_Schutzenberger_prim[OF pow_nemp_imprim[OF \2 \j\], of y x, unfolded eq', OF _ pow_nemp_imprim[OF l_min]] non_comm by argo hence "q \ r \ r \ q" using \p \ \\ \q \ r = s\ \r \ q = p\ \s \ p = y\ comm_not_prim[OF \s \ \\ \p \ \\] by argo \ \primitivity of x using @{thm per_le_prim_iff}\ thm per_le_prim_iff[of x p] have "x \p p \ x" - unfolding \(r \ q)\<^sup>@t'\r = x\[symmetric] \r \ q = p\[symmetric] + unfolding \(r \ q)\<^sup>@t\r = x\[symmetric] \r \ q = p\[symmetric] by comparison have "2*\<^bold>|p\<^bold>| \ \<^bold>|x\<^bold>|" - unfolding \(r \ q)\<^sup>@t'\r = x\[symmetric] \r \ q = p\[symmetric] lenmorph pow_len - using mult_le_mono1[OF \2 \ t'\, of "(\<^bold>|r\<^bold>| + \<^bold>|q\<^bold>|)"] by linarith + unfolding \(r \ q)\<^sup>@t\r = x\[symmetric] \r \ q = p\[symmetric] lenmorph pow_len + using mult_le_mono1[OF \2 \ t\, of "(\<^bold>|r\<^bold>| + \<^bold>|q\<^bold>|)"] by linarith have [symmetric]: "p \ x \ x \ p" - unfolding \(r \ q)\<^sup>@t'\r = x\[symmetric] \r \ q = p\[symmetric] lassoc pow_comm[symmetric] + unfolding \(r \ q)\<^sup>@t\r = x\[symmetric] \r \ q = p\[symmetric] lassoc pow_comm[symmetric] unfolding rassoc cancel by fact - with per_le_prim_iff[OF \x \p p \ x\ \p \ \\ \ 2 * \<^bold>|p\<^bold>| \ \<^bold>|x\<^bold>|\] - have "primitive x" + with per_le_prim_iff[OF \x \p p \ x\ \p \ \\ \ 2 * \<^bold>|p\<^bold>| \ \<^bold>|x\<^bold>|\] + have "primitive x" by blast - from that[OF \(r \ q)\<^sup>@t'\r = x\[unfolded \t' = Suc (Suc t)\] \q \ r \ r \ q = y\ z \j = 2\ \l = 2\ \q\r \ r\q\[symmetric] - \primitive x\ \primitive y\] + from that[OF \(r \ q)\<^sup>@t\r = x\ \q \ r \ r \ q = y\ z \2 \ t\ + \j = 2\ \l = 2\ \q\r \ r\q\[symmetric] \primitive x\ \primitive y\] show thesis. -qed +qed subsubsection \case @{term "j = 1"}\ lemma case_j1k2_primitive: assumes "j = 1" "2 \ k" shows "primitive x" using Lyndon_Schutzenberger_prim[OF _ pow_nemp_imprim pow_nemp_imprim[OF l_min, of z, folded eq], OF _ \2 \ k\] comm_pow_roots[of j k x y] k_min non_comm - unfolding \j = 1\ pow_one' + unfolding \j = 1\ pow_1 by linarith lemma case_j1k2_a: assumes "j = 1" "2 \ k" "z \s y\<^sup>@k" obtains r q t where - "x = ((q \ r) \ (r \ (q \ r) \<^sup>@ Suc t) \<^sup>@ (k - 1)) \<^sup>@ (l - 2) \ - (((q \ r) \ (r \ (q \ r) \<^sup>@ Suc t) \<^sup>@ (k - 2)) \ r) \ q" and - "y = r \ (q \ r) \<^sup>@ Suc t" and - "z = (q \ r) \ (r \ (q \ r) \<^sup>@ Suc t) \<^sup>@ (k - 1)" and "r\q \ q\r" + "x = ((q \ r) \ (r \ (q \ r) \<^sup>@ t) \<^sup>@ (k - 1)) \<^sup>@ (l - 2) \ + (((q \ r) \ (r \ (q \ r) \<^sup>@ t) \<^sup>@ (k - 2)) \ r) \ q" and + "y = r \ (q \ r) \<^sup>@ t" and + "z = (q \ r) \ (r \ (q \ r) \<^sup>@ t) \<^sup>@ (k - 1)" and \0 < t\ and "r\q \ q\r" proof- have "z \ \" using assms(1) bin_fst_nemp eq by force - have "k \ 0" "k - 1 \ 0" + have "0 < k" "0 < k -1" using \2 \ k\ by linarith+ - have "l \ 0" "l - 1 \ 0" + have "0 < l" "0 < l - 1" using l_min by linarith+ - from LS_per_lemma_case[reversed, OF eq \k \ 0\, unfolded \j = 1\] + from LS_per_lemma_case[reversed, OF eq \0 < k\, unfolded \j = 1\] 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\z" using \z \s y\<^sup>@k\ suffix_def by blast have "\<^bold>|v\<^bold>| < \<^bold>|y\<^bold>|" using perlem[unfolded lenarg[OF \y\<^sup>@k = v\z\] lenmorph] by simp have "v

y\<^sup>@k = v\z\[symmetric]] - unfolding pop_pow_one[OF \k \ 0\] + unfolding pow_pos[OF \0 < k\] using pref_prod_less[OF _ \\<^bold>|v\<^bold>| < \<^bold>|y\<^bold>|\] by blast obtain u where "v\u = y" "u \ \" - using \v

unfolding strict_suffix_def suffix_def - by blast + using \v

spref_exE by blast have "z = u\y\<^sup>@(k-1)" - using \y\<^sup>@k = v\z\[unfolded pop_pow_one[OF \k \ 0\], + using \y\<^sup>@k = v\z\[unfolded pow_pos[OF \0 < k\], folded \v \ u = y\, unfolded rassoc cancel, unfolded \v \ u = y\, symmetric]. - note eq[unfolded pop_pow_one'[OF \l \ 0\] \y\<^sup>@k = v\z\ lassoc cancel_right - \j = 1\ pow_one'] + note eq[unfolded pow_pos'[OF \0 < l\] \y\<^sup>@k = v\z\ lassoc cancel_right + \j = 1\ pow_1] obtain u' where "u'\v = y" proof- have "v \s z\<^sup>@(l-1)" using \x \ v = z \<^sup>@ (l - 1)\ by blast moreover have "y \s z\<^sup>@(l-1)" - unfolding \z = u\y\<^sup>@(k-1)\ pop_pow_one'[OF \k - 1 \ 0\] - pop_pow_one'[OF \l - 1 \ 0\] lassoc + unfolding \z = u\y\<^sup>@(k-1)\ pow_pos'[OF \0 < k - 1\] + pow_pos'[OF \0 < l - 1\] lassoc by blast ultimately have "v \s y" using order_less_imp_le[OF \\<^bold>|v\<^bold>| < \<^bold>|y\<^bold>|\] suffix_length_suffix by blast thus thesis using sufD that by blast qed hence "u' \ \" using \v

by force from conjugation[OF \u'\v = y\[folded \v\u = y\] \u' \ \\] obtain r q t where "r \ q = u'" "q \ r = u" "(r \ q) \<^sup>@ t \ r = v" by blast have y: "y = r \ (q \ r) \<^sup>@ Suc t" using \u' \ v = y\[symmetric, folded \(r \ q) \<^sup>@ t \ r = v\ \r \ q = u'\] - unfolding rassoc pow_slide[symmetric]. + unfolding rassoc pow_slide[symmetric]. have z: "z = (q \ r) \ (r \ (q \ r) \<^sup>@ Suc t) \<^sup>@ (k - 1)" using \q \ r = u\ \z = u \ y \<^sup>@ (k - 1)\ y by blast - from \x \ v = z \<^sup>@ (l - 1)\[folded z[symmetric] \(r \ q) \<^sup>@ t \ r = v\, - unfolded pop_pow_one'[OF \k - 1 \ 0\] pop_pow_one'[OF \l - 1 \ 0\]] - have x: "x = ((q \ r) \ (r \ (q \ r) \<^sup>@ Suc t) \<^sup>@ (k - 1)) \<^sup>@ (l - 2) \ + let ?x = "((q \ r) \ (r \ (q \ r) \<^sup>@ Suc t) \<^sup>@ (k - 1)) \<^sup>@ (l - 2) \ (((q \ r) \ (r \ (q \ r) \<^sup>@ Suc t) \<^sup>@ (k - 2)) \ r) \ q" - unfolding pop_pow_one[OF Suc_not_Zero] diff_Suc_1 shift_pow - unfolding lassoc cancel_right - unfolding rassoc pop_pow_one'[OF \k - 1 \ 0\] - unfolding diff_Suc_eq_diff_pred[symmetric] Suc_1. - - (* ALT approach *) - (* let ?x = "((q \ r) \ (r \ (q \ r) \<^sup>@ Suc t) \<^sup>@ (k - 1)) \<^sup>@ (l - 2) \ *) - (* (((q \ r) \ (r \ (q \ r) \<^sup>@ Suc t) \<^sup>@ (k - 2)) \ r) \ q" *) - (* have "?x \ v = z \<^sup>@ (l - 1)" *) - (* unfolding z \(r \ q) \<^sup>@ t \ r = v\[symmetric] pop_pow_one'[OF \k - 1 \ 0\] *) - (* pop_pow_one'[OF \l - 1 \ 0\] diff_diff_left nat_1_add_1 *) - (* by (simp only: shifts) *) - (* from \x \ v = z \<^sup>@ (l - 1)\[folded this] *) - (* have "x = ?x" *) - (* by blast *) - + have "?x \ v = z \<^sup>@ (l - 1)" + unfolding z \(r \ q) \<^sup>@ t \ r = v\[symmetric] pow_pos'[OF \0 < k - 1\] + pow_pos'[OF \0 < l - 1\] diff_diff_left nat_1_add_1 + by (simp only: shifts) + from \x \ v = z \<^sup>@ (l - 1)\[folded this] + have x: "x = ?x" + by blast have "z\y \ y\z" using non_comm - using power_commuting_commutes[of z y l, folded eq, + using comm_add_exp[of z y l, folded eq, unfolded rassoc pow_comm, unfolded lassoc cancel_right - \j = 1\ pow_one'] + \j = 1\ pow_1] by blast hence "r\q \ q\r" unfolding \q \ r = u\ \r \ q = u'\ \u'\ v = y\[symmetric] - \z = u \ y \<^sup>@ (k - 1)\ pop_pow_one'[OF \k \ 0\] rassoc + \z = u \ y \<^sup>@ (k - 1)\ pow_pos'[OF \0 < k\] rassoc \y \<^sup>@ k = v \ z\[unfolded \u' \ v = y\[symmetric] \z = u \ y \<^sup>@ (k - 1)\, symmetric] cancel_right.. - show thesis - using that[OF x y z \r\q \ q\r\]. + using that[OF x y z _ \r\q \ q\r\] by blast qed lemma case_j1k2_b: assumes "j = 1" "2 \ k" "y\<^sup>@k y\<^sup>@k)\<^sup>@(l-1)\q" and - "z = q\y\<^sup>@k" and + "z = q\y\<^sup>@k" and "q\y \ y\q" proof- obtain q where "z = q\y\<^sup>@k" "q \ \" using ssufD[OF \y\<^sup>@k ] unfolding suffix_def by blast - have "l \ 0" using l_min by linarith + have "0 < l" using l_min by linarith have "x = (q\y\<^sup>@k)\<^sup>@(l-1)\q" - using eq[unfolded pop_pow_one'[OF \l \ 0\] \j = 1\ pow_one', + using eq[unfolded pow_pos'[OF \0 < l\] \j = 1\ pow_1, unfolded \z = q\y\<^sup>@k\ lassoc cancel_right]. have "q\y \ y\q" - using + using comm_trans[OF _ _ \q \ \\, of y x] conjug_pow[of y q y k, symmetric] - conjug_pow[of "q \ y \<^sup>@ k" q "q \ y \<^sup>@ k" "l-1"] non_comm + conjug_pow[of "q \ y \<^sup>@ k" q "q \ y \<^sup>@ k" "l-1"] non_comm unfolding append_same_eq[symmetric, of \(q \ y \<^sup>@ k) \<^sup>@ (l - 1) \ q\ \q \ (q \ y \<^sup>@ k) \<^sup>@ (l - 1)\ q] unfolding \x = (q \ y \<^sup>@ k) \<^sup>@ (l - 1) \ q\ rassoc - by argo + by argo show ?thesis using \x = (q \ y \<^sup>@ k) \<^sup>@ (l - 1) \ q\ \z = q \ y \<^sup>@ k\ \q\y \ y\q\ that by blast qed -lemma case_j1k1: assumes "j = 1" "k = 1" - obtains r q m n where - "x = (r\q)\<^sup>@m\r" and - "y = q\(r\q)\<^sup>@n" and - "z = r\q" and - "Suc (m+n)=l" and "r\q \ q\r" -proof- - from eq[unfolded assms pow_one'] - have "x \ y = concat ([z] \<^sup>@ l)" - by (simp add: concat_pow) - hence "x

@ l)" - using bin_snd_nemp by blast - - from pref_mod_list[OF this] - obtain m r where "m < \<^bold>|[z] \<^sup>@ l\<^bold>|" "r

@ l) ! m" - "concat (take m ([z] \<^sup>@ l)) \ r = x". - - have "m < l" - using \m < \<^bold>|[z] \<^sup>@ l\<^bold>|\ - unfolding sing_pow_len. - - obtain n where "Suc (m + n) = l" - using less_imp_Suc_add[OF \m < l\] - by blast - - have "z\<^sup>@m\r = x" - using \concat (take m ([z] \<^sup>@ l)) \ r = x\ - unfolding concat_take_sing[OF less_or_eq_imp_le, OF disjI1, OF \m < l\]. - - have "r

m < \<^bold>|[z] \<^sup>@ l\<^bold>|\ \r

@ l) ! m\ sing_pow_len sing_pow_nth by metis - then obtain q where "z = r\q" "q \ \" - by blast - - have "z \<^sup>@ m\\<^sup>>z \<^sup>@ l = z\<^sup>@(l-m)" - using lq_triv - pop_pow[OF less_or_eq_imp_le[OF disjI1, OF \m < \<^bold>|[z] \<^sup>@ l\<^bold>|\], symmetric] - unfolding sing_pow_len - by auto - hence "z \<^sup>@ m\\<^sup>>z \<^sup>@ l = z\z\<^sup>@n" - unfolding pop_pow_one[OF zero_less_diff'[OF \m < l\]] - using \Suc (m + n) = l\ by force - have "y = q\(r\q)\<^sup>@n" - using lqI[OF \x \ y = z \<^sup>@ l\[folded \z\<^sup>@m\r = x\, unfolded rassoc], symmetric] - unfolding \z \<^sup>@ m\\<^sup>>z \<^sup>@ l = z\z\<^sup>@n\ - unfolding \z = r\q\ rassoc cancel. - - have "x\z \ z\x" - using conjug_pow[of z x z l, folded \x \ y = z \<^sup>@ l\, - unfolded rassoc cancel, OF sym, symmetric] - non_comm by blast - hence "r\q \ q\r" - unfolding \z \<^sup>@ m \ r = x\[symmetric] \z = r \ q\ - unfolding lassoc power_commutes[of "r\q" m, symmetric] - unfolding rassoc cancel. - - show ?thesis - using that[OF \z\<^sup>@m\r = x\[unfolded \z = r\q\, symmetric] - \y = q\(r\q)\<^sup>@n\ \z = r\q\ \Suc (m+n) = l\ \r\q \ q\r\]. -qed - subsection \Putting things together\ -lemma solution_cases: obtains +lemma solution_cases: obtains "j = 2" "k = 1" | "j = 1" "2 \ k" "z @k" | "j = 1" "2 \ k" "y\<^sup>@k 0" "l-1 \ 0" + have "0 < l" "0 < l-1" using l_min by linarith+ - have "k \ 0" + have "0 < k" using k_min by linarith - have "j \ 0" + have "0 < j" using j_min by linarith have "z \ \" - using eq nemp_pow_nemp[of z l] bin_fst_nemp[folded nonzero_pow_emp[OF \j \ 0\, of x], THEN pref_nemp] - by force + using eq nemp_pow_nemp[of z l] bin_fst_nemp[folded nonzero_pow_emp[OF \0 < j\, of x], THEN pref_nemp] + by force have "z \ y\<^sup>@k" - proof + proof assume "z = y\<^sup>@k" - with eq[unfolded pop_pow_one'[OF \l\0\], folded this, unfolded cancel_right] + with eq[unfolded pow_pos'[OF \0 < l\], folded this, unfolded cancel_right] have "x\<^sup>@j \ y\<^sup>@k = y\<^sup>@k \ x\<^sup>@j" using pow_comm by auto - with comm_drop_exps[of x "j-1" y "k - 1", unfolded Suc_minus[OF \j \ 0\] Suc_minus[OF \k \ 0\]] + from comm_drop_exps[OF this \0 < j\ \0 < k\] show False using non_comm by blast qed consider "2 \ j" "k = 1" | "j = 1" "2 \ 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 @k" | "y\<^sup>@k @k" "x\<^sup>@j", unfolded eq, THEN suf_prod_root, - THEN ruler_pref'[reversed]] \z \ y\<^sup>@k\ + using suffix_order.less_le + triv_suf[of "y\<^sup>@k" "x\<^sup>@j", unfolded eq, THEN suf_prod_root, + THEN ruler_suf'] \z \ y\<^sup>@k\ 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 +theorem parametric_solutionE: obtains \\case @{term "x\y"}\ r q m n where "x = (r\q)\<^sup>@m\r" and "y = q\(r\q)\<^sup>@n" and "z = r\q" and - "Suc (m+n) = l" and "r\q \ q\r" + "l = m + n + 1" and "r\q \ q\r" | \\case @{term "x\y\<^sup>@k"} with @{term "2 \ k"} and @{term "z @k"}\ r q t where - "x = ((q \ r) \ (r \ (q \ r) \<^sup>@ Suc t) \<^sup>@ (k - 1)) \<^sup>@ (l - 2) \ - (((q \ r) \ (r \ (q \ r) \<^sup>@ Suc t) \<^sup>@ (k - 2)) \ r) \ q" and - "y = r \ (q \ r) \<^sup>@ Suc t" and - "z = (q \ r) \ (r \ (q \ r) \<^sup>@ Suc t) \<^sup>@ (k - 1)" and - "r\q \ q\r" + "x = ((q \ r) \ (r \ (q \ r) \<^sup>@ t) \<^sup>@ (k - 1)) \<^sup>@ (l - 2) \ + (((q \ r) \ (r \ (q \ r) \<^sup>@ t) \<^sup>@ (k - 2)) \ r) \ q" and + "y = r \ (q \ r) \<^sup>@ t" and + "z = (q \ r) \ (r \ (q \ r) \<^sup>@ t) \<^sup>@ (k - 1)" and + "0 < t" and "r\q \ q\r" | \\case @{term "x\y\<^sup>@k"} with @{term "2 \ k"} and @{term "y\<^sup>@k - q where + q where "x = (q\y\<^sup>@k)\<^sup>@(l-1)\q" and - "z = q\y\<^sup>@k" and + "z = q\y\<^sup>@k" and "q\y \ y\q" | \\case @{term "x\<^sup>@j\y"} with @{term "2 \ j"}\ r q t where - "x = (r \ q) \<^sup>@ (Suc (Suc t)) \ r" and + "x = (r \ q) \<^sup>@ t \ r" and "y = q \ r \ r \ q" and - "z = (r \ q) \<^sup>@ (Suc (Suc t)) \ r \ r \ q" and - "j = 2" and "l = 2" and "r\q \ q\r" and + "z = (r \ q) \<^sup>@ t \ r \ r \ q" and + "j = 2" and "l = 2" and "2 \ t" and "r\q \ q\r" and "primitive x" and "primitive y" proof- show ?thesis using solution_cases proof(cases) case 1 from case_j2k1[OF _ \k = 1\, of thesis] \j = 2\ show ?thesis using that(4) by blast next case 2 - from case_j1k2_a[OF \j = 1\ \2 \ k\, of thesis] - show ?thesis - using that(2) \z @ k\ unfolding strict_suffix_def + from case_j1k2_a[OF this(1-2) ssufD1[OF this(3)], of thesis] + show thesis + using that(2) 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 + from case_j1k1[OF eq[unfolded \k = 1\ \j = 1\ pow_1] non_comm l_min, of thesis] + show thesis + using that(1). qed qed -end (* end locale *) - +end text \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 $$ \ theorem LS_parametric_solution: assumes y_le_x: "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" and j_min: "1 \ j" and k_min: "1 \ k" and l_min: "2 \ l" - shows + shows "x\<^sup>@j \ y\<^sup>@k = z\<^sup>@l - \ ( - (\r m n t. - x = r\<^sup>@m \ y = r\<^sup>@n \ z = r\<^sup>@t \ m*j+n*k=t*l) \\{x,y} is not a code\ - \ ((j = 1 \ k = 1) \ - (\r q m n. - x = (r\q)\<^sup>@m\r \ y = q\(r\q)\<^sup>@n \ z = r\q \ Suc(m+n) = l \ r\q \ q\r)) - \ ((j = 1 \ 2 \ k) \ - (\r q t. - x = ((q \ r) \ (r \ (q \ r) \<^sup>@ Suc t) \<^sup>@ (k - 1)) \<^sup>@ (l - 2)\(((q \ r) \ - (r \ (q \ r) \<^sup>@ Suc t) \<^sup>@ (k - 2)) \ r) \ q - \ y = r \ (q \ r) \<^sup>@ Suc t - \ z = (q \ r) \ (r \ (q \ r) \<^sup>@ Suc t) \<^sup>@ (k - 1) - \ r\q \ q\r)) - \ ((j = 1 \ 2 \ k) \ - (\r q. - x = (q\r\<^sup>@k)\<^sup>@(l-1)\q \ y = r \ z = q\r\<^sup>@k \ r\q \ q\r)) - \ ((j = 2 \ k = 1 \ l = 2) \ - (\r q t. - x = (r \ q) \<^sup>@ (Suc (Suc t)) \ r \ y = q \ r \ r \ q - \ z = (r \ q) \<^sup>@ (Suc (Suc t)) \ r \ r \ q \ r\q \ q\r )) - ) + \ + (\r m n t. + x = r\<^sup>@m \ y = r\<^sup>@n \ z = r\<^sup>@t \ m*j+n*k=t*l) \\Case A: {x,y} is not a code\ + \ (j = 1 \ k = 1) \ + (\r q m n. + x = (r\q)\<^sup>@m\r \ y = q\(r\q)\<^sup>@n \ z = r\q \ m + n + 1 = l \ r\q \ q\r) \ \Case B\ + \ (j = 1 \ 2 \ k) \ + (\r q. + x = (q\r\<^sup>@k)\<^sup>@(l-1)\q \ y = r \ z = q\r\<^sup>@k \ r\q \ q\r) \ \Case C\ + \ (j = 1 \ 2 \ k) \ + (\r q t. 0 < t \ + x = ((q \ r) \ (r \ (q \ r) \<^sup>@ t) \<^sup>@ (k - 1)) \<^sup>@ (l - 2)\(((q \ r) \ + (r \ (q \ r) \<^sup>@ t) \<^sup>@ (k - 2)) \ r) \ q + \ y = r \ (q \ r) \<^sup>@ t + \ z = (q \ r) \ (r \ (q \ r) \<^sup>@ t) \<^sup>@ (k - 1) + \ r\q \ q\r) \ \Case D\ + \ (j = 2 \ k = 1 \ l = 2) \ + (\r q t. 2 \ t \ + x = (r \ q) \<^sup>@ t \ r \ y = q \ r \ r \ q + \ z = (r \ q) \<^sup>@ t \ r \ r \ q \ r\q \ q\r ) \ \Case E\ " (is "?eq = (?sol_per \ (?cond_j1k1 \ ?sol_j1k1) \ + (?cond_j1k2 \ ?sol_j1k2_b) \ (?cond_j1k2 \ ?sol_j1k2_a) \ - (?cond_j1k2 \ ?sol_j1k2_b) \ (?cond_j2k1l2 \ ?sol_j2k1l2))") proof(rule iffI) assume eq: "x \<^sup>@ j \ y \<^sup>@ k = z \<^sup>@ l" - show + show "(?sol_per \ (?cond_j1k1 \ ?sol_j1k1) \ + (?cond_j1k2 \ ?sol_j1k2_b) \ (?cond_j1k2 \ ?sol_j1k2_a) \ - (?cond_j1k2 \ ?sol_j1k2_b) \ (?cond_j2k1l2 \ ?sol_j2k1l2))" proof(cases) assume "x\y = y\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 \primitive r\]] by auto from eqs[unfolded this, folded pow_mult, symmetric] have "m * j + n * k = t * l" unfolding prim_nemp[OF \primitive r\, THEN eq_pow_exp]. - hence ?sol_per + hence ?sol_per using \x = r \<^sup>@ m\ \y = r \<^sup>@ n\ \z = r \<^sup>@ t\ by blast - thus ?thesis + thus ?thesis by blast next assume "x\y \ y\x" interpret LS_len_le x y j k l z using \x \<^sup>@ j \ y \<^sup>@ k = z \<^sup>@ l\ \x\y \ y\x\ 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] \k = 1\, OF disjI2, OF \j = 2\[symmetric], of "?sol_j2k1l2 \ l = 2"] have "?sol_j2k1l2" and "l = 2" - by blast+ + by auto thus ?thesis using \k = 1\ \j = 2\ by blast next case 2 have "?sol_j1k2_a" - using case_j1k2_a[OF \j = 1\ \2 \ k\ ssufD1[OF \z @ k\], of ?sol_j1k2_a] + using case_j1k2_a[OF \j = 1\ \2 \ k\ ssufD1[OF \z @ k\], of ?sol_j1k2_a] + unfolding Suc_eq_plus1 by blast thus ?thesis using \j = 1\ \2 \ k\ by blast next case 3 - with case_j1k2_b[OF this, of "?sol_j1k2_b"] - have "?sol_j1k2_b" by auto - thus ?thesis + with case_j1k2_b[OF this, of "?sol_j1k2_b"] + have "?sol_j1k2_b" by auto + thus ?thesis using \j = 1\ \2 \ k\ by blast next case 4 - with case_j1k1[OF this, of ?sol_j1k1] + with case_j1k1[OF eq[unfolded \k = 1\ \j = 1\ pow_1] non_comm l_min, of ?sol_j1k1] have"?sol_j1k1" - by blast + unfolding Suc_eq_plus1 shift_pow + by blast thus ?thesis using \j = 1\ \k = 1\ by blast qed qed next have "l \ 0" "l - 1 \ 0" using l_min by auto have "k \ 0" using k_min by auto have "j \ 0" using j_min by auto assume "(?sol_per \ (?cond_j1k1 \ ?sol_j1k1) \ + (?cond_j1k2 \ ?sol_j1k2_b) \ (?cond_j1k2 \ ?sol_j1k2_a) \ - (?cond_j1k2 \ ?sol_j1k2_b) \ (?cond_j2k1l2 \ ?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" + 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 pow_mult[symmetric] add_exps[symmetric] unfolding \m * j + n * k = t * l\.. next fix r q m n assume "j = 1" "k = 1" and sol: "x = (r\q)\<^sup>@m\r" "y = q\(r\q)\<^sup>@n" "z = r\q" - and "Suc(m+n) = l" + and "m + n + 1 = l" + hence "Suc (m+n) = l" + by simp show ?thesis unfolding sol - unfolding \j = 1\ \k = 1\ \Suc(m+n) = l\[symmetric] pow_one' + unfolding \j = 1\ \k = 1\ \Suc (m + n) = l\[symmetric] pow_1 unfolding lassoc pow_Suc add_exps - unfolding power_commutes[of _ m, symmetric] lassoc.. + unfolding pow_comm[of _ m, symmetric] lassoc.. + next + fix r q + assume "j = 1" "2 \ k" and sol: "x = (q \ r \<^sup>@ k) \<^sup>@ (l - 1) \ q" "y = r" "z = q \ r \<^sup>@ k" + have "0 < l" + using \2 \ l\ by force + show ?thesis + unfolding sol \j = 1\ pow_1 + unfolding pow_pos'[OF \0 < l\] rassoc.. next fix r q t assume "j = 1" "2 \ k" and sol: "x = - ((q \ r) \ (r \ (q \ r) \<^sup>@ Suc t) \<^sup>@ (k - 1)) \<^sup>@ (l - 2) \ - (((q \ r) \ (r \ (q \ r) \<^sup>@ Suc t) \<^sup>@ (k - 2)) \ r) \ q" - "y = r \ (q \ r) \<^sup>@ Suc t" - "z = (q \ r) \ (r \ (q \ r) \<^sup>@ Suc t) \<^sup>@ (k - 1)" + ((q \ r) \ (r \ (q \ r) \<^sup>@ t) \<^sup>@ (k - 1)) \<^sup>@ (l - 2) \ + (((q \ r) \ (r \ (q \ r) \<^sup>@ t) \<^sup>@ (k - 2)) \ r) \ q" + "y = r \ (q \ r) \<^sup>@ t" + "z = (q \ r) \ (r \ (q \ r) \<^sup>@ t) \<^sup>@ (k - 1)" + "0 < t" obtain k' where "Suc (Suc k') = k" using Suc_minus2[OF \2 \ k\] 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 \2 \ l\] 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 \2 \ l\] by blast hence l2: "l - 2 = l'" and l: "l = l' + 2" by fastforce+ show "x \<^sup>@ j \ y \<^sup>@ k = z \<^sup>@ l" unfolding sol \j = 1\ k1 k2 l2 unfolding k l by comparison next - fix r q - assume "j = 1" "2 \ k" and sol: "x = (q \ r \<^sup>@ k) \<^sup>@ (l - 1) \ q" "y = r" "z = q \ r \<^sup>@ k" - show ?thesis - unfolding sol \j = 1\ pow_one' - unfolding pop_pow_one'[OF \l \ 0\] rassoc.. - next fix r q t assume "j = 2" "k = 1" "l = 2" and sol: - "x = (r \ q) \<^sup>@ Suc (Suc t) \ r" - "y = q \ r \ r \ q" "z = (r \ q) \<^sup>@ Suc (Suc t) \ r \ r \ q" + "x = (r \ q) \<^sup>@ t \ r" + "y = q \ r \ r \ q" "z = (r \ q) \<^sup>@ t \ r \ r \ q" + "2 \ t" show "x \<^sup>@ j \ y \<^sup>@ k = z \<^sup>@ l" - unfolding \j = 2\ \k = 1\ \l = 2\ sol pow_one' pow_two + unfolding \j = 2\ \k = 1\ \l = 2\ sol pow_1 pow_two by comparison qed qed subsection \Uniqueness of the imprimitivity witness\ text\In this section, we show that given a binary code @{term "{x,y}"} and two imprimitive words @{term "x\<^sup>@j\y\<^sup>@k"} and @{term "x\<^sup>@j'\y\<^sup>@k'"} is possible only if the two words are equals, that is, if @{term "j=j'"} and @{term "k=k'"}.\ lemma LS_unique_same: assumes "x \ y \ y \ x" - and "1 \ j" and "1 \ k" and "\ primitive(x\<^sup>@j\y\<^sup>@k)" + and "1 \ j" and "1 \ k" and "\ primitive(x\<^sup>@j\y\<^sup>@k)" and "1 \ k'" and "\ primitive(x\<^sup>@j\y\<^sup>@k')" shows "k = k'" proof(rule ccontr) assume "k \ 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 \ ka'" unfolding ka_def ka'_def using \k \ k'\ by auto then obtain dif where [symmetric]: "ka + dif = ka'" and "dif \ 0" using less_imp_add_positive by blast have "ka \ 0" and "ka' \ 0" and \j \ 0\ unfolding ka_def ka'_def using \1 \ k\ \1 \ k'\ \1 \ j\ by force+ have "\ primitive(x\<^sup>@j\y\<^sup>@ka)" "\ primitive(x\<^sup>@j\y\<^sup>@ka')" unfolding ka_def ka'_def using assms(4) assms(6) by presburger+ have "x\<^sup>@j\y\<^sup>@ka' = x\<^sup>@j\y\<^sup>@ka\y\<^sup>@dif" unfolding add_exps[symmetric] \ka' = ka + dif\.. consider "dif = 1" | "2 \ dif" using \ka < ka'\ \ka' = ka + dif\ by fastforce hence "x \ y = y \ x" proof(cases) assume "dif = 1" define u where "u = x\<^sup>@j\y\<^sup>@(ka - 1)" have "\ primitive (u \ y)" - unfolding u_def rassoc pow_Suc2[symmetric] Suc_minus[OF \ka \ 0\] by fact + unfolding u_def rassoc pow_Suc'[symmetric] Suc_minus[OF \ka \ 0\] by fact have "\ primitive (u \ y \ y)" - unfolding u_def rassoc using \\ primitive(x\<^sup>@j\y\<^sup>@ka')\[unfolded \x\<^sup>@j\y\<^sup>@ka' = x\<^sup>@j\y\<^sup>@ka\y\<^sup>@dif\ \dif = 1\ pow_one'] - unfolding pow_Suc2[of y "ka - 1", unfolded Suc_minus[OF \ka \ 0\]] rassoc. + unfolding u_def rassoc using \\ primitive(x\<^sup>@j\y\<^sup>@ka')\[unfolded \x\<^sup>@j\y\<^sup>@ka' = x\<^sup>@j\y\<^sup>@ka\y\<^sup>@dif\ \dif = 1\ pow_1] + unfolding pow_Suc'[of y "ka - 1", unfolded Suc_minus[OF \ka \ 0\]] rassoc. from imprim_ext_suf_comm[OF \\ primitive (u \ y)\ \\ primitive (u \ y \ y)\] have "(x \<^sup>@ j \ y \<^sup>@ (ka - 1)) \ y = y \ x \<^sup>@ j \ y \<^sup>@ (ka - 1)" unfolding u_def. thus "x \ y = y \ x" using \j \ 0\ by mismatch next assume "2 \ dif" hence "\ primitive (y\<^sup>@dif)".. from Lyndon_Schutzenberger_prim[OF \\ primitive (x \<^sup>@ j \ y \<^sup>@ ka)\ this \\ primitive (x \<^sup>@ j \ y \<^sup>@ ka')\[unfolded \x \<^sup>@ j \ y \<^sup>@ ka' = x \<^sup>@ j \ y \<^sup>@ ka\ y\<^sup>@dif\ lassoc]] show "x \ y = y \ x" using \dif \ 0\ \j \ 0\ by mismatch qed thus False using \x \ y \ y \ x\ by blast qed lemma LS_unique_distinct_le: assumes "x \ y \ y \ x" - and "2 \ j" and "\ primitive(x\<^sup>@j\y)" + and "2 \ j" and "\ primitive(x\<^sup>@j\y)" and "2 \ k" and "\ primitive(x\y\<^sup>@k)" and "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" shows False proof- - + have "0 < k" + using \2 \ k\ by linarith obtain l z where [symmetric]:"z\<^sup>@l = x\<^sup>@j\y" and "2 \ l" - using not_prim_pow[OF \\ primitive(x\<^sup>@j\y)\]. + using not_prim_primroot_expE[OF \\ primitive(x\<^sup>@j\y)\]. have "x\<^sup>@j\y\<^sup>@1 = z\<^sup>@l" by (simp add: \x \<^sup>@ j \ y = z \<^sup>@ l\) interpret eq1: LS_len_le x y j 1 l z using \x \ y \ y \ x\ \\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|\ \x\<^sup>@j\y\<^sup>@1 = z\<^sup>@l\ \2 \ l\ \2 \ j\ - by(unfold_locales, linarith+) + by(unfold_locales) linarith+ - from eq1.case_j2k1[OF \2 \ j\] + from eq1.case_j2k1[OF \2 \ j\ refl] obtain r q t where - xrq: "(r \ q) \<^sup>@ (Suc (Suc t)) \ r = x" and - yrq: "q \ r \ r \ q = y" and - "(r \ q) \<^sup>@ (Suc (Suc t)) \ r \ r \ q = z" and - "j = 2" and "l = 2" and "r\q \ q\r" and - "primitive x" and "primitive y" - by blast + x[symmetric]: "(r \ q) \<^sup>@ t \ r = x" and + y[symmetric]: "q \ r \ r \ q = y" and + z[symmetric]: "(r \ q) \<^sup>@ t \ r \ r \ q = z" and + "2 \ t" and "j = 2" and "l = 2" and "r\q \ q\r" and + "primitive x" and "primitive y". have "q\r \ \" "r\q \ \" - using eq1.bin_snd_nemp yrq by fastforce+ + using eq1.bin_snd_nemp y by fastforce+ obtain z' l' where "x\y\<^sup>@k = z'\<^sup>@l'" "2 \ l'" - using not_prim_pow[OF \\ primitive (x \ y \<^sup>@ k)\] by metis - have "l' \ 0" and "l' - 1 \ 0" + using not_prim_primroot_expE[OF \\ primitive (x \ y \<^sup>@ k)\] by metis + from \x\y\<^sup>@k = z'\<^sup>@l'\[unfolded x y, unfolded rassoc, symmetric] + have z': "z' \<^sup>@ l' = (r \ q) \<^sup>@ t \ r \ (q \ r \ r \ q) \<^sup>@ k". + have "0 < l'" and "0 < l' - 1" using \2 \ l'\ by auto - - have "k \ 0" - using \2 \ k\ by linarith - - let ?w = "(r \ q) \<^sup>@ (Suc (Suc t)) \ (r \ q) \ r" + have "r \ q \ r \ q \p x" + using pref_extD[of "r\q\r\q" "(r \ q) \<^sup>@ (t - 2) \ r"] + unfolding x[folded pop_pow[OF \2 \ t\], unfolded pow_two] rassoc by blast - have "(r \ q) \<^sup>@ (Suc (Suc t)) \ (r \ q) \ r \p ((r \ q) \ (r \ q) \<^sup>@ (Suc (Suc t))) \ (r \ q) \ r" - unfolding pow_comm[symmetric] rassoc pref_cancel_conv using triv_pref. - hence per1: "?w \p (r \ q) \ ?w" - unfolding rassoc. - - have "((r \ q) \<^sup>@ (Suc (Suc t)) \ r) \ q \ r \p z'\<^sup>@l'" - unfolding \x\y\<^sup>@k = z'\<^sup>@l'\[folded xrq yrq, unfolded rassoc, symmetric] - unfolding rassoc pop_pow_one[OF \k \ 0\] - by simp - hence per2: "?w \p z' \ ?w" - using pref_prod_root by auto - + have per1: "x \ q \ r \p (r \ q) \ x \ q \ r" + unfolding x by comparison + have per2: "x \ q \ r \p z' \ x \ q \ r" + by (rule pref_prod_root[of _ _ l'], + unfold \x\y\<^sup>@k = z'\<^sup>@l'\[unfolded y pow_pos[OF \0 < k\], symmetric]) + comparison have "(r \ q) \ z' \ z' \ (r \ q)" proof - have "k \ 0" - using \2 \ k\ by simp - have "y\<^sup>@k = y\<^sup>@Suc (k - 1)" - unfolding Suc_minus[OF \k \ 0\].. assume "(r \ q) \ z' = z' \ (r \ q)" hence "(r \ q) \ z'\<^sup>@l' = z'\<^sup>@l' \ r \ q" - by (simp add: power_commuting_commutes) - from this[folded \x\y\<^sup>@k = z'\<^sup>@l'\[unfolded \y\<^sup>@k = y\<^sup>@Suc (k - 1)\] xrq yrq] - have "q \ r = r \ q" - unfolding shifts by mismatch + by (simp add: comm_add_exp) + from this[unfolded z'] + have "r \ q = q \ r" + using \0 < k\ by mismatch thus False using \r \ q \ q \ r\ by presburger qed - with two_pers[OF _ per2, of "r\q"] per1 - have "\<^bold>|?w\<^bold>| < \<^bold>|r \ q\<^bold>| + \<^bold>|z'\<^bold>|" - unfolding rassoc using leI by blast - hence "\<^bold>|x\<^bold>| \ \<^bold>|z'\<^bold>|" - unfolding xrq[symmetric] - by simp - note eq2 = eqd[OF \x\y\<^sup>@k = z'\<^sup>@l'\[unfolded pop_pow_one[OF \l' \ 0\]] this, - folded xrq, unfolded pow_Suc pop_pow_one'[OF \l' - 1 \ 0\]] - hence "z' \s y\<^sup>@k" - unfolding lassoc by blast - have "r \ q \ r \ q \p z'" - using eq2 by force + with two_pers[OF per1 per2] + have "\<^bold>|x\<^bold>| \ \<^bold>|z'\<^bold>|" + unfolding lenmorph by linarith + + from eqdE[OF \x\y\<^sup>@k = z'\<^sup>@l'\[unfolded pow_pos[OF \0 < l'\] + pow_pos'[OF \0 < l'-1\]] \\<^bold>|x\<^bold>| \ \<^bold>|z'\<^bold>|\ ] + obtain w where "x \ w = z'" "w \ z' \<^sup>@ (l' - 1 - 1) \ z' = y \<^sup>@ k". + from this(1) this(2)[unfolded lassoc] + have "x \f y\<^sup>@k" + by blast hence "r\q\r\q \f (q\r\r\q)\<^sup>@k" - using \z' \s y\<^sup>@k\[folded yrq] - by blast + unfolding y + using pref_fac[OF \r \ q \ r \ q \p x\] by blast have "\<^bold>|r \ q \ r \ q\<^bold>| = \<^bold>|q \ r \ r \ q\<^bold>|" by simp from xyxy_conj_yxxy[OF fac_pow_len_conjug[OF this \r\q\r\q \f (q\r\r\q)\<^sup>@k\, symmetric]] have "r \ q = q \ r". thus False using \r \ q \ q \ r\ by blast qed lemma LS_unique_distinct: assumes "x \ y \ y \ x" - and "2 \ j" and "\ primitive(x\<^sup>@j\y)" + and "2 \ j" and "\ primitive(x\<^sup>@j\y)" and "2 \ k" and "\ primitive(x\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 \ y \ y \ x" - and "1 \ j" and "1 \ k" and "\ primitive(x\<^sup>@j\y\<^sup>@k)" + and "1 \ j" and "1 \ k" and "\ primitive(x\<^sup>@j\y\<^sup>@k)" and "1 \ j'" and "1 \ k'" and "\ primitive(x\<^sup>@j'\y\<^sup>@k')" shows "k = k'" proof- have "j = 1 \ k = 1" using Lyndon_Schutzenberger_prim[OF pow_non_prim pow_non_prim, - OF _ _ \\ primitive (x \<^sup>@ j \ y \<^sup>@ k)\] - comm_drop_exps[of x "j - 1" y "k - 1", unfolded Suc_minus'[OF \1 \ j\] Suc_minus'[OF \1 \ k\]] - \x \ y \ y \ x\ by blast - + OF _ _ \\ primitive (x \<^sup>@ j \ y \<^sup>@ k)\, THEN comm_drop_exps] + \1 \ j\ \1 \ k\ \x \ y \ y \ x\ by linarith have "j' = 1 \ k' = 1" using Lyndon_Schutzenberger_prim[OF pow_non_prim pow_non_prim, - OF _ _ \\ primitive (x \<^sup>@ j' \ y \<^sup>@ k')\] - comm_drop_exps[of x "j' - 1" y "k' - 1", unfolded Suc_minus'[OF \1 \ j'\] Suc_minus'[OF \1 \ k'\]] - \x \ y \ y \ x\ by blast - + OF _ _ \\ primitive (x \<^sup>@ j' \ y \<^sup>@ k')\, THEN comm_drop_exps] + \1 \ j'\ \1 \ k'\ \x \ y \ y \ x\ by linarith 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 \ j'" show "k = k'" proof(rule ccontr, cases "j = 1") assume "k \ k'" and "j = 1" hence "2 \ j'" and "k' = 1" and "2 \ k" - using \j \ j'\ \1 \ j'\ \k \ k'\ \1 \ k\ \j' = 1 \ k' = 1\ by auto + using \j \ j'\ \1 \ j'\ \k \ k'\ \1 \ k\ \j' = 1 \ k' = 1\ by auto from LS_unique_distinct[OF \x \ y \ y \ x\ \2 \ j'\ _ \2 \ k\] show False - using \\ primitive(x\<^sup>@j'\y\<^sup>@k')\[unfolded \k'=1\ pow_one'] \\ primitive(x\<^sup>@j\y\<^sup>@k)\[unfolded \j=1\ pow_one'] + using \\ primitive(x\<^sup>@j'\y\<^sup>@k')\[unfolded \k'=1\ pow_1] \\ primitive(x\<^sup>@j\y\<^sup>@k)\[unfolded \j=1\ pow_1] by blast next assume "k \ k'" and "j \ 1" hence "2 \ j" and "k = 1" and "2 \ k'" and "j' = 1" - using \1 \ j\ \j = 1 \ k = 1\ \1 \ k'\ \j' = 1 \ k' = 1\ by auto - from LS_unique_distinct[OF \x \ y \ y \ x\ \2 \ j\ _ \2 \ k'\] + using \1 \ j\ \j = 1 \ k = 1\ \1 \ k'\ \j' = 1 \ k' = 1\ by auto + from LS_unique_distinct[OF \x \ y \ y \ x\ \2 \ j\ _ \2 \ k'\] show False - using \\ primitive(x\<^sup>@j'\y\<^sup>@k')\[unfolded \j'=1\ pow_one'] \\ primitive(x\<^sup>@j\y\<^sup>@k)\[unfolded \k=1\ pow_one'] + using \\ primitive(x\<^sup>@j'\y\<^sup>@k')\[unfolded \j'=1\ pow_1] \\ primitive(x\<^sup>@j\y\<^sup>@k)\[unfolded \k=1\ pow_1] by blast qed qed qed lemma LS_unique: assumes "x \ y \ y \ x" - and "1 \ j" and "1 \ k" and "\ primitive(x\<^sup>@j\y\<^sup>@k)" + and "1 \ j" and "1 \ k" and "\ primitive(x\<^sup>@j\y\<^sup>@k)" and "1 \ j'" and "1 \ k'" and "\ primitive(x\<^sup>@j'\y\<^sup>@k')" -shows "j = j'" and "k = k'" - using LS_unique'[OF \x \ y \ y \ x\ +shows "j = j'" and "k = k'" + using LS_unique'[OF \x \ y \ y \ x\ \1 \ j\ \1 \ k\ \\ primitive (x \<^sup>@ j \ y \<^sup>@ k)\ \1 \ j'\ \1 \ k'\ \\ primitive (x \<^sup>@ j'\ y \<^sup>@ k')\] - LS_unique'[reversed, OF \x \ y \ y \ x\ + LS_unique'[reversed, OF \x \ y \ y \ x\ \1 \ k\ \1 \ j\ \\ primitive (x \<^sup>@ j \ y \<^sup>@ k)\ \1 \ k'\ \1 \ j'\ \\ primitive (x \<^sup>@ j'\ y \<^sup>@ k')\] by blast+ -end \ No newline at end of file +section "The bound on the exponent in Lyndon-Schützenberger equation" + +lemma (in LS_len_le) case_j1k2_exp_le: + assumes "j = 1" "2 \ k" + shows "k*\<^bold>|y\<^bold>|+ 4 \ \<^bold>|x\<^bold>|+2*\<^bold>|y\<^bold>|" +proof- + have "x \ y \<^sup>@ k = z \<^sup>@ l" and "\<^bold>|y\<^bold>| \ 0" and "0 < l" + using eq[unfolded \j = 1\ cow_simps] nemp_len[OF bin_snd_nemp] l_min + by linarith+ + + consider "y \<^sup>@ k s y\<^sup>@k" + using ruler_eq'[reversed, + OF \x \ y\<^sup>@k = z\<^sup>@l\[symmetric, unfolded pow_pos'[OF \0 < l\]]] by blast + thus ?thesis + proof(cases) + assume "y\<^sup>@k y \<^sup>@ k) \<^sup>@ (l - 1) \ q" and + "z = q \ y \<^sup>@ k" and + "q \ y \ y \ q". + have "1 \ \<^bold>|q\<^bold>|" + using nemp_le_len[of q] \q \ y \ y \ q\ by blast + + have "\<^bold>|y\<^bold>| \ 1" + using bin_snd_nemp nemp_le_len by blast + + have lle: "x \ (l-1)*x" for x + using l_min + by (simp add: quotient_smaller) + + have "\<^bold>|x\<^bold>| \ k*\<^bold>|y\<^bold>| + 2" + unfolding x lenmorph pow_len + using le_trans[OF _ lle, of "k * \<^bold>|y\<^bold>| + 1" "\<^bold>|q\<^bold>| + k * \<^bold>|y\<^bold>|", THEN add_le_mono[OF \1 \ \<^bold>|q\<^bold>|\]] + unfolding add.commute[of "\<^bold>|q\<^bold>|"] + using \1 \ \<^bold>|q\<^bold>|\ by auto + thus ?thesis + using \\<^bold>|y\<^bold>| \ 1\ by linarith + next + assume "z \s y \<^sup>@ k " + from case_j1k2_a[OF assms this] + obtain q r t where + x: "x = ((q \ r) \ (r \ (q \ r) \<^sup>@ t) \<^sup>@ (k - 1)) \<^sup>@ (l - 2) \ (((q \ r) \ (r \ (q \ r) \<^sup>@ t) \<^sup>@ (k - 2)) \ r) \ q" and + "y = r \ (q \ r) \<^sup>@ t" and + "z = (q \ r) \ (r \ (q \ r) \<^sup>@ t) \<^sup>@ (k - 1)" and + "0 < t" and "r \ q \ q \ r". + + have "q \ \" "r \ \" + using \r \ q \ q \ r\ by blast+ + hence "\<^bold>|q\<^bold>| \ 1" "\<^bold>|r\<^bold>| \ 1" + using nemp_le_len by blast+ + hence "\<^bold>|q\r\<^bold>| + \<^bold>|r\<^bold>| + \<^bold>|q\<^bold>| \ 4" + by simp + + have "\<^bold>|x\<^bold>| \ \<^bold>|(((q \ r) \ (r \ (q \ r) \<^sup>@ t) \<^sup>@ (k - 2)) \ r) \ q\<^bold>|" + using x suf_len' by blast + hence "\<^bold>|x\<^bold>| \ \<^bold>|q\r\<^bold>| + (k-2)*\<^bold>|y\<^bold>| + \<^bold>|r\<^bold>| + \<^bold>|q\<^bold>|" + unfolding \y = r \ (q \ r) \<^sup>@ t\[symmetric] + by (simp add: pow_len) + hence "\<^bold>|x\<^bold>| \ (k-2)*\<^bold>|y\<^bold>| + 4" + using \4 \ \<^bold>|q \ r\<^bold>| + \<^bold>|r\<^bold>| + \<^bold>|q\<^bold>|\ by linarith + thus ?thesis + unfolding add.commute[of "\<^bold>|x\<^bold>|"] + unfolding nat_le_add_iff1[OF \2 \ k\]. + qed +qed + +lemma (in LS_len_le) case_j2k1_exp_le: + assumes "2 \ j" "k = 1" + shows "j*\<^bold>|x\<^bold>| + 4 \ \<^bold>|y\<^bold>| + 2*\<^bold>|x\<^bold>|" +proof- + from case_j2k1[OF assms] + obtain r q t where + "(r \ q) \<^sup>@ t \ r = x" and + "q \ r \ r \ q = y" and + "(r \ q) \<^sup>@ t \ r \ r \ q = z" and + \2 \ t\ and "j = 2" and "l = 2" and + "r \ q \ q \ r" and + "primitive x" and + "primitive y". + + have "\<^bold>|r\<^bold>| \ 1" "\<^bold>|q\<^bold>| \ 1" + using \r \ q \ q \ r\ nemp_le_len by blast+ + hence "\<^bold>|y\<^bold>| \ 4" + unfolding \q \ r \ r \ q = y\[symmetric] lenmorph + by linarith + thus ?thesis + by (simp add: \j = 2\) +qed + +theorem LS_exp_le_one: + assumes eq: "x \ y \<^sup>@ k = z \<^sup>@ l" + and "2 \ l" + and "x \ y \ y \ x" + and "1 \ k" + shows "k*\<^bold>|y\<^bold>| + 4 \ \<^bold>|x\<^bold>|+2*\<^bold>|y\<^bold>|" +proof- + have "x \ \" "y \ \" "x \ y" "\<^bold>|y\<^bold>| \ 0" "z \ \" + using \x \ y \ y \ x\ \x \ y \<^sup>@ k = z \<^sup>@ l\ by fastforce+ + have "l \ 0" \1 \ l-1\ + using \2 \ l\ by force+ + + consider "k = 1" | "k \ 2" + using \1 \ k\ by linarith + then show ?thesis + proof(cases) + assume "k=1" + have "4 \ \<^bold>|x\<^bold>| + \<^bold>|y\<^bold>|" + using case_j1k1[OF eq[unfolded \k = 1\ pow_1] \x \ y \ y \ x\ \2 \ l\] + by blast + thus ?thesis + unfolding \k = 1\ by force + next + assume "k \ 2" + show ?thesis + proof(rule le_cases) + assume "\<^bold>|y\<^bold>| \ \<^bold>|x\<^bold>|" + then interpret LS_len_le x y 1 k l z + using assms by (unfold_locales, auto) + from case_j1k2_exp_le[OF refl \k \ 2\] + show ?thesis. + next + assume "\<^bold>|x\<^bold>| \ \<^bold>|y\<^bold>|" + have "y \ x \ x \ y" + using assms(3) by force + define z' where "z' = rotate \<^bold>|x\<^bold>| z" + hence "y\<^sup>@k \ x = z' \<^sup>@ l" + using arg_cong[OF assms(1), of "\t. rotate \<^bold>|x\<^bold>| t"] + unfolding rotate_append rotate_pow_comm + by blast + interpret LS_len_le y x k 1 l z' + using \\<^bold>|x\<^bold>| \ \<^bold>|y\<^bold>|\ \y \ x \ x \ y\ \y\<^sup>@k \ x = z' \<^sup>@ l\ \2 \ l\ \1 \ k\ + by (unfold_locales, auto) + from case_j2k1_exp_le[OF \2 \ k\ refl] + show ?thesis. + qed + qed +qed + +lemma LS_exp_le_conv_rat: + fixes x y k::"'a::linordered_field" + assumes "y > 0" + shows "k * y + 4 \ x + 2 * y \ k \ (x - 4)/y+ 2" + unfolding le_diff_eq[symmetric] + unfolding diff_conv_add_uminus + unfolding add.assoc add.commute[of "2*y"] + unfolding add.assoc[symmetric] + unfolding diff_le_eq[of _ "2*y" "x + - 4",symmetric] left_diff_distrib'[symmetric] + unfolding pos_le_divide_eq[OF \y > 0\, symmetric] + unfolding diff_le_eq.. + + +end diff --git a/thys/Combinatorics_Words/Morphisms.thy b/thys/Combinatorics_Words/Morphisms.thy --- a/thys/Combinatorics_Words/Morphisms.thy +++ b/thys/Combinatorics_Words/Morphisms.thy @@ -1,1621 +1,2004 @@ (* Title: Morphisms - File: CoW.Morphisms + File: Combinatorics_Words.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 \One morphism\ -subsection \Morphism, core map and extension\ +subsection \Morphism, core map and extension\ definition list_extension :: "('a \ 'b list) \ ('a list \ 'b list)" ("_\<^sup>\" [1000] 1000) where "t\<^sup>\ \ (\ x. concat (map t x))" definition morphism_core :: "('a list \ 'b list) \ ('a \ 'b list)" ("_\<^sup>\" [1000] 1000) where core_def: "f\<^sup>\ \ (\ x. f [x])" -lemma core_sing: "f\<^sup>\ a = f [a]" +(*QUESTION simp? abbereviation? + SH: attribute simp destroys proofs based on core*) +lemma core_sing: "f\<^sup>\ a = f [a]" unfolding core_def.. lemma range_map_core: "range (map f\<^sup>\) = lists (range f\<^sup>\)" using lists_image[of "\x. f [x]" UNIV, folded core_def, symmetric] - unfolding lists_UNIV. + unfolding lists_UNIV. lemma map_core_lists: "(map f\<^sup>\ w) \ lists (range f\<^sup>\)" by auto -locale morphism_on = +lemma comp_core: "(f \ g)\<^sup>\ = f \ g\<^sup>\" + unfolding core_def + by auto + +locale morphism_on = fixes f :: "'a list \ 'b list" and A :: "'a list set" - assumes morph_on: "\ u v. u \ \A\ \ v \ \A\ \ f (u \ v) = f u \ f v" + assumes morph_on: "u \ \A\ \ v \ \A\ \ f (u \ v) = f u \ f v" begin lemma emp_to_emp[simp]: "f \ = \" using morph_on[of \ \] self_append_conv2[of "f \" "f \"] by simp lemma emp_to_emp': "w = \ \ f w = \" using morph_on[of \ \] self_append_conv2[of "f \" "f \"] by simp lemma morph_concat_concat_map: "ws \ lists \A\ \ f (concat ws) = concat (map f ws)" by (induct ws, simp_all add: morph_on hull_closed_lists) lemma hull_im_hull: shows "\f ` A\ = f ` \A\" proof show " \f ` A\ \ f ` \A\" - proof (rule) - fix x + proof (rule subsetI) + fix x show "x \ \f ` A\ \ x \ f ` \A\" proof (induction rule: hull.induct) show "\ \ f ` \A\" using hull.emp_in emp_to_emp by force - show "w1 \ w2 \ f ` \A\" if "w1 \ f ` A" and "w2 \ f ` \A\" for w1 w2 - proof- + show "w1 \ w2 \ f ` \A\" if "w1 \ f ` A" and "w2 \ f ` \A\" for w1 w2 + proof- from that obtain pre1 pre2 where "pre1 \ \A\" and "pre2 \ \A\" and "f pre1 = w1" and "f pre2 = w2" - using imageE by blast+ + using imageE by blast+ from hull_closed[OF this(1-2)] morph_on[OF \pre1 \ \A\\ \pre2 \ \A\\, unfolded this(3-4)] show "w1 \ w2 \ f ` \A\" - by force + by force qed qed qed - show "f ` \A\ \ \f ` A\" - proof + show "f ` \A\ \ \f ` A\" + proof fix x assume "x \ f ` \A\" then obtain xs where "f (concat xs) = x" and "xs \ 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)]] + morph_concat_concat_map[OF genset_sub_lists[OF this(2)]] show "x \ \f ` A\" by fastforce qed qed lemma inj_basis_to_basis: assumes "inj_on f \A\" shows "f ` (\ \A\) = \ (f`\A\)" proof interpret basis: morphism_on f "\ \A\" by (rule morph_on morphism_on.intro, unfold basis_gen_hull'[of A]) - (simp only: morph_on) + (simp only: morph_on) show "\ (f ` \A\) \ f ` \ \A\" - using basis.hull_im_hull unfolding basis_gen_hull unfolding self_gen using basis_hull_sub[of "f ` \ \A\"] by argo + using basis.hull_im_hull unfolding basis_gen_hull unfolding self_gen using basis_hull_sub[of "f ` \ \A\"] by argo show "f ` \ \A\ \ \ (f ` \A\)" proof fix x assume "x \ f ` \ \A\" then obtain y where "y \ \ \A\" and "x = f y" by blast hence "x \ f ` \A\" using basis_sub by blast from basis_concat_listsE[OF this] obtain xs where "xs \ lists \ (f `\A\)" and "concat xs = x". hence "\ \ set xs" - using emp_not_basis by blast + using emp_not_basis by blast have "xs \ lists (f `\A\)" - using \xs \ lists \ (f `\A\)\ basis_sub by blast + using \xs \ lists \ (f `\A\)\ basis_sub by blast then obtain ys where "map f ys = xs" and "ys \ lists \A\" unfolding lists_image by blast - have "\ \ set ys" + have "\ \ set ys" using emp_to_emp \\ \ set xs\ - imageI[of \ "set ys" f] unfolding list.set_map[of f ys, unfolded \map f ys = xs\] by presburger - hence "ys \ lists \A\\<^sub>+" + imageI[of \ "set ys" f] unfolding list.set_map[of f ys, unfolded \map f ys = xs\] by presburger + hence "ys \ lists (\A\ - {\}) " using \ys \ lists \A\\ by fast have "f (concat ys) = x" - unfolding morph_concat_concat_map[OF \ys \ lists \A\\] \map f ys = xs\ by fact - from \inj_on f \A\\ this[unfolded \x = f y\] + unfolding morph_concat_concat_map[OF \ys \ lists \A\\] \map f ys = xs\ by fact + from \inj_on f \A\\ this[unfolded \x = f y\] have "concat ys = y" unfolding inj_on_def using subsetD[OF basis_sub \y \ \ \A\\] hull_closed_lists[OF \ys \ lists \A\\] by blast - hence "\<^bold>|ys\<^bold>| = 1" - using \y \ \ \A\\ \ys \ lists \A\\<^sub>+\ unfolding basis_def simple_element_def mem_Collect_eq by fast + hence "\<^bold>|ys\<^bold>| = 1" + using \y \ \ \A\\ \ys \ lists (\A\ - {\})\ unfolding basis_def simple_element_def mem_Collect_eq by fast hence "\<^bold>|xs\<^bold>| = 1" using \map f ys = xs\ by fastforce with \concat xs = x\ \xs \ lists \ (f `\A\)\ show "x \ \ (f ` \A\)" using len_one_concat_in by blast qed qed lemma inj_code_to_code: assumes "inj_on f \A\" and "code A" shows "code (f ` A)" proof fix xs ys assume "xs \ lists (f ` A)" and "ys \ lists (f ` A)" - then obtain xs' ys' where "xs' \ lists A" and "map f xs' = xs" and "ys' \ lists A" and "map f ys' = ys" + then obtain xs' ys' where "xs' \ lists A" and "map f xs' = xs" and "ys' \ 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: \map f xs' = xs\ \map f ys' = ys\ \xs' \ lists A\ \ys' \ lists A\ genset_sub_lists morph_concat_concat_map) hence "concat xs' = concat ys'" using \inj_on f \A\\[unfolded inj_on_def] \xs' \ lists A\ \ys' \ lists A\ by auto hence "xs' = ys'" using \code A\[unfolded code_def] \xs' \ lists A\ \ys' \ lists A\ by simp thus "xs = ys" using \map f xs' = xs\ \map f ys' = ys\ by blast qed end locale morphism = fixes f :: "'a list \ 'b list" assumes morph: "f (u \ v) = f u \ f v" begin sublocale morphism_on f UNIV by (simp add: morph morphism_on.intro) lemma map_core_lists[simp]: "map f\<^sup>\ xs \ lists (range f\<^sup>\)" 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) + by (simp add: pow_morph rev_map_arg rev_pow) lemma pop_hd: "f (a#u) = f [a] \ f u" - unfolding hd_word[of a u] using morph. + unfolding hd_word[of a u] using morph. lemma pop_hd_nemp: "u \ \ \ f (u) = f [hd u] \ f (tl u)" using list.exhaust_sel pop_hd[of "hd u" "tl u"] by force lemma pop_last_nemp: "u \ \ \ f (u) = f (butlast u) \ f [last u]" unfolding morph[symmetric] append_butlast_last_id .. lemma pref_mono: "u \p v \ f u \p f v" using morph by (auto simp add: prefix_def) lemma suf_mono: "u \s v \ f u \s f v" - using morph by (auto simp add: suf_def) + using morph by (auto simp add: suffix_def) lemma morph_concat_map: "concat (map f\<^sup>\ x) = f x" unfolding core_def -proof (induction x, simp) +proof (induction x) case (Cons a x) - then show ?case - unfolding pop_hd[of a x] by auto -qed + then show ?case + unfolding pop_hd[of a x] by auto +qed simp lemma morph_concat_map': "(\ x. concat (map f\<^sup>\ x)) = f" using morph_concat_map by simp -lemma morph_to_concat: +lemma morph_to_concat: obtains xs where "xs \ lists (range f\<^sup>\)" and "f x = concat xs" proof- have "map f\<^sup>\ x \ lists (range f\<^sup>\)" - by (simp add: lists_image) - from that[OF this morph_concat_map[symmetric]] + by fastforce + from that[OF this morph_concat_map[symmetric]] show thesis. -qed +qed lemma range_hull: "range f = \(range f\<^sup>\)\" 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 \ \(range f\<^sup>\)\" using range_hull by blast lemma core_ext_id: "f\<^sup>\\<^sup>\ = 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) +proof (induction u) case (Cons a u) - then show ?case + then show ?case unfolding rev.simps(2) pop_hd[of a u] morph lenmorph by force -qed +qed simp lemma rev_map_len: "\<^bold>|rev_map f u\<^bold>| = \<^bold>|f u\<^bold>|" unfolding rev_map_def - by (simp add: morph_rev_len) + by (simp add: morph_rev_len) lemma in_set_morph_len: assumes "a \ set w" shows "\<^bold>|f [a]\<^bold>| \ \<^bold>|f w\<^bold>|" proof- from split_listE[OF assms] obtain p s where "w = p \ [a] \ s". from lenarg[OF arg_cong[of _ _ f, OF this], unfolded morph lenmorph] show ?thesis by linarith qed lemma morph_lq_comm: "u \p v \ f (u\\<^sup>>v) = (f u)\\<^sup>>(f v)" using morph by (auto simp add: prefix_def) -lemma morph_rq_comm: "v \s u \ f (u\<^sup><\v) = (f u)\<^sup><\(f v)" - using morph by (auto simp add: suf_def) +lemma morph_rq_comm: assumes "v \s u" + shows "f (u\<^sup><\v) = (f u)\<^sup><\(f v)" + using arg_cong[OF rq_suf[OF \v \s u\], of f, unfolded morph, THEN rqI, symmetric]. lemma code_set_morph: assumes c: "code (f\<^sup>\ `(set (u \ v)))" and i: "inj_on f\<^sup>\ (set (u \ v))" and "f u = f v" shows "u = v" proof- let ?C = "f\<^sup>\ `(set (u \ v))" interpret code ?C using c by blast have "(map f\<^sup>\ u) \ lists ?C" and "(map f\<^sup>\ v) \ lists ?C" - by (simp_all add: in_listsI) + by (simp_all add: in_listsI) from is_code[OF this \f u = f v\[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: "(\ w. w = \ \ f w = \) \ (\ a. f [a] \ \)" - by (rule, blast) - (metis Nil_is_append_conv emp_to_emp' hd_tlE pop_hd) + by (rule iffI, blast) + (metis Nil_is_append_conv emp_to_emp' hd_tlE pop_hd) + +lemma fac_mono: "u \f w \ f u \f f w" + using morph by fastforce + +lemma set_core_set: "set (f w) = \ (set ` f\<^sup>\ ` (set w))" + unfolding list.set_map[symmetric] + unfolding image_set[of set "(map f\<^sup>\ w)", symmetric] + unfolding morph_concat_map[symmetric, of w] + using set_concat. end lemma morph_map: "morphism (map f)" by (simp add: morphism_def) lemma list_ext_morph: "morphism t\<^sup>\" unfolding list_extension_def by (simp add: morphism_def) lemma ext_def_on_set: "(\ a. a \ set u \ g a = f a) \ g\<^sup>\ u = f\<^sup>\ u" unfolding list_extension_def using map_ext by metis lemma morph_def_on_set: "morphism f \ morphism g \ (\ a. a \ set u \ g\<^sup>\ a = f\<^sup>\ a) \ g u = f u" using ext_def_on_set morphism.core_ext_id by metis lemma morph_compose: "morphism f \ morphism g \ morphism (f \ g)" by (simp add: morphism_def) +subsection \Periodic morphism\ + +locale periodic_morphism = morphism + + assumes ims_comm: "\ u v. f u \ f v = f v \ f u" and + not_triv_emp: "\ (\ c. f [c] = \)" +begin + +lemma per_morph_root_ex: + "\ r. \ u. \ n. f u = r\<^sup>@n \ primitive r" +proof- + obtain c root n where "f[c] = root\<^sup>@n" and "root = \ (f [c])" and "f [c] \ \" + using primroot_expE not_triv_emp by metis + have "\ n. f u = root\<^sup>@n" for u + using comm_primroot_exp[OF \f [c] \ \\, OF ims_comm, folded \root = \ (f [c])\] by metis + thus ?thesis + using \root = \ (f [c])\ \f [c] \ \\ by auto +qed + +definition mroot where "mroot \ (SOME r. (\ u. \ n. f u = r\<^sup>@n) \ primitive r)" +definition mexp :: "'a \ nat" where "mexp c \ (SOME n. f [c] = mroot\<^sup>@n)" + +lemma per_morph_rootI: "\ u. \ n. f u = mroot\<^sup>@n" and + per_morph_root_prim: "primitive mroot" + using per_morph_root_ex exE_some[of "\ r. \u. \n. f u = r \<^sup>@ n \ primitive r", of mroot] + unfolding mroot_def by auto + +lemma per_morph_expI': "f [c] = mroot\<^sup>@(mexp c)" + using per_morph_rootI exE_some[of "\ n. f [c] = mroot \<^sup>@ n", of "mexp c"] + unfolding mexp_def by blast + +lemma per_morph_expE: + obtains n where "f u = mroot\<^sup>@n" + using per_morph_rootI by auto + +interpretation mirror: periodic_morphism "rev_map f" +proof + show "rev_map f (u \ v) = rev_map f u \ rev_map f v" for u v + using morphism.morph[OF rev_map_morph]. + show "rev_map f u \ rev_map f v = rev_map f v \ rev_map f u" for u v + unfolding comm_rev_iff ims_comm rev_map_arg.. + show "\ (\c. rev_map f [c] = \)" + using not_triv_emp unfolding rev_map_sing by blast +qed + +lemma mroot_rev: "mirror.mroot = rev mroot" +proof- + have "primitive (rev mroot)" + using per_morph_root_prim prim_rev_iff by blast + obtain u where "f u \ \" + using not_triv_emp by auto + obtain n where "f u = mroot\<^sup>@n" + using per_morph_expE[of u]. + hence "0 < n" + using \f u \ \\ by blast + obtain n' where "rev (f u) = mirror.mroot\<^sup>@n'" "0 < n'" + using mirror.per_morph_expE rev_map_arg_rev + \f u \ \\[folded Nil_is_rev_conv, symmetric] + using bot_nat_0.not_eq_extremum zero_exp by metis + from this(1)[unfolded \f u = mroot\<^sup>@ n\, unfolded rev_pow] + have *: "rev mroot \<^sup>@ n = mirror.mroot \<^sup>@ n'". + have "(rev mroot) \ mirror.mroot = mirror.mroot \ (rev mroot)" + by (rule comm_drop_exps[OF _ \0 < n\ \0 < n'\]) (use * in blast) + thus ?thesis + using comm_prim[OF \primitive (rev mroot)\ mirror.per_morph_root_prim] by force +qed + +end + + subsection \Non-erasing morphism\ locale nonerasing_morphism = morphism + assumes nonerasing: "f w = \ \ w = \" begin lemma core_nemp: "f\<^sup>\ a \ \" unfolding core_def using nonerasing not_Cons_self2 by blast lemma nemp_to_nemp: "w \ \ \ f w \ \" using nonerasing by blast lemma sing_to_nemp: "f [a] \ \" - by (simp add: nemp_to_nemp) + by (simp add: nemp_to_nemp) lemma pref_morph_pref_eq: "u \p v \ f v \p f u \ u = v" - using nonerasing morph[of u "u\\<^sup>>v"] unfolding prefix_def by fastforce + using nonerasing morph[of u "u\\<^sup>>v"] unfolding prefix_def by fastforce + +lemma comm_eq_im_eq: + "u \ v = v \ u \ f u = f v \ u = v" + by (elim ruler_eqE) + (simp_all add: pref_morph_pref_eq pref_morph_pref_eq[symmetric]) + +lemma comm_eq_im_iff : + assumes "u \ v = v \ u" + shows "f u = f v \ u = v" + using comm_eq_im_eq[OF \u \ v = v \ u\] by blast lemma rev_map_nonerasing: "nonerasing_morphism (rev_map f)" proof show "rev_map f (u \ v) = rev_map f u \ rev_map f v" for u v by (simp add: morphism.morph rev_map_morph) show "rev_map f w = \ \ w = \" 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 \], of \f (a # \) = \\]]]. lemma hd_im_hd_hd: assumes "u \ \" shows "hd (f u) = hd (f [hd u])" unfolding hd_append2[OF sing_to_nemp] pop_hd_nemp[OF \u \ \\].. lemma ssuf_mono: "u f u |u\<^bold>| \ \<^bold>|f u\<^bold>|" -proof (induct u, simp) +proof (induct u) case (Cons a u) - show ?case + show ?case unfolding hd_word[of a u] morph lenmorph sing_len - by (rule add_mono[OF _ \\<^bold>|u\<^bold>| \ \<^bold>|f u\<^bold>|\], use nemp_le_len[OF sing_to_nemp] in force) -qed + by (rule add_mono[OF _ \\<^bold>|u\<^bold>| \ \<^bold>|f u\<^bold>|\], use nemp_le_len[OF sing_to_nemp] in force) +qed simp lemma im_len_eq_iff: "\<^bold>|u\<^bold>| = \<^bold>|f u\<^bold>| \ (\ c. c \ set u \ \<^bold>|f [c]\<^bold>| = 1)" -proof (induct u, simp) +proof (induct u) case (Cons a u) - show ?case + 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 "\c. c \ set (a # u) \ \<^bold>|f [c]\<^bold>| = 1" by auto next assume "\c. c \ set (a # u) \ \<^bold>|f [c]\<^bold>| = 1" hence all: "\c. c \ set u \ \<^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 \\<^bold>|f [a]\<^bold>| = 1\ all[folded Cons.hyps].. qed -qed +qed simp lemma im_len_less: "a \ set u \ \<^bold>|f [a]\<^bold>| \ 1 \ \<^bold>|u\<^bold>| < \<^bold>|f u\<^bold>|" - using im_len_le im_len_eq_iff order_le_neq_trans by auto - + using im_len_le im_len_eq_iff order_le_neq_trans by auto + end -lemma (in morphism) nonerI[intro]: assumes "(\ a. f\<^sup>\ a \ \)" - shows "nonerasing_morphism f" +lemma (in morphism) nonerI[intro]: assumes "(\ a. f\<^sup>\ a \ \)" + shows "nonerasing_morphism f" proof from assms[unfolded core_def] noner_sings_conv show "\w. f w = \ \ w = \" by presburger qed +lemma (in morphism) prim_morph_noner: + assumes prim_morph: "\u. 2 \ \<^bold>|u\<^bold>| \ primitive u \ primitive (f u)" + and non_single_dom: "\a b :: 'a. a \ b" + shows "nonerasing_morphism f" +proof (intro nonerI notI) + fix a + assume "f\<^sup>\ a = \" + obtain c d :: "'a" where "c \ d" + using non_single_dom by blast + then obtain b where "a \ b" + by (cases "a = c") simp_all + then have "\ primitive (f ([a] \ [b] \ [b]))" + using \f\<^sup>\ a = \\ unfolding morph + by (simp add: core_def eq_append_not_prim) + have "primitive ([a] \ [b] \ [b])" + using prim_abk[OF \a \ b\, of 2] by simp + from prim_morph[OF _ this] \\ primitive (f ([a] \ [b] \ [b]))\ + show False + by simp +qed + subsection \Code morphism\ -text \The term ``Code morphism'' is equivalent to ``injective morphism''.\ +text \The term ``Code morphism'' is equivalent to ``injective morphism''.\ text \Note that this is not equivalent to @{term "code (range f\<^sup>\)"}, since the core can be not injective.\ lemma (in morphism) code_core_range_inj: "inj f \ code (range f\<^sup>\) \ inj f\<^sup>\" proof assume "inj f" show "code (range f\<^sup>\) \ inj f\<^sup>\" proof show "inj f\<^sup>\" using \inj f\ unfolding inj_on_def core_def by blast show "code (range f\<^sup>\)" proof - show + show "xs \ lists (range f\<^sup>\) \ ys \ lists (range f\<^sup>\) \ concat xs = concat ys \ xs = ys" for xs ys unfolding range_map_core[symmetric] using \inj f\[unfolded inj_on_def core_def] morph_concat_map - by force + by force qed qed next assume "code (range f\<^sup>\) \ inj f\<^sup>\" hence "code (range f\<^sup>\)" and "inj f\<^sup>\" by blast+ show "inj f" proof fix x y assume "f x = f y" - with code.is_code[OF \code (range f\<^sup>\)\, folded range_map_core, OF rangeI rangeI, unfolded morph_concat_map] + with code.is_code[OF \code (range f\<^sup>\)\, folded range_map_core, OF rangeI rangeI, unfolded morph_concat_map] have "map f\<^sup>\ x = map f\<^sup>\ y" by blast - with \inj f\<^sup>\\ + with \inj f\<^sup>\\ show "x = y" by simp qed qed -locale code_morphism = morphism f for f + + +locale code_morphism = morphism f for f + assumes code_morph: "inj f" begin -lemma inj_core: "inj f\<^sup>\" +lemma inj_core: "inj f\<^sup>\" using code_morph unfolding core_def inj_on_def by blast -lemma sing_im_core: "f [a] \ (range f\<^sup>\)" +lemma sing_im_core: "f [a] \ (range f\<^sup>\)" unfolding core_def by simp lemma code_im: "code (range f\<^sup>\)" 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>\" using code_im. sublocale nonerasing_morphism - by (rule, simp add: in_code_nemp) + by (rule nonerI, simp add: nemp) -lemma code_morph_code: assumes "f r = f s" shows "r = s" +lemma code_morph_code: assumes "f r = f s" shows "r = s" proof- from code.is_code[OF code_im, of "map f\<^sup>\ r" "map f\<^sup>\ s"] have "map f\<^sup>\ r = map f\<^sup>\ 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 \(range f\<^sup>\)\" unfolding bij_betw_def - by (rule, simp_all add: range_hull, rule, simp add: code_morph_code) + by (rule disjE, simp_all add: range_hull) + (rule injI, 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) +proof (rule conjI) 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 +qed (simp add: rev_map_morph) -lemma morph_on_inj_on: +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 + using morph code_morph_code unfolding morphism_on_def inj_on_def by blast+ end -lemma code_morphismI: "morphism f \ inj f \ code_morphism f" - unfolding code_morphism_def code_morphism_axioms_def by blast +lemma (in morphism) code_morphismI: "inj f \ code_morphism f" + by unfold_locales + +lemma (in nonerasing_morphism) code_morphismI' : + assumes comm: "\u v. f u = f v \ u \ v = v \ u" + shows "code_morphism f" +proof (unfold_locales, intro injI) + fix u v + assume "f u = f v" + then have "u \ v = v \ u" + by (fact comm) + from comm_eq_im_eq[OF this \f u = f v\] + show "u = v". +qed subsection \Prefix code morphism\ -locale pref_code_morphism = nonerasing_morphism + +locale pref_code_morphism = nonerasing_morphism + assumes pref_free: "f\<^sup>\ a \p f\<^sup>\ b \ a = b" begin interpretation prefrange: pref_code "(range f\<^sup>\)" - unfolding pref_code_def using core_nemp pref_free by fast + by (unfold_locales, unfold image_iff) + (use core_nemp in metis, use pref_free in fast) -lemma inj_core: "inj f\<^sup>\" +lemma inj_core: "inj f\<^sup>\" unfolding inj_on_def using pref_free by force -sublocale code_morphism +sublocale code_morphism proof show "inj f" - unfolding inj_on_def - proof (standard+) + proof (rule injI) fix x y - assume "f x = f y" + assume "f x = f y" hence "map f\<^sup>\ x = map f\<^sup>\ y" - using prefrange.is_code[folded range_map_core, of "map f\<^sup>\ x" "map f\<^sup>\ y"] - unfolding morph_concat_map by fast + using prefrange.is_code[folded range_map_core, of "map f\<^sup>\ x" "map f\<^sup>\ y"] + unfolding morph_concat_map by fast with inj_core[folded inj_map[of "f\<^sup>\"], unfolded inj_on_def] - show "x = y" + show "x = y" by fast qed qed thm nonerasing -lemma pref_free_morph: assumes "f r \p f s" shows "r \p s" +lemma pref_free_morph: assumes "f r \p f s" shows "r \p s" using assms -proof (induction r s rule: list_induct2', simp) +proof (induction r s rule: list_induct2') 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 + then show ?case using emp_to_emp nonerasing prefix_bot.extremum_unique by blast next case (4 x xs y ys) - then show ?case + then show ?case proof- have "f\<^sup>\ x \p f\<^sup>\ y \ f ys" - unfolding core_def using "4.prems"[unfolded pop_hd[of x xs] pop_hd[of y ys], THEN append_prefixD]. + 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" + 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 \x = y\ by fastforce + unfolding \x = y\ by fastforce qed -qed +qed simp end subsection \Marked morphism\ -locale marked_morphism = nonerasing_morphism + - assumes +locale marked_morphism = nonerasing_morphism + + assumes marked_core: "hd (f\<^sup>\ a) = hd (f\<^sup>\ b) \ a = b" begin lemma marked_im: "marked_code (range f\<^sup>\)" - unfolding marked_code_def using image_iff marked_core core_nemp by fast + by (unfold_locales, unfold image_iff) + (use marked_core core_nemp in metis)+ interpretation marked_code "(range f\<^sup>\)" 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 \ \" and "v \ \" and "hd (f u) = hd (f v)" + +lemma hd_im_eq_hd_eq: assumes "u \ \" and "v \ \" and "hd (f u) = hd (f v)" shows "hd u = hd v" using marked_morph[OF \hd (f u) = hd (f v)\[unfolded hd_im_hd_hd[OF \u \ \\] hd_im_hd_hd[OF \v \ \\]]]. lemma marked_morph_lcp: "f (r \\<^sub>p s) = f r \\<^sub>p f s" - by (simp add: - marked_concat_lcp[of "map f\<^sup>\ r" "map f\<^sup>\ s", unfolded map_lcp_conv[OF inj_core] morph_concat_map]) + by (rule marked_concat_lcp[of "map f\<^sup>\ r" "map f\<^sup>\ s", unfolded map_lcp_conv[OF inj_core] morph_concat_map]) simp_all lemma marked_inj_map: "inj e \ marked_morphism ((map e) \ 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) + by unfold_locales + (simp add: morph, simp add: code_morph_code, simp add: core_def core_nemp nemp_to_nemp marked_core list.map_sel(1) sing_to_nemp) end thm morphism.nonerI lemma (in morphism) marked_morphismI: - "(\ a. f[a] \ \) \ (\ a b. a \ b) \ hd (f[a]) \ hd (f[b]) \ marked_morphism f" - by (standard, blast, unfold core_def, blast) + "(\ a. f[a] \ \) \ (\ a b. a \ b) \ hd (f[a]) \ hd (f[b]) \ marked_morphism f" + by unfold_locales presburger+ + +subsection "Image length" + +definition max_image_length:: "('a list \ 'b list) \ nat" ("\_\") + where "max_image_length f = Max (length`(range f\<^sup>\))" + +definition min_image_length::"('a list \ 'b list) \ nat" ("\_\" ) + where "min_image_length f = Min (length`(range f\<^sup>\))" + +lemma max_im_len_id: "\id::('a list \ 'a list)\ = 1" and min_im_len_id: "\id::('a list \ 'a list)\ = 1" +proof- + have a1: "length ` range (\x. [x]) = {1}" + by force + show "\id::('a list \ 'a list)\ = 1" and "\id::('a list \ 'a list)\ = 1" + unfolding max_image_length_def min_image_length_def core_def id_apply a1 + by force+ +qed + +context morphism +begin + +lemma max_im_len_le: "finite (length`range f\<^sup>\) \ \<^bold>|f z\<^bold>| \ \<^bold>|z\<^bold>|*\f\" +proof(induction z) + case (Cons a z) + have "\<^bold>|f [a]\<^bold>| \ length`(range f\<^sup>\)" + by (simp add: core_def) + hence "\<^bold>|f [a]\<^bold>| \ \f\" + unfolding max_image_length_def + using Cons.prems Max.coboundedI by metis + thus ?case + unfolding hd_word[of a z] morph[of "[a]" z] + unfolding lenmorph + using Cons.IH[OF Cons.prems] by auto +qed simp + +lemma max_im_len_le_sing: assumes "finite (length`range f\<^sup>\)" + shows "\<^bold>|f [a]\<^bold>| \ \f\" + using max_im_len_le[OF assms, of "[a]"] + unfolding mult_1 sing_len. + +lemma min_im_len_ge: "finite (length`range f\<^sup>\) \ \<^bold>|z\<^bold>| * \f\ \ \<^bold>|f z\<^bold>|" +proof(induction z) + case (Cons a z) + have "\<^bold>|f [a]\<^bold>| \ length`(range f\<^sup>\)" + by (simp add: core_def) + hence "\f\ \ \<^bold>|f [a]\<^bold>|" + unfolding min_image_length_def + by (meson Cons.prems Min_le) + thus ?case + unfolding hd_word[of a z] morph[of "[a]" z] + unfolding lenmorph + using Cons.IH[OF Cons.prems] by auto +qed simp + +lemma max_im_len_comp_le: assumes finite_f: "finite (length`range f\<^sup>\)" and + finite_g: "finite (length`range g\<^sup>\)" and "morphism g" + shows "finite (length ` range (g \ f)\<^sup>\)" "\g \ f\ \ \f\*\g\" +proof- + interpret mg: morphism g + by (simp add: \morphism g\) + + have "\<^bold>|g (f [x])\<^bold>| \ \f\*\g\" for x + proof- + have "\<^bold>|f [x]\<^bold>| \ \f\" + using finite_f max_im_len_le_sing by presburger + thus "\<^bold>|g (f [x])\<^bold>| \ \f\*\g\" + by (meson finite_g le_trans mg.max_im_len_le mult_le_cancel2) + qed + hence "\<^bold>|(g o f)\<^sup>\ x\<^bold>| \ \f\*\g\" for x + by (simp add: core_sing) + hence "l \ length ` range (g \ f)\<^sup>\ \ l \ \f\*\g\" for l + by blast + thus "finite (length ` range (g \ f)\<^sup>\)" + using finite_nat_set_iff_bounded_le by metis + from Max.boundedI[OF this] + show "\g o f\ \ \f\*\g\" + using \\l. l \ length ` range (g \ f)\<^sup>\ \ l \ \f\ * \g\\ + unfolding max_image_length_def + by blast +qed + +lemma max_im_len_emp: assumes "finite (length ` range f\<^sup>\)" + shows "\f\ = 0 \ (f = (\w. \))" + by (rule iffI, use max_im_len_le[OF assms] npos_len in force, simp add: core_def max_image_length_def) + +lemmas max_im_len_le_dom = max_im_len_le[OF finite_imageI, OF finite_imageI] and + max_im_len_le_sing_dom = max_im_len_le_sing[OF finite_imageI, OF finite_imageI] and + min_im_len_ge_dom = min_im_len_ge[OF finite_imageI, OF finite_imageI] and + max_im_len_comp_le_dom = max_im_len_comp_le[OF finite_imageI, OF finite_imageI] and + max_im_len_emp_dom = max_im_len_emp[OF finite_imageI, OF finite_imageI] + +end +subsection "Endomorphism" + +locale endomorphism = morphism f for f:: "'a list \ 'a list" +begin + +lemma pow_endomorphism: "endomorphism (f^^k)" + by (unfold_locales, induction k) (simp_all add: power.power.power_0 morph) + +interpretation pow_endm: endomorphism "(f^^k)" + using pow_endomorphism by blast + + +lemmas pow_morphism = pow_endm.morphism_axioms and + pow_morph = pow_endm.morph and + pow_emp_to_emp = pow_endm.emp_to_emp + + + + +lemma pow_sets_im: "set w = set v \ set ((f^^k) w) = set ((f^^k) v)" + by(induct k, auto simp add: power.power.power_0 set_core_set) + +lemma fin_len_ran_pow: "finite (length ` range f\<^sup>\) \ finite (length ` range (f^^k)\<^sup>\)" +proof(induction k) + case 0 + have "(w::'a list) \ range (\a. [a]) \ \<^bold>|w\<^bold>| = 1" for w + by force + thus ?case + unfolding funpow_0 core_def + using finite_nat_set_iff_bounded_le by auto +next + case (Suc k) + show ?case + using pow_endm.max_im_len_comp_le(1)[of _ f, folded funpow.simps(2), OF Suc.IH, OF Suc.prems Suc.prems morphism_axioms]. +qed + +lemma max_im_len_pow_le: assumes "finite (length ` range f\<^sup>\)" shows "\f^^k\ \ \f\^k" +proof(induction k) + have funpow_1: "f^^1 = f" by simp + case (Suc k) + show ?case + using mult_le_mono2[OF Suc.IH[OF Suc.prems], of "\f ^^ 1\"] pow_endm.max_im_len_comp_le(2)[OF fin_len_ran_pow, OF \finite (length ` range f\<^sup>\)\ \finite (length ` range f\<^sup>\)\ morphism_axioms] + unfolding compow_Suc funpow_1 comp_apply + unfolding power_class.power.power_Suc + unfolding mult.commute[of "\f\"] + using dual_order.trans by blast +qed (simp add: max_im_len_id[unfolded id_def]) + +lemma max_im_len_pow_le': "finite (length ` range f\<^sup>\) \ \<^bold>|(f^^k) w\<^bold>| \ \<^bold>|w\<^bold>| * \f\^k" + using fin_len_ran_pow le_trans max_im_len_pow_le mult_le_mono2 pow_endm.max_im_len_le by meson + +lemmas max_im_len_pow_le_dom = max_im_len_pow_le[OF finite_imageI, OF finite_imageI] and + max_im_len_pow_le'_dom = max_im_len_pow_le'[OF finite_imageI, OF finite_imageI] + +lemma funpow_nonerasing_morphism: assumes "nonerasing_morphism f" + shows "nonerasing_morphism (f^^k)" +proof(unfold_locales, induction k) + case (Suc k) + then show ?case + using nonerasing_morphism.nonerasing[OF assms] + unfolding compow_Suc' by blast +qed simp + +lemma im_len_pow_mono: assumes "nonerasing_morphism f" "i \ j" + shows "(\<^bold>|(f^^i) w\<^bold>| \ \<^bold>|(f^^j) w\<^bold>|)" + using nonerasing_morphism.im_len_le[OF funpow_nonerasing_morphism[of "j-i"], OF \nonerasing_morphism f\, of "(f^^i) w"] + using funpow_add[unfolded comp_apply, of "j-i" i f] + unfolding diff_add[OF \i \ j\] + by simp + +lemma fac_mono_pow: "u \f (f^^k) w \ (f^^l) u \f (f^^(l+k)) w" + by (simp add: funpow_add pow_endm.fac_mono) + +lemma rev_map_endomorph: "endomorphism (rev_map f)" + by (simp add: endomorphism.intro rev_map_morph) + +end +section \Primitivity preserving morphisms\ + +locale primitivity_preserving_morphism = nonerasing_morphism + + assumes prim_morph : "2 \ \<^bold>|u\<^bold>| \ primitive u \ primitive (f u)" +begin + +sublocale code_morphism +proof (rule code_morphismI', rule nemp_comm) + fix u v + assume "u \ \" and "v \ \" and "f u = f v" + then have "2 \ \<^bold>|u \ v\<^bold>|" and "2 \ \<^bold>|u \ v \ v\<^bold>|" + by (simp_all flip: len_nemp_conv) + moreover have "\ primitive (f (u \ v))" and "\ primitive (f (u \ v \ v))" + using pow_nemp_imprim[of 2] pow_nemp_imprim[of 3] unfolding numeral_nat + by (simp_all add: morph \f u = f v\) assumption+ + ultimately have "\ primitive (u \ v)" and "\ primitive (u \ v \ v)" + by (intro notI; elim prim_morph[rotated, elim_format], blast+)+ + then show "u \ v = v \ u" + by (fact imprim_ext_suf_comm) +qed + +lemmas code_morph = code_morph + +end section \Two morphisms\ text \Solutions and the coincidence pairs are defined for any two mappings\ subsection \Solutions\ -definition minimal_solution :: "'a list \ ('a list \ 'b list) \ ('a list \ 'b list) \ bool" ("_ \ _ =\<^sub>M _" [80,80,80] 51 ) - where minsoldef: "minimal_solution s g h \ s \ \ \ g s = h s \ (\ s'. s' \np s \ g s' = h s' \ s' = s)" - -lemma minsolD: "s \ g =\<^sub>M h \ g s = h s" - using minsoldef by blast - -lemma minsolD': "s \ g =\<^sub>M h \ s \ \" - using minsoldef by blast +definition minimal_solution :: "'a list \ ('a list \ 'b list) \ ('a list \ 'b list) \ bool" + ("_ \ _ =\<^sub>M _" [80,80,80] 51 ) + where min_sol_def: "minimal_solution s g h \ s \ \ \ g s = h s + \ (\ s'. s' \ \ \ s' \p s \ g s' = h s' \ s' = s)" -lemma minsolD_min: "s \ g =\<^sub>M h \ p \ \ \ p \p s \ g p = h p \ p = s" - by (simp add: minsoldef) +lemma min_solD: "s \ g =\<^sub>M h \ g s = h s" + using min_sol_def by blast -lemma minsolI: "s \ \ \ g s = h s \ (\ s'. s' \np s \ g s' = h s' \ s' = s) \ s \ g =\<^sub>M h" - using minsoldef by blast +lemma min_solD': "s \ g =\<^sub>M h \ s \ \" + using min_sol_def by blast -lemma minsol_sym_iff: "s \ g =\<^sub>M h \ s \ h =\<^sub>M g" - unfolding minsoldef eq_commute[of "g _" "h _"] by blast +lemma min_solD_min: "s \ g =\<^sub>M h \ p \ \ \ p \p s \ g p = h p \ p = s" + by (simp add: min_sol_def) -lemma minsol_sym[sym]: "s \ g =\<^sub>M h \ s \ h =\<^sub>M g" - unfolding minsoldef eq_commute[of "g _"]. +lemma min_solI[intro]: "s \ \ \ g s = h s \ (\ s'. s'\p s \ s' \ \ \ g s' = h s' \ s' = s) \ s \ g =\<^sub>M h" + using min_sol_def by metis + +lemma min_sol_sym_iff: "s \ g =\<^sub>M h \ s \ h =\<^sub>M g" + unfolding min_sol_def eq_commute[of "g _" "h _"] by blast + +lemma min_sol_sym[sym]: "s \ g =\<^sub>M h \ s \ h =\<^sub>M g" + unfolding min_sol_def eq_commute[of "g _"]. lemma min_sol_prefE: - assumes "g r = h r" and "r \ \" + assumes "g r = h r" and "r \ \" obtains e where "e \ g =\<^sub>M h" and "e \p r" proof- - let ?P = "\ 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 \p r" - using take_is_prefix by blast - have "e \ \" - unfolding e_def using \r \ \\ by simp - note * = Least_le[of ?P "\<^bold>|r\<^bold>| - 1", unfolded Suc_minus[OF nemp_len[OF \r \ \\]] take_self, OF \g r = h r\, 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 \r \ \\]] in linarith) - - have min: "s \np e \ g s = h s \ s = e" for s - proof (rule ccontr) - assume "s \np e" and "g s = h s" and "s \ e" - have "\<^bold>|s\<^bold>| - 1 < n" - using \\<^bold>|e\<^bold>| = Suc n\ long_pref[OF npD[OF \s \np e\]] \s \ e\ - Suc_le_lessD nemp_le_len[OF npD'[OF \s \np e\], 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 \s \np e\]]] - using pref_trans[OF npD[OF \s \np e\] \e \p r\] using pref_take[of s r] by simp - from not_less_Least[of "\<^bold>|s\<^bold>| - 1" ?P, folded n_def this, OF \\<^bold>|s\<^bold>| - 1 < n\] - show False - using \g s = h s\ by blast + let ?min = "\ n. take n r \ \ \ g (take n r) = h (take n r)" + have "?min \<^bold>|r\<^bold>|" + using assms by force + define n where "n = (LEAST n. ?min n)" + define e where "e = take n r" + from Least_le[of ?min, folded n_def, OF \?min \<^bold>|r\<^bold>|\] + have "n = \<^bold>|e\<^bold>|" + unfolding e_def by simp + show thesis + proof (rule that) + show "e \p r" + unfolding e_def using take_is_prefix by blast + show "e \ g =\<^sub>M h" + proof (rule min_solI) + from LeastI[of ?min, OF \?min \<^bold>|r\<^bold>|\, folded n_def e_def] + show "e \ \" and "g e = h e" + by blast+ + show min: "s = e" if "s \p e" "s \ \" "g s = h s" for s + proof- + have "\<^bold>|s\<^bold>| \ \<^bold>|e\<^bold>|" + using pref_len[OF \s \p e\]. + hence "take \<^bold>|s\<^bold>| r = s" + using \s \p e\ pref_take unfolding e_def by fastforce + from not_less_Least[of "\<^bold>|s\<^bold>|" ?min, folded e_def n_def, unfolded this] + show "s = e" + using that leI long_pref unfolding \n = \<^bold>|e\<^bold>|\ by fast + qed + qed qed - - from LeastI[of ?P "\<^bold>|r\<^bold>| - 1", unfolded Suc_minus[OF nemp_len[OF \r \ \\]] take_self, OF \g r = h r\] - have "g e = h e" - unfolding e_def n_def. - from minsolI[OF \e \ \\, of g h, OF this min] - have "e \ g =\<^sub>M h" by blast - from that[OF this \e \p r\] - show thesis. qed subsection \Coincidence pairs\ definition coincidence_set :: "('a list \ 'b list) \ ('a list \ 'b list) \ ('a list \ 'a list) set" ("\") where "coincidence_set g h \ {(r,s). g r = h s}" lemma coin_set_eq: "(g \ fst)`(\ g h) = (h \ snd)`(\ g h)" unfolding coincidence_set_def comp_apply using Product_Type.Collect_case_prodD[of _ "\ x y. g x = h y"] image_cong by auto lemma coin_setD: "pair \ \ g h \ g (fst pair) = h (snd pair)" unfolding coincidence_set_def by force lemma coin_setD_iff: "pair \ \ g h \ g (fst pair) = h (snd pair)" unfolding coincidence_set_def by force -lemma coin_set_sym: "fst`(\ g h) = snd `(\ h g)" - unfolding coincidence_set_def - by (rule, rule, auto simp add: image_iff, metis) +lemma coin_set_sym: "fst`(\ g h) = snd `(\ h g)" + unfolding coincidence_set_def + by (rule set_eqI) (auto simp add: image_iff, metis) lemma coin_set_inter_fst: "(g \ fst)`(\ g h) = range g \ range h" proof show "(g \ fst) ` \ g h \ range g \ range h" proof fix x assume "x \ (g \ fst) ` \ g h" - then obtain pair where "x = g (fst pair)" and "pair \ \ g h" + then obtain pair where "x = g (fst pair)" and "pair \ \ g h" by force from this(1)[unfolded coin_setD[OF this(2)]] this(1) show "x \ range g \ range h" by blast qed next show "range g \ range h \ (g \ fst) ` \ g h" proof fix x assume "x \ range g \ range h" then obtain r s where "g r = h s" and "x = g r" by blast hence "(r,s) \ \ g h" unfolding coincidence_set_def by blast - thus "x \ (g \ fst) ` \ g h" + thus "x \ (g \ fst) ` \ g h" unfolding \x = g r\ by force qed qed lemmas coin_set_inter_snd = coin_set_inter_fst[unfolded coin_set_eq] definition minimal_coincidence :: "('a list \ 'b list) \ 'a list \ ('a list \ 'b list) \ 'a list \ bool" ("(_ _) =\<^sub>m (_ _)" [80,81,80,81] 51 ) where min_coin_def: "minimal_coincidence g r h s \ r \ \ \ s \ \ \ g r = h s \ (\ r' s'. r' \np r \ s' \np s \ g r' = h s' \ r' = r \ s' = s)" -definition min_coincidence_set :: "('a list \ 'b list) \ ('a list \ 'b list) \ ('a list \ 'a list) set" ("\\<^sub>m") +definition min_coincidence_set :: "('a list \ 'b list) \ ('a list \ 'b list) \ ('a list \ 'a list) set" ("\\<^sub>m") where "min_coincidence_set g h \ ({(r,s) . g r =\<^sub>m h s})" lemma min_coin_minD: "g r =\<^sub>m h s \ r' \np r \ s' \np s \ g r' = h s' \ r' = r \ s' = s" using min_coin_def by blast lemma min_coin_setD: "p \ \\<^sub>m g h \ g (fst p) =\<^sub>m h (snd p)" unfolding min_coincidence_set_def by force lemma min_coinD: "g r =\<^sub>m h s \ g r = h s" using min_coin_def by blast lemma min_coinD': "g r =\<^sub>m h s \ r \ \ \ s \ \" using min_coin_def by blast -lemma min_coin_sub: "\\<^sub>m g h \ \ g h" +lemma min_coin_sub: "\\<^sub>m g h \ \ g h" unfolding coincidence_set_def min_coincidence_set_def using min_coinD by blast -lemma min_coin_defI: assumes "r \ \" and "s \ \" and "g r = h s" and - "(\ r' s'. r' \np r \ s' \np s \ g r' = h s' \ r' = r \ s' = s)" +lemma min_coin_defI: assumes "r \ \" and "s \ \" and "g r = h s" and + "(\ r' s'. r' \np r \ s' \np s \ g r' = h s' \ r' = r \ 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 \ h s =\<^sub>m g r" - unfolding min_coin_def eq_commute[of "g _" "h _"] by blast +lemma min_coin_sym[sym]: "g r =\<^sub>m h s \ 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 \ h s =\<^sub>m g r" using min_coin_sym by auto -lemma min_coin_set_sym: "fst`(\\<^sub>m g h) = snd `(\\<^sub>m h g)" +lemma min_coin_set_sym: "fst`(\\<^sub>m g h) = snd `(\\<^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) + by (rule set_eqI, rule iffI) (simp_all add: image_iff min_coin_sym_iff) subsection \Basics\ locale two_morphisms = g: morphism g + h: morphism h for g h :: "'a list \ 'b list" begin lemma def_on_sings: assumes "\a. a \ set u \ g [a] = h [a]" shows "g u = h u" using assms -proof (induct u, simp) +proof (induct u) 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 +qed simp lemma def_on_sings_eq: assumes "\a. g [a] = h [a]" shows "g = h" using def_on_sings[OF assms] by (simp add: ext) lemma ims_prefs_comp: assumes "u \p u'" and "v \p v'" and "g u' \ h v'" shows "g u \ h v" using ruler_comp[OF g.pref_mono h.pref_mono, OF assms]. lemma ims_sufs_comp: assumes "u \s u'" and "v \s v'" and "g u' \\<^sub>s h v'" shows "g u \\<^sub>s h v" using suf_ruler_comp[OF g.suf_mono h.suf_mono, OF assms]. lemma ims_hd_eq_comp: assumes "u \ \" and "g u = h u" shows "g [hd u] \ h [hd u]" using ims_prefs_comp[OF hd_pref[OF \u \ \\] hd_pref[OF \u \ \\]] unfolding \g u = h u\ by blast lemma ims_last_eq_suf_comp: assumes "u \ \" and "g u = h u" shows "g [last u] \\<^sub>s h [last u]" using ims_sufs_comp[OF hd_pref[reversed, OF \u \ \\] hd_pref[reversed, OF \u \ \\]] unfolding \g u = h u\ using comp_refl[reversed] by blast lemma len_im_le: assumes "(\a. a \ set s \ \<^bold>|g [a]\<^bold>| \ \<^bold>|h [a]\<^bold>|)" shows "\<^bold>|g s\<^bold>| \ \<^bold>|h s\<^bold>|" using assms proof (induction s) case (Cons a s) have IH_prem: "\a. a \ set s \ \<^bold>|g [a]\<^bold>| \ \<^bold>|h [a]\<^bold>|" using Cons.prems by simp show "\<^bold>|g (a # s)\<^bold>| \ \<^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 "\a. a \ set s \ \<^bold>|g [a]\<^bold>| \ \<^bold>|h [a]\<^bold>|" and "b \ 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: "\a. a \ set s \ \<^bold>|g [a]\<^bold>| \ \<^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 \a = b\ using \\<^bold>|g [b]\<^bold>| < \<^bold>|h [b]\<^bold>|\ len_im_le[OF IH_prem] by (rule add_less_le_mono) next assume "a \ b" then have "b \ set s" using \b \ set (a # s)\ 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 \b \ set s\ \\<^bold>|g [b]\<^bold>| < \<^bold>|h [b]\<^bold>|\] by (rule add_le_less_mono) qed qed simp lemma solution_eq_len_eq: assumes "g s = h s" and "\a. a \ set s \ \<^bold>|g [a]\<^bold>| = \<^bold>|h [a]\<^bold>|" shows "\a. a \ set s \ g [a] = h [a]" using assms proof (induction s) case (Cons b s) have nemp: "b # s \ \" using list.distinct(2). from ims_hd_eq_comp[OF nemp \g (b # s) = h (b # s)\] 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 \g (b # s) = h (b # s)\ 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 \ set s \ g [a] = h [a]" for a. ultimately show "\a. a \ set (b # s) \ 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: +lemma min_solD_min_suf: assumes "sol \ g =\<^sub>M h" and "s \ \" "s \s sol" and "g s = h s" + shows "s = sol" +proof (rule ccontr) + assume "s \ sol" + from sufE[OF \s \s sol\] + obtain y where "sol = y \ s". + hence "y \ \" + using \s \ sol\ by force + have "g y = h y" + using min_solD[OF \sol \ g =\<^sub>M h\, unfolded \sol = y \ s\] + unfolding g.morph h.morph \g s = h s\ by blast + from min_solD_min[OF \sol \ g =\<^sub>M h\ \y \ \\ _ this] + have "y = sol" + using \sol = y \ s\ by blast + thus False + using \sol = y \ s\ \s \ \\ by fast +qed + +lemma min_sol_rev[reversal_rule]: assumes "s \ g =\<^sub>M h" shows "(rev s) \ (rev_map g) =\<^sub>M (rev_map h)" -proof (rule minsolI) - show "rev s \ \" - using minsolD'[OF \s \ g =\<^sub>M h\] by simp - show "rev_map g (rev s) = rev_map h (rev s)" - unfolding rev_map_def using minsolD[OF \s \ g =\<^sub>M h\] by auto -next - fix s' - assume "s' \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''\ rev s'" - using npD[OF \s' \np rev s\, unfolded pref_rev_suf_iff rev_rev_ident] by (auto simp add: suf_def) - hence "s'' \ s" - using npD'[OF \s' \np rev s\] by simp - have "g (rev s') = h (rev s')" - by (simp add: \g (rev s') = h (rev s')\) - hence "g s'' = h s''" - using minsolD[OF \s \ g =\<^sub>M h\, unfolded \s = s''\ rev s'\ h.morph g.morph] by simp - hence "s'' = \" - using \s'' \ s\ \s \ g =\<^sub>M h\[unfolded minsoldef] \s = s''\ rev s'\ by blast - thus "s' = rev s" - by (simp add: \s = s'' \ rev s'\) -qed + unfolding min_sol_def[of _ "rev_map g" "rev_map h", reversed] + using min_solD[OF assms] min_solD'[OF assms] min_solD_min_suf[OF assms] by blast lemma coin_set_lists_concat: "ps \ lists (\ g h) \ 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: "\snd `(\ g h)\ = snd `(\ g h)" +lemma coin_set_hull: "\snd `(\ g h)\ = snd `(\ g h)" proof (rule equalityI, rule subsetI) fix x assume "x \ \snd ` \ g h\" then obtain xs where "xs \ lists (snd ` \ g h)" and "concat xs = x" - using hull_concat_lists0 by blast + using hull_concat_lists0 by blast then obtain ps where "ps \ lists (\ 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) \concat xs = x\] show "x \ snd ` \ g h" unfolding coincidence_set_def by force -qed simp +qed simp lemma min_sol_sufE: - assumes "g r = h r" and "r \ \" + assumes "g r = h r" and "r \ \" obtains e where "e \ g =\<^sub>M h" and "e \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 \g r = h r\ \r \ \\] + from min_sol_prefE[of g r h, OF \g r = h r\ \r \ \\] obtain p where "p \ g =\<^sub>M h" and "p \p r". show thesis proof (cases "p = r", (use less.prems(1)[OF \p \ g =\<^sub>M h\] in fast)) assume "p \ r" from prefE[OF \p \p r\] obtain r' where "r = p \ r'". - have "g r' = h r'" - using \g r = h r\[unfolded \r = p \ r'\ g.morph h.morph minsolD[OF \p \ g =\<^sub>M h\] cancel]. - from \p \ r\ \r = p \ r'\ - have "r' \ \" by fast - from minsolD'[OF \p \ g =\<^sub>M h\] \r = p \ r'\ + have "g r' = h r'" + using \g r = h r\[unfolded \r = p \ r'\ g.morph h.morph min_solD[OF \p \ g =\<^sub>M h\] cancel]. + from \p \ r\ \r = p \ r'\ + have "r' \ \" by fast + from min_solD'[OF \p \ g =\<^sub>M h\] \r = p \ r'\ have "\<^bold>|r'\<^bold>| < \<^bold>|r\<^bold>|" by fastforce from less.hyps[OF this _ \g r' = h r'\ \r' \ \\] obtain e where "e \ g =\<^sub>M h" "e \s r'". - from less.prems(1)[OF this(1), unfolded \r = p \ r'\, OF suf_ext, OF this(2)] - show thesis. + from less.prems(1)[OF this(1), unfolded \r = p \ r'\, OF suf_ext, OF this(2)] + show thesis. qed qed qed lemma min_sol_primitive: assumes "sol \ g =\<^sub>M h" shows "primitive sol" proof (rule ccontr) - have "sol \ \" - using assms minsoldef by auto + have "sol \ \" + using assms min_sol_def by auto assume "\ primitive sol" - from not_prim_primroot_expE[OF this \sol\ \\] - obtain k where "(\ sol)\<^sup>@(Suc (Suc k)) = sol". - with minsolD[OF assms] + from not_prim_primroot_expE[OF this] + obtain k where "(\ sol)\<^sup>@k = sol" "2 \ k". + hence "0 < k" by linarith + note min_solD[OF assms] have "g (\ sol) = h (\ sol)" - using Suc_pow_eq_eq g.pow_morph h.pow_morph by metis + by (rule pow_eq_eq[OF _ \0 < k\]) + (unfold g.pow_morph[of "\ sol" k, symmetric] h.pow_morph[of "\ sol" k, symmetric] \(\ sol)\<^sup>@k = sol\, fact) thus False - using \\ primitive sol\ \sol \ \\ assms minsolD_min prim_primroot_conv by blast + using \\ primitive sol\ min_solD_min[OF \sol \ g =\<^sub>M h\ primroot_nemp primroot_pref] \sol \ \\ + unfolding prim_primroot_conv[OF \sol \ \\, symmetric] by blast qed +lemma prim_sol_two_sols: + assumes "g u = h u" and "\ u \ g =\<^sub>M h" and "primitive u" + obtains s1 s2 where "s1 \ g =\<^sub>M h" and "s2 \ g =\<^sub>M h" and "s1 \ s2" +proof- + show thesis + using assms + proof (induction "\<^bold>|u\<^bold>|" arbitrary: u rule: less_induct) + case less + then show ?case + proof- + obtain s1 where "s1 \ g =\<^sub>M h" and "s1 \p u" + using min_sol_prefE[of g u h, OF \g u = h u\ prim_nemp[OF \primitive u\]]. + obtain u' where "s1 \ u' = u" + using \s1 \p u\ unfolding prefix_def by blast + have "g u' = h u'" + using \g u = h u\[folded \s1 \ u' = u\] + unfolding g.morph h.morph min_solD[OF \s1 \ g =\<^sub>M h\] cancel. + have "u' \ \" + using \s1 \ g =\<^sub>M h\ \\ u \ g =\<^sub>M h\[folded \s1 \ u' = u\] by force + obtain exp where "(\ u')\<^sup>@exp = u'" "0 < exp" + using primroot_expE. + from pow_eq_eq[of "g (\ u')" exp "h (\ u')", folded g.pow_morph h.pow_morph, unfolded this(1), OF \g u' = h u'\ \0 < exp\] + have "g (\ u') = h (\ u')". + have "\<^bold>|\ u'\<^bold>| < \<^bold>|u\<^bold>|" + using add_strict_increasing[OF nemp_pos_len [OF min_solD'[OF \s1 \ g =\<^sub>M h\]] primroot_len_le[OF \u' \ \\]] + unfolding lenarg[OF \s1 \ u' = u\, unfolded lenmorph]. + show thesis + proof (cases) + assume "\ u' \ g =\<^sub>M h" + have "\ u' \ s1" + using \primitive u\[folded \s1 \ u' = u\] comm_not_prim[OF primroot_nemp[OF \u' \ \\] \u' \ \\ comm_primroot[symmetric]] by fast + from that[OF \\ u' \ g =\<^sub>M h\ \s1 \ g =\<^sub>M h\ this] + show thesis. + next + assume "\ \ u' \ g =\<^sub>M h" + from less.hyps[OF \\<^bold>|\ u'\<^bold>| < \<^bold>|u\<^bold>|\ \g (\ u') = h (\ u')\ this] + show thesis + using \u' \ \\ by blast + qed + qed + qed +qed + +lemma prim_sols_two_sols: + assumes "g r = h r" and "g s = h s" and "primitive s" and "primitive r" and "r \ s" + obtains s1 s2 where "s1 \ g =\<^sub>M h" and "s2 \ g =\<^sub>M h" and "s1 \ s2" + using prim_sol_two_sols assms by blast + end subsection \Two nonerasing morphisms\ text \Minimal coincidence pairs and minimal solutions make good sense for nonerasing morphisms only.\ -locale two_nonerasing_morphisms = two_morphisms + - g: nonerasing_morphism g + - h: nonerasing_morphism h +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 \ u = \ \ v = \" by (metis g.emp_to_emp g.nonerasing h.emp_to_emp h.nonerasing) -lemma min_coin_rev: +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 \ \" and "rev s \ \" using min_coinD'[OF \g r =\<^sub>m h s\] by simp_all - show "rev_map g (rev r) = rev_map h (rev s)" + show "rev_map g (rev r) = rev_map h (rev s)" unfolding rev_map_def using min_coinD[OF \g r =\<^sub>m h s\] by auto -next - fix r' s' assume "r' \np rev r" "s' \np rev s" "rev_map g r' = rev_map h s'" - then obtain r'' s'' where "r''\ rev r' = r" and "s''\ rev s' = s" +next + fix r' s' assume "r' \np rev r" "s' \np rev s" "rev_map g r' = rev_map h s'" + then obtain r'' s'' where "r''\ rev r' = r" and "s''\ rev s' = s" using npD[OF \s' \np rev s\] npD[OF \r' \np rev r\] - unfolding pref_rev_suf_iff rev_rev_ident using sufD by (auto simp add: suf_def) + unfolding pref_rev_suf_iff rev_rev_ident using sufD by (auto simp add: suffix_def) have "g (rev r') = h (rev s')" - using \rev_map g r' = rev_map h s'\[unfolded rev_map_def rev_is_rev_conv] by simp - hence "g r'' = h s''" + using \rev_map g r' = rev_map h s'\[unfolded rev_map_def rev_is_rev_conv] by simp + hence "g r'' = h s''" using min_coinD[OF \g r =\<^sub>m h s\, folded \r''\ rev r' = r\ \s''\ rev s' = s\, unfolded g.morph h.morph] by simp have "r'' \ r" - using \r' \np rev r\ \r'' \ rev r' = r\ by auto + using \r' \np rev r\ \r'' \ rev r' = r\ by auto hence "r'' = \ \ s'' = \" using \g r =\<^sub>m h s\[unfolded min_coin_def nonempty_prefix_def] \r''\ rev r' = r\ \s''\ rev s' = s\ \g r'' = h s''\ by blast - hence "r'' = \" and "s'' = \" + hence "r'' = \" and "s'' = \" using noner_eq_emp_iff[OF \g r'' = h s''\] by force+ thus "r' = rev r \ s' = rev s" using \r''\ rev r' = r\ \s''\ rev s' = s\ by auto qed -lemma min_coin_pref_eq: +lemma min_coin_pref_eq: assumes "g e =\<^sub>m h f" and "g e' = h f'" and "e' \np e" and "f' \ f" shows "e' = e" and "f' = f" proof- note npD'[OF \e' \np e\] npD[OF \e' \np e\] have "f \ \" and "g e = h f" using \g e =\<^sub>m h f\[unfolded min_coin_def] by blast+ - have "f' \ \" - using \g e' = h f'\ \e' \ \\ by (simp add: noner_eq_emp_iff) - from g.pref_mono[OF \e' \p e\, unfolded \g e = h f\ \g e' = h f'\] + have "f' \ \" + using \g e' = h f'\ \e' \ \\ by (simp add: noner_eq_emp_iff) + from g.pref_mono[OF \e' \p e\, unfolded \g e = h f\ \g e' = h f'\] have "f' \p f" - using pref_compE[OF \f' \ f\] \f' \ \\ h.pref_mono h.pref_morph_pref_eq by metis + using pref_compE[OF \f' \ f\] \f' \ \\ h.pref_mono h.pref_morph_pref_eq by metis hence "f' \np f" using \f' \ \\ by blast with \g e =\<^sub>m h f\[unfolded min_coin_def] show "e' = e" and "f' = f" - using \g e' = h f'\ \e' \np e\ by blast+ -qed + using \g e' = h f'\ \e' \np e\ by blast+ +qed lemma min_coin_prefE: - assumes "g r = h s" and "r \ \" + assumes "g r = h s" and "r \ \" obtains e f where "g e =\<^sub>m h f" and "e \p r" and "f \p s" and "hd e = hd r" proof- define P where "P = (\ k. \ e f. g e = h f \ e \ \ \ e \p r \ f \p s \ \<^bold>|e\<^bold>| = k)" define d where "d = (LEAST k. P k)" obtain e f where "g e = h f" and "e \ \" and "e \p r" and "f \p s" and "\<^bold>|e\<^bold>| = d" using \g r = h s\ LeastI[of P "\<^bold>|r\<^bold>|"] P_def assms(2) d_def by blast hence "f \ \" - using noner_eq_emp_iff by blast + using noner_eq_emp_iff by blast have "r' \np e \ s' \np f \ g r' = h s' \ r' = e \ s' = f" for r' s' proof- - assume "r' \np e" and "s' \np f" and "g r' = h s'" - hence "P \<^bold>|r'\<^bold>|" + assume "r' \np e" and "s' \np f" and "g r' = h s'" + hence "P \<^bold>|r'\<^bold>|" unfolding P_def using \e \p r\ \f \p s\ npD'[OF \r' \np e\] pref_trans[OF npD[OF \r' \np e\] \e \p r\] pref_trans[OF npD[OF \s' \np f\] \f \p s\] by blast from Least_le[of P, OF this, folded \\<^bold>|e\<^bold>| = d\ d_def] have "r' = e" - using long_pref[OF npD[OF \r' \np e\]] by blast + using long_pref[OF npD[OF \r' \np e\]] by blast from \g e = h f\[folded this, unfolded \g r' = h s'\] this show ?thesis - using conjunct2[OF \s' \np f\[unfolded nonempty_prefix_def]] h.pref_morph_pref_eq + using conjunct2[OF \s' \np f\[unfolded nonempty_prefix_def]] h.pref_morph_pref_eq by simp qed hence "g e =\<^sub>m h f" unfolding min_coin_def using \e \ \\ \f \ \\ \g e = h f\ by blast from that[OF this \e \p r\ \f \p s\ pref_hd_eq[OF \e \p r\ \e \ \\]] show thesis. qed -lemma min_coin_dec: assumes "g e = h f" +lemma min_coin_dec: assumes "g e = h f" obtains ps where "concat (map fst ps) = e" and "concat (map snd ps) = f" and "\ p. p \ set ps \ 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 + then show ?case proof- show thesis proof (cases "e = \") assume "e = \" hence "f = \" using \g e = h f\ using noner_eq_emp_iff by auto from less.prems(1)[of \] \e = \\ \f = \\ show thesis by simp next assume "e \ \" - from min_coin_prefE[OF \g e = h f\ this] + from min_coin_prefE[OF \g e = h f\ 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 \ e\<^sub>2 = e" and "f\<^sub>1 \ f\<^sub>2 = f" and "e\<^sub>1 \ \" and "f\<^sub>1 \ \" using min_coinD' prefD by metis have "g e\<^sub>2 = h f\<^sub>2" using \g e = h f\[folded \e\<^sub>1 \ e\<^sub>2 = e\ \f\<^sub>1 \ f\<^sub>2 = f\, unfolded g.morph h.morph min_coinD[OF \g e\<^sub>1 =\<^sub>m h f\<^sub>1\] cancel]. have "\<^bold>|e\<^sub>2\<^bold>| < \<^bold>|e\<^bold>|" - using lenarg[OF \e\<^sub>1 \ e\<^sub>2 = e\] nemp_pos_len[OF \e\<^sub>1 \ \\] unfolding lenmorph by linarith + using lenarg[OF \e\<^sub>1 \ e\<^sub>2 = e\] nemp_pos_len[OF \e\<^sub>1 \ \\] unfolding lenmorph by linarith from less.hyps[OF \\<^bold>|e\<^sub>2\<^bold>| < \<^bold>|e\<^bold>|\ _ \g e\<^sub>2 = h f\<^sub>2\] obtain ps' where "concat (map fst ps') = e\<^sub>2" and "concat (map snd ps') = f\<^sub>2" and "\p. p \ set ps' \ g (fst p) =\<^sub>m h (snd p)" by blast - show thesis + 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 \concat (map fst ps') = e\<^sub>2\ \e\<^sub>1 \ e\<^sub>2 = e\ by simp show "concat (map snd ((e\<^sub>1, f\<^sub>1) # ps')) = f" using \concat (map snd ps') = f\<^sub>2\ \f\<^sub>1 \ f\<^sub>2 = f\ by simp show "\p. p \ set ((e\<^sub>1, f\<^sub>1) # ps') \ g (fst p) =\<^sub>m h (snd p)" using \\p. p \ set ps' \ g (fst p) =\<^sub>m h (snd p)\ \g e\<^sub>1 =\<^sub>m h f\<^sub>1\ by auto qed qed qed qed lemma min_coin_code: - assumes "xs \ lists (\\<^sub>m g h)" and "ys \ lists (\\<^sub>m g h)" and + assumes "xs \ lists (\\<^sub>m g h)" and "ys \ lists (\\<^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) +proof (induction xs ys rule: list_induct2') case (2 x xs) - then show ?case - using min_coin_setD[THEN min_coinD', of x g h] listsE[OF \x # xs \ lists (\\<^sub>m g h)\] by force + then show ?case + using min_coin_setD[THEN min_coinD', of x g h] listsE[OF \x # xs \ lists (\\<^sub>m g h)\] by force next case (3 y ys) then show ?case using min_coin_setD[of y g h, THEN min_coinD'] listsE[OF \y # ys \ lists (\\<^sub>m g h)\] by auto next - case (4 x xs y ys) + case (4 x xs y ys) then show ?case proof- - have "concat (map fst (x#xs)) = fst x \ concat (map fst xs)" + have "concat (map fst (x#xs)) = fst x \ concat (map fst xs)" "concat (map fst (y#ys)) = fst y \ concat (map fst ys)" - "concat (map snd (x#xs)) = snd x \ concat (map snd xs)" + "concat (map snd (x#xs)) = snd x \ concat (map snd xs)" "concat (map snd (y#ys)) = snd y \ concat (map snd ys)" - by auto - from eqd_comp[OF \concat (map fst (x#xs)) = concat (map fst (y#ys))\[unfolded this]] eqd_comp[OF \concat (map snd (x#xs)) = concat (map snd (y#ys))\[unfolded this]] + by auto + from eqd_comp[OF \concat (map fst (x#xs)) = concat (map fst (y#ys))\[unfolded this]] eqd_comp[OF \concat (map snd (x#xs)) = concat (map snd (y#ys))\[unfolded this]] have "fst x \ fst y" and "snd x \ 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 \y # ys \ lists (\\<^sub>m g h)\] in blast) (use min_coin_setD listsE[OF \x # xs \ lists (\\<^sub>m g h)\] in blast) from min_coin_pref_eq[OF this(1) min_coinD[OF this(2)] _ \snd x \ snd y\] min_coin_pref_eq[OF this(2) min_coinD[OF this(1)] _ pref_comp_sym[OF \snd x \ snd y\]] 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 \fst x \ fst y\] by metis+ + have "fst x = fst y" and "snd x = snd y" + using npI pref_compE[OF \fst x \ fst y\] 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 \ lists (\\<^sub>m g h)" "ys \ lists (\\<^sub>m g h)" + using "4.prems"(3-4) by fastforce+ + have "xs \ lists (\\<^sub>m g h)" "ys \ lists (\\<^sub>m g h)" using "4.prems"(1-2) by fastforce+ from "4.IH"(1)[OF this eq] prod_eqI[OF \fst x = fst y\ \snd x = snd y\] show "x # xs = y # ys" - by blast + by blast qed -qed +qed simp lemma coin_closed: "ps \ lists (\ g h) \ (concat (map fst ps), concat (map snd ps)) \ \ g h" unfolding coincidence_set_def by (induct ps, simp, auto simp add: g.morph h.morph) lemma min_coin_gen_snd: "\snd ` (\\<^sub>m g h)\ = snd `(\ g h)" proof show "\snd ` \\<^sub>m g h\ \ snd ` \ g h" proof fix x assume "x \ \snd ` \\<^sub>m g h\" then obtain xs where "xs \ lists (snd ` \\<^sub>m g h)" and "x = concat xs" using hull_concat_lists0 by blast then obtain ps where "ps \ lists (\\<^sub>m g h)" and "xs = map snd ps" unfolding lists_image image_iff by blast - from min_coin_sub coin_closed this(1) + from min_coin_sub coin_closed this(1) have "(concat (map fst ps), x) \ \ g h" unfolding \x = concat xs\ \xs = map snd ps\ by fast - thus "x \ snd ` \ g h" by force + thus "x \ snd ` \ g h" by force qed show "snd ` \ g h \ \snd ` \\<^sub>m g h\" proof fix x assume "x \ snd ` \ 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 "\p. p \ set ps \ g (fst p) =\<^sub>m h (snd p)" by metis thus "x \ \snd ` \\<^sub>m g h\" unfolding min_coincidence_set_def image_def by fastforce qed qed lemma min_coin_gen_fst: "\fst ` (\\<^sub>m g h)\ = fst `(\ g h)" - using two_nonerasing_morphisms.min_coin_gen_snd[folded coin_set_sym min_coin_set_sym, OF two_nonerasing_morphisms_swap]. + 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: +lemma min_coin_code_snd: assumes "code_morphism g" shows "code (snd ` (\\<^sub>m g h))" proof fix xs ys assume "xs \ lists (snd ` \\<^sub>m g h)" and "ys \ lists (snd ` \\<^sub>m g h)" then obtain psx psy where "psx \ lists (\\<^sub>m g h)" and "xs = map snd psx" and "psy \ lists (\\<^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 \psx \ lists (\\<^sub>m g h)\ \xs = map snd psx\ min_coin_sub[of g h] - coin_set_lists_concat by fastforce + coin_set_lists_concat by fastforce have eq2: "g (concat (map fst psy)) = h (concat ys)" using \psy \ lists (\\<^sub>m g h)\ \ys = map snd psy\ min_coin_sub[of g h] - coin_set_lists_concat by fastforce - assume "concat xs = concat ys" + 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 \code_morphism g\] by auto have "concat (map snd psx) = concat (map snd psy)" using \concat xs = concat ys\ \xs = map snd psx\ \ys = map snd psy\ by auto - from min_coin_code[OF \psx \ lists (\\<^sub>m g h)\ \psy \ lists (\\<^sub>m g h)\ \concat (map fst psx) = concat (map fst psy)\ this] + from min_coin_code[OF \psx \ lists (\\<^sub>m g h)\ \psy \ lists (\\<^sub>m g h)\ \concat (map fst psx) = concat (map fst psy)\ this] show "xs = ys" unfolding \xs = map snd psx\ \ys = map snd psy\ by blast qed -lemma min_coin_code_fst: +lemma min_coin_code_fst: "code_morphism h \ code (fst ` (\\<^sub>m g h))" - using two_nonerasing_morphisms.min_coin_code_snd[OF two_nonerasing_morphisms_swap, folded min_coin_set_sym]. + using two_nonerasing_morphisms.min_coin_code_snd[OF two_nonerasing_morphisms_swap, folded min_coin_set_sym]. -lemma min_coin_basis_snd: +lemma min_coin_basis_snd: assumes "code_morphism g" shows "\ (snd `(\ g h)) = snd ` (\\<^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 + using min_coin_code_snd[OF assms] code.code_is_basis by blast lemma min_coin_basis_fst: "code_morphism h \ \ (fst `(\ g h)) = fst ` (\\<^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 \ h" and "set u = UNIV" shows "\<^bold>|u\<^bold>| < \<^bold>|g u\<^bold>|" proof (rule ccontr) assume "\ \<^bold>|u\<^bold>| < \<^bold>|g u\<^bold>|" hence "\<^bold>|u\<^bold>| = \<^bold>|g u\<^bold>|" and "\<^bold>|u\<^bold>| = \<^bold>|h u\<^bold>|" - unfolding \g u = h u\ using h.im_len_le le_neq_implies_less by blast+ + unfolding \g u = h u\ 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] \set u = UNIV\ 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 \g u = h u\, THEN def_on_sings_eq, unfolded \set u = UNIV\, OF _ UNIV_I] by force - thus False using \g \ h\ by contradiction + thus False using \g \ h\ by contradiction qed end locale two_code_morphisms = g: code_morphism g + h: code_morphism h for g h :: "'a list \ 'b list" begin sublocale two_nonerasing_morphisms g h by unfold_locales -lemmas code_morphs = g.code_morphism_axioms h.code_morphism_axioms +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: "\ (h` (snd `(\ g h))) = h ` snd ` (\\<^sub>m g h)" "\ (g` (fst `(\ g h))) = g ` fst ` (\\<^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 ` \ g h", unfolded coin_set_hull] show "\ (h ` snd ` \ g h) = h ` snd ` \\<^sub>m g h" unfolding basis_morph_swap[OF code_morphs(2) code_morphs(2), of "snd ` \ 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 ` \ 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 ` \ g h", unfolded swap.coin_set_hull[folded coin_set_sym]] min_coin_basis_fst show "\ (g ` fst ` \ g h) = g ` fst ` \\<^sub>m g h" unfolding basis_morph_swap[OF code_morphs(1) code_morphs(1), of "fst ` \ g h", unfolded swap.coin_set_hull[folded coin_set_sym]] - unfolding min_coin_basis_fst[OF code_morphs(2)] + unfolding min_coin_basis_fst[OF code_morphs(2)] unfolding min_coin_gen_fst.. qed lemma range_inter_basis_snd: shows "\ (range g \ range h) = h ` (snd ` \\<^sub>m g h)" "\ (range g \ range h) = g ` (fst ` \\<^sub>m g h)" proof- show "\ (range g \ range h) = h ` (snd ` \\<^sub>m g h)" unfolding coin_set_inter_snd[folded image_comp, symmetric] using min_coin_im_basis(1). show "\ (range g \ range h) = g ` (fst ` \\<^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 \ (range g \ range h)" - unfolding range_inter_basis_snd +lemma range_inter_code: + shows "code \ (range g \ range h)" + unfolding range_inter_basis_snd thm morphism_on.inj_code_to_code - by (rule 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 \Two marked morphisms\ -locale two_marked_morphisms = two_nonerasing_morphisms + +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) + 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 \ g r = z' \ h s \ z \ g r' = z' \ h s' \ z \ g (r \\<^sub>p r') = z' \ h (s \\<^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 \p r'" and "g r =\<^sub>m h s" and "g r' =\<^sub>m h s'" +lemma comparable_min_sol_eq: assumes "r \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 \p s'" - using g.pref_mono[OF \r \p r'\] + have "s \p s'" + using g.pref_mono[OF \r \p r'\] h.pref_free_morph - unfolding min_coinD[OF \g r =\<^sub>m h s\] min_coinD[OF \g r' =\<^sub>m h s'\] by simp - thus "r = r'"and "s = s'" + unfolding min_coinD[OF \g r =\<^sub>m h s\] min_coinD[OF \g r' =\<^sub>m h s'\] by simp + thus "r = r'"and "s = s'" using \g r' =\<^sub>m h s'\[unfolded min_coin_def] min_coinD[OF \g r =\<^sub>m h s\] min_coinD'[OF \g r =\<^sub>m h s\] \r \p r'\ - by blast+ + 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' \ \" shows "e \p e'" and "f \p f'" proof- have "g (e \\<^sub>p e') = h (f \\<^sub>p f')" - using unique_continuation[of \ e \ f e' f', unfolded clean_emp, OF min_coinD[OF\g e =\<^sub>m h f\] \g e' = h f'\]. + using unique_continuation[of \ e \ f e' f', unfolded emp_simps, OF min_coinD[OF\g e =\<^sub>m h f\] \g e' = h f'\]. have "e \ \" using \g e =\<^sub>m h f\ min_coinD' by auto hence eq1: "e = [hd e] \ tl e" and eq2: "e' = [hd e'] \ tl e'" using \e' \ \\ by simp+ from lcp_ext_left[of "[hd e]" "tl e" "tl e'", folded eq1 eq2[folded \hd e = hd e'\]] have "e \\<^sub>p e' \ \" by force from this have "f \\<^sub>p f' \ \" using \g (e \\<^sub>p e') = h (f \\<^sub>p f')\ g.nonerasing h.emp_to_emp by force from npI[OF \e \\<^sub>p e' \ \\ lcp_pref] npI[OF \f \\<^sub>p f' \ \\ lcp_pref] show "e \p e'" and "f \p f'" - using min_coin_minD[OF assms(1) \e \\<^sub>p e' \np e\ \f \\<^sub>p f' \np f\ \g (e \\<^sub>p e') = h (f \\<^sub>p f')\, + using min_coin_minD[OF assms(1) \e \\<^sub>p e' \np e\ \f \\<^sub>p f' \np f\ \g (e \\<^sub>p e') = h (f \\<^sub>p f')\, 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 \ \" and "e' \ \" using \g e =\<^sub>m h f\ \g e' =\<^sub>m h f'\ min_coinD' by blast+ have "g e' = h f'" and "g e = h f" using \g e =\<^sub>m h f\ \g e' =\<^sub>m h f'\ min_coinD by blast+ - show "e = e'" and "f = f'" + show "e = e'" and "f = f'" using first_letter_determines[OF \g e =\<^sub>m h f\ \g e' = h f'\ \hd e = hd e'\ \e' \ \\] first_letter_determines[OF \g e' =\<^sub>m h f'\ \g e = h f\ \hd e = hd e'\[symmetric] \e \ \\] by force+ qed -definition pre_block :: "'a \ 'a list \ 'a list" +lemma first_letter_determines_sol: assumes "r \ g =\<^sub>M h" and "s \ g =\<^sub>M h" and "hd r = hd s" + shows "r = s" +proof- + have "r \\<^sub>p s \ \" + using nemp_lcp_distinct_hd[OF min_solD'[OF \r \ g =\<^sub>M h\] min_solD'[OF \s \ g =\<^sub>M h\]] \hd r = hd s\ + by blast + have "g r = h r" and "g s = h s" + using min_solD[OF \r \ g =\<^sub>M h\] min_solD[OF \s \ g =\<^sub>M h\]. + have "g (r \\<^sub>p s) = h (r \\<^sub>p s)" + unfolding \g r = h r\ \g s = h s\ g.marked_morph_lcp h.marked_morph_lcp.. + from min_solD_min[OF \r \ g =\<^sub>M h\ \r \\<^sub>p s \ \\ lcp_pref this] min_solD_min[OF \s \ g =\<^sub>M h\ \r \\<^sub>p s \ \\ lcp_pref' this] + show "r = s" by force +qed + +definition pre_block :: "'a \ 'a list \ 'a list" where "pre_block a = (THE p. (g (fst p) =\<^sub>m h (snd p)) \ hd (fst p) = a)" \ \@{term "pre_block a"} may not be a block, if no such exists\ definition blockP :: "'a \ bool" where "blockP a \ g (fst (pre_block a)) =\<^sub>m h (snd (pre_block a)) \ hd (fst (pre_block a)) = a" \ \Predicate: the @{term pre_block} of the letter @{term a} is indeed a block\ lemma pre_blockI: "g u =\<^sub>m h v \ pre_block (hd u) = (u,v)" unfolding pre_block_def -proof (rule the_equality, simp) +proof (rule the_equality) show "\p. g u =\<^sub>m h v \ g (fst p) =\<^sub>m h (snd p) \ hd (fst p) = hd u \ p = (u, v)" using first_letter_determines' by force -qed +qed simp -lemma blockI: assumes "g u =\<^sub>m h v" and "hd u = a" +lemma blockI: assumes "g u =\<^sub>m h v" and "hd u = a" shows "blockP a" proof- from pre_blockI[OF \g u =\<^sub>m h v\, unfolded \hd u = a\] show "blockP a" unfolding blockP_def using assms by simp qed lemma hd_im_comm_eq_aux: assumes "g w = h w" and "w \ \" and comm: "g\<^sup>\ (hd w) \ h\<^sup>\(hd w) = h\<^sup>\ (hd w) \ g\<^sup>\(hd w)" and len: "\<^bold>|g\<^sup>\ (hd w)\<^bold>| \ \<^bold>|h\<^sup>\(hd w)\<^bold>|" shows "g\<^sup>\ (hd w) = h\<^sup>\ (hd w)" proof(cases "w \ [hd w]*") assume "w \ [hd w]*" then obtain l where "w = [hd w]\<^sup>@l" unfolding root_def by metis from nemp_exp_pos[OF \w \ \\, of "[hd w]" l, folded this] have "l \ 0" - by fast + by fast from \g w = h w\ have "(g [hd w])\<^sup>@l = (h [hd w])\<^sup>@l" unfolding g.pow_morph[symmetric] h.pow_morph[symmetric] \w = [hd w]\<^sup>@l\[symmetric]. with \l \ 0\ have "g [hd w] = h [hd w]" - using pow_eq_eq by blast + using pow_eq_eq by blast thus "g\<^sup>\ (hd w) = h\<^sup>\ (hd w)" unfolding core_def. next assume "w \ [hd w]*" from distinct_letter_in_hd[OF this] obtain b l w' where "[hd w]\<^sup>@l \ [b] \ w' = w" and "b \ hd w" and "l \ 0". from commE[OF comm] obtain t m k where "g\<^sup>\ (hd w) = t\<^sup>@m" and "h\<^sup>\ (hd w) = t\<^sup>@k". have "\<^bold>|t\<^bold>| \ 0" and "t \ \" and "m \ 0" - using \g\<^sup>\ (hd w) = t\<^sup>@m\ g.core_nemp pow_zero[of t] by (fastforce, fastforce, metis) + using \g\<^sup>\ (hd w) = t\<^sup>@m\ g.core_nemp pow_zero[of t] by (fastforce, fastforce, metis) with lenarg[OF \g\<^sup>\ (hd w) = t\<^sup>@m\] lenarg[OF \h\<^sup>\ (hd w) = t\<^sup>@k\] have "m \ k" unfolding pow_len lenmorph using len by auto have "m = k" proof(rule ccontr) assume "m \ k" hence "m < k" using \m \ k\ by simp - have "k*l-m*l \ 0" + have "0 < k*l-m*l" using \m < k\ \l \ 0\ by force have "g w = t\<^sup>@(m*l) \ g [b] \ g w'" unfolding arg_cong[OF \[hd w]\<^sup>@l \ [b] \ w' = w\, of g, symmetric] g.morph g.pow_morph \g\<^sup>\ (hd w) = t\<^sup>@m\[unfolded core_def] pow_mult[symmetric].. moreover have "h w = t\<^sup>@(k*l) \ h [b] \ h w'" unfolding arg_cong[OF \[hd w]\<^sup>@l \ [b] \ w' = w\, of h, symmetric] h.morph h.pow_morph \h\<^sup>\ (hd w) = t\<^sup>@k\[unfolded core_def] pow_mult[symmetric].. - ultimately have "g [b] \ g w' = t\<^sup>@(k*l-m*l) \ h [b] \ h w'" + ultimately have *: "g [b] \ g w' = t\<^sup>@(k*l-m*l) \ h [b] \ h w'" using \g w = h w\ pop_pow_cancel[OF _ mult_le_mono1[OF \m \ k\]] - unfolding g.morph[symmetric] h.morph[symmetric] by metis - hence "hd t = hd (g [b])" - using \t \ \\ \k * l - m * l \ 0\ h.emp_to_emp h.sing_to_nemp hd_append2 hd_pow noner_eq_emp_iff nonzero_pow_emp by metis + unfolding g.morph[symmetric] h.morph[symmetric] by metis + have "t\<^sup>@(k*l-m*l) \ \" + using gr_implies_not0[OF \0 < k * l - m * l\] unfolding nemp_emp_pow[OF \t \ \\]. + have "hd (t\<^sup>@(k*l-m*l)) = hd t" + using hd_append2[OF \t \ \\] unfolding pow_pos[OF \0 < k * l - m * l\]. + have "hd t = hd (g [b])" + using hd_append2[OF g.sing_to_nemp[of b], of "g w'"] + unfolding hd_append2[of _ "h [b] \ h w'", OF \t\<^sup>@(k*l-m*l) \ \\, folded *] \hd (t\<^sup>@(k*l-m*l)) = hd t\. have "hd t = hd (g [hd w])" using g.hd_im_hd_hd[OF \w \ \\, unfolded \g\<^sup>\ (hd w) = t \<^sup>@ m\[unfolded core_def]] - hd_append2[OF \t \ \\, of "t\<^sup>@(m-1)", unfolded pow_Suc, folded pow_Suc[of t "m-1", unfolded Suc_minus[OF \m \ 0\]]] + hd_append2[OF \t \ \\, of "t\<^sup>@(m-1)", unfolded pow_Suc, folded pow_Suc[of t "m-1", unfolded Suc_minus[OF \m \ 0\]]] g.hd_im_hd_hd[OF \w \ \\] by force thus False unfolding \hd t = hd (g [b])\ using \b \ hd w\ g.marked_morph by blast qed show "g\<^sup>\ (hd w) = h\<^sup>\ (hd w)" unfolding \g\<^sup>\ (hd w) = t\<^sup>@m\ \h\<^sup>\ (hd w) = t\<^sup>@k\ \m = k\.. qed - + lemma hd_im_comm_eq: assumes "g w = h w" and "w \ \" and comm: "g\<^sup>\ (hd w) \ h\<^sup>\(hd w) = h\<^sup>\ (hd w) \ g\<^sup>\(hd w)" shows "g\<^sup>\ (hd w) = h\<^sup>\ (hd w)" proof- interpret swap: two_marked_morphisms h g by unfold_locales - show "g\<^sup>\ (hd w) = h\<^sup>\ (hd w)" + show "g\<^sup>\ (hd w) = h\<^sup>\ (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 \ \" shows "blockP (hd u)" using min_coin_prefE[OF assms] block_ex by metis \ \Successor morphisms\ -definition suc_fst where "suc_fst \ \ x. concat(map (\ y. fst (pre_block y)) x)" -definition suc_snd where "suc_snd \ \ x. concat(map (\ y. snd (pre_block y)) x)" +definition suc_fst where "suc_fst \ \ x. concat(map (\ y. fst (pre_block y)) x)" +definition suc_snd where "suc_snd \ \ x. concat(map (\ y. snd (pre_block y)) x)" lemma blockP_D: "blockP a \ 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 \ hd (suc_fst [a]) = a" unfolding blockP_def suc_fst_def by simp - -abbreviation "blocks \ \ (\ a. a \ set \ \ blockP a)" + +abbreviation "blocks \ \ (\ a. a \ set \ \ 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>\ (hd (suc_snd [a]))) = hd (g\<^sup>\ a)" proof- from hd_tlE[OF conjunct2[OF min_coinD'[OF blockP_D[OF \blockP a\]]]] obtain b where "hd (suc_snd [a]) = b" by blast have "suc_fst [a] \ \" and "suc_snd [a] \ \" using min_coinD'[OF blockP_D[OF \blockP a\]] by blast+ - from g.hd_im_hd_hd[OF this(1)] h.hd_im_hd_hd[OF this(2)] + from g.hd_im_hd_hd[OF this(1)] h.hd_im_hd_hd[OF this(2)] have "hd (h\<^sup>\ (hd (suc_snd [a]))) = hd (g\<^sup>\ (hd (suc_fst [a])))" - unfolding core_def min_coinD[OF blockP_D[OF \blockP a\]] by argo + unfolding core_def min_coinD[OF blockP_D[OF \blockP a\]] 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" + 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 \ \ g (suc_fst \) = h (suc_snd \)" -proof (induct \, simp) +proof (induct \) case (Cons a \) have "blocks \" and "blockP a" using \blocks (a # \)\ by simp_all from Cons.hyps[OF this(1)] show ?case unfolding sucs.g.pop_hd[of a \] sucs.h.pop_hd[of a \] g.morph h.morph - using min_coinD[OF blockP_D, OF \blockP a\] by simp -qed + using min_coinD[OF blockP_D, OF \blockP a\] by simp +qed simp -lemma suc_eq': assumes "\ a. blockP a" shows "g(suc_fst w) = h(suc_snd w)" - by (simp add: assms blocks_eq) +lemma suc_eq': assumes "\ a. blockP a" shows "g(suc_fst w) = h(suc_snd w)" + by (simp add: assms blocks_eq) -lemma suc_eq: assumes all_blocks: "\ a. blockP a" shows "g \ suc_fst = h \ suc_snd" - using suc_eq'[OF assms] by fastforce +lemma suc_eq: assumes all_blocks: "\ a. blockP a" shows "g \ suc_fst = h \ suc_snd" + using suc_eq'[OF assms] by fastforce lemma block_eq: "blockP a \ g (suc_fst [a]) = h (suc_snd [a])" - using blockP_D min_coinD by blast + using blockP_D min_coinD by blast lemma blocks_inj_suc: assumes "blocks \" shows "inj_on suc_fst\<^sup>\ (set \)" - unfolding inj_on_def core_def using blockP_D_hd[OF \blocks \\[rule_format]] + unfolding inj_on_def core_def using blockP_D_hd[OF \blocks \\[rule_format]] by metis lemma blocks_inj_suc': assumes "blocks \" shows "inj_on suc_snd\<^sup>\ (set \)" using g.marked_core blockP_D_hd_hd[OF \blocks \\[rule_format]] - unfolding inj_on_def core_def by metis + unfolding inj_on_def core_def by metis lemma blocks_marked_code: assumes "blocks \" shows "marked_code (suc_fst\<^sup>\ `(set \))" proof - show "\u. u \ suc_fst\<^sup>\ ` set \ \ u \ \" - unfolding core_def using min_coinD'[OF blockP_D[OF \blocks \\[rule_format]]] by fast+ + show "\ \ suc_fst\<^sup>\ ` set \" + unfolding core_def image_iff using min_coinD'[OF blockP_D[OF \blocks \\[rule_format]]] by fastforce show "\u v. u \ suc_fst\<^sup>\ ` set \ \ v \ suc_fst\<^sup>\ ` set \ \ hd u = hd v \ u = v" using blockP_D_hd[OF \blocks \\[rule_format]] unfolding core_def by fastforce qed lemma blocks_marked_code': assumes all_blocks: "\ a. a \ set \ \ blockP a" shows "marked_code (suc_snd\<^sup>\ `(set \))" proof - show "\u. u \ suc_snd\<^sup>\ ` set \ \ u \ \" - unfolding core_def using min_coinD'[OF all_blocks[THEN blockP_D]] by fast+ + show "\ \ suc_snd\<^sup>\ ` set \" + unfolding core_def image_iff using min_coinD'[OF all_blocks[THEN blockP_D]] by fastforce show "u = v" if "u \ suc_snd\<^sup>\ ` set \" and "v \ suc_snd\<^sup>\ ` set \" and "hd u = hd v" for u v proof- obtain a b where "u = suc_snd [a]" and "v = suc_snd [b]" and "a \ set \" and "b \ set \" - using \v \ suc_snd\<^sup>\ ` set \\ \u \ suc_snd\<^sup>\ ` set \\ unfolding core_def by fast+ - from g.marked_core[of a b, + using \v \ suc_snd\<^sup>\ ` set \\ \u \ suc_snd\<^sup>\ ` set \\ unfolding core_def by fast+ + from g.marked_core[of a b, folded blockP_D_hd_hd[OF all_blocks, OF \a \ set \\] blockP_D_hd_hd[OF all_blocks, OF \b \ set \\] this(1-2) \hd u = hd v\,OF refl] show "u = v" - unfolding \u = suc_snd [a]\ \v = suc_snd [b]\ by blast + unfolding \u = suc_snd [a]\ \v = suc_snd [b]\ by blast qed qed lemma sucs_marked_morphs: assumes all_blocks: "\ a. blockP a" shows "two_marked_morphisms suc_fst suc_snd" proof show "hd (suc_fst\<^sup>\ a) = hd (suc_fst\<^sup>\ b) \ a = b" for a b using blockP_D_hd[OF all_blocks] unfolding core_def by force show "hd (suc_snd\<^sup>\ a) = hd (suc_snd\<^sup>\ b) \ 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 = \ \ w = \" for w - using assms blockP_D min_coinD' sucs.g.noner_sings_conv by blast + using assms blockP_D min_coinD' sucs.g.noner_sings_conv by blast show "suc_snd w = \ \ w = \" for w - using blockP_D[OF assms(1), THEN min_coinD'] sucs.h.noner_sings_conv by blast + 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 } \ 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 } \ 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]]. + 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 \ where "suc_fst \ = e" and "suc_snd \ = f" and "blocks \" +lemma block_decomposition: assumes "g e = h f" + obtains \ where "suc_fst \ = e" and "suc_snd \ = f" and "blocks \" using assms proof (induct "\<^bold>|e\<^bold>|" arbitrary: e f thesis rule: less_induct) case less show ?case proof (cases "e = \") assume "e = \" - hence "f = \" + hence "f = \" using less.hyps empty_sol[OF \g e = h f\] by blast - hence "suc_fst \ = e" and "suc_snd \ = f" + hence "suc_fst \ = e" and "suc_snd \ = f" unfolding suc_fst_def suc_snd_def by (simp add: \e = \\)+ from less.prems(1)[OF this] show thesis - by simp + by simp next assume "e \ \" from min_coin_prefE[OF \g e = h f\ 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\e\<^sub>2 = e" and "f\<^sub>1\f\<^sub>2 = f" and "e\<^sub>1 \ \" and "f\<^sub>1 \ \" by (metis min_coinD' prefD) from \g e = h f\[folded \e\<^sub>1\e\<^sub>2 = e\ \f\<^sub>1\f\<^sub>2 = f\, unfolded g.morph h.morph] have "g e\<^sub>2 = h f\<^sub>2" using min_coinD[OF \g e\<^sub>1 =\<^sub>m h f\<^sub>1\] by simp - have "\<^bold>|e\<^sub>2\<^bold>| < \<^bold>|e\<^bold>|" + have "\<^bold>|e\<^sub>2\<^bold>| < \<^bold>|e\<^bold>|" using \e\<^sub>1\e\<^sub>2 = e\ \e\<^sub>1 \ \\ by auto - from less.hyps[OF this _ \g e\<^sub>2 = h f\<^sub>2\] + from less.hyps[OF this _ \g e\<^sub>2 = h f\<^sub>2\] obtain \' where "suc_fst \' = e\<^sub>2" and "suc_snd \' = f\<^sub>2" and "blocks \'". have "suc_fst [hd e] = e\<^sub>1" and "suc_snd [hd e] = f\<^sub>1" using suc_morph_sings \e\<^sub>1 \ e\<^sub>2 = e\ \g e\<^sub>1 =\<^sub>m h f\<^sub>1\ \e\<^sub>1 \ \\ by auto hence "suc_fst (hd e # \') = e" and "suc_snd (hd e # \') = f" - using \e\<^sub>1 \ e\<^sub>2 = e\ \f\<^sub>1 \ f\<^sub>2 = f\ - unfolding hd_word[of "hd e" \'] sucs.g.morph sucs.h.morph \suc_fst \' = e\<^sub>2\ \suc_snd \' = f\<^sub>2\ \suc_fst [hd e] = e\<^sub>1\ \suc_snd [hd e] = f\<^sub>1\ by force+ + using \e\<^sub>1 \ e\<^sub>2 = e\ \f\<^sub>1 \ f\<^sub>2 = f\ + unfolding hd_word[of "hd e" \'] sucs.g.morph sucs.h.morph \suc_fst \' = e\<^sub>2\ \suc_snd \' = f\<^sub>2\ \suc_fst [hd e] = e\<^sub>1\ \suc_snd [hd e] = f\<^sub>1\ by force+ have "blocks (hd e # \')" - using \blocks \'\ \e\<^sub>1 \ e\<^sub>2 = e\ \e\<^sub>1 \ \\ \g e\<^sub>1 =\<^sub>m h f\<^sub>1\ block_ex by force + using \blocks \'\ \e\<^sub>1 \ e\<^sub>2 = e\ \e\<^sub>1 \ \\ \g e\<^sub>1 =\<^sub>m h f\<^sub>1\ block_ex by force from less.prems(1)[OF _ _ this] show thesis by (simp add: \suc_fst (hd e # \') = e\ \suc_snd (hd e # \') = f\) qed -qed +qed lemma block_decomposition_unique: assumes "g e = h f" and "suc_fst \ = e" and "suc_fst \' = e" and "blocks \" and "blocks \'" shows "\ = \'" proof- let ?C = "suc_fst\<^sup>\`(set (\ \ \'))" have "blocks (\ \ \')" - using \blocks \\ \blocks \'\ by auto + using \blocks \\ \blocks \'\ by auto interpret marked_code ?C by (rule blocks_marked_code) (simp add: \blocks (\ \ \')\) have "inj_on suc_fst\<^sup>\ (set (\ \ \'))" - using \blocks (\ \ \')\ blocks_inj_suc by blast + using \blocks (\ \ \')\ blocks_inj_suc by blast from sucs.g.code_set_morph[OF code_axioms this \suc_fst \ = e\[folded \suc_fst \' = e\]] show "\ = \'". qed lemma block_decomposition_unique': assumes "g e = h f" and "suc_snd \ = f" and "suc_snd \' = f" and "blocks \" and "blocks \'" shows "\ = \'" proof- - have "suc_fst \ = e" and "suc_fst \' = e" - using assms blocks_eq g.code_morph_code by presburger+ - from block_decomposition_unique[OF assms(1) this assms(4-5)] + have "suc_fst \ = e" and "suc_fst \' = e" + using assms blocks_eq g.code_morph_code by presburger+ + from block_decomposition_unique[OF assms(1) this assms(4-5)] show "\ = \'". qed lemma comm_sings_block: assumes "g[a] \ h[b] = h[b] \ 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>| \ \" 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 \p [a] \<^sup>@ \<^bold>|h [b]\<^bold>|" and "f \p [b] \<^sup>@ \<^bold>|g [a]\<^bold>|" + obtain e f where "g e =\<^sub>m h f" and "e \p [a] \<^sup>@ \<^bold>|h [b]\<^bold>|" and "f \p [b] \<^sup>@ \<^bold>|g [a]\<^bold>|" using min_coin_prefE[OF comm_common_power[OF assms,folded g.pow_morph h.pow_morph] \[a] \<^sup>@ \<^bold>|h [b]\<^bold>| \ \\, of thesis] by blast note e = pref_sing_pow[OF \e \p [a] \<^sup>@ \<^bold>|h [b]\<^bold>|\] note f = pref_sing_pow[OF \f \p [b] \<^sup>@ \<^bold>|g [a]\<^bold>|\] - from min_coinD'[OF \g e =\<^sub>m h f\] - have exps: "\<^bold>|e\<^bold>| = Suc (\<^bold>|e\<^bold>| - 1)" "\<^bold>|f\<^bold>| = Suc (\<^bold>|f\<^bold>| - 1)" + from min_coinD'[OF \g e =\<^sub>m h f\] + 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 \e = [a] \<^sup>@ \<^bold>|e\<^bold>|\[unfolded pow_Suc[of "[a]" "\<^bold>|e\<^bold>| - 1", folded \\<^bold>|e\<^bold>| = Suc (\<^bold>|e\<^bold>| - 1)\], 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 \g e =\<^sub>m h f\, unfolded this] e f exps - show thesis + using \e = [a] \<^sup>@ \<^bold>|e\<^bold>|\[unfolded pow_Suc[of "[a]" "\<^bold>|e\<^bold>| - 1", folded \\<^bold>|e\<^bold>| = Suc (\<^bold>|e\<^bold>| - 1)\], 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 \g e =\<^sub>m h f\, unfolded this] e f exps + show thesis by metis qed \ \a variant of successor morphisms: target alphabet encoded to be the same as for original morphisms\ definition sucs_encoding where "sucs_encoding = (\ a. hd (g [a]))" definition sucs_decoding where "sucs_decoding = (\ a. SOME c. hd (g[c]) = a)" lemma sucs_encoding_inv: "sucs_decoding \ 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) - + by (rule ext) + (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)" +lemma map_encoding_inj: "inj (map sucs_encoding)" using encoding_inj by simp definition suc_fst' where "suc_fst' = (map sucs_encoding) \ suc_fst" definition suc_snd' where "suc_snd' = (map sucs_encoding) \ suc_snd" lemma encoded_sucs_eq_conv: "suc_fst w = suc_snd w' \ 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 \ suc_fst' = suc_snd'" - unfolding suc_fst'_def suc_snd'_def using inj_comp_eq[OF map_encoding_inj] by blast + unfolding suc_fst'_def suc_snd'_def using inj_comp_eq[OF map_encoding_inj] by blast lemma encoded_sucs: assumes "\ 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) \ 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) \ 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) \ suc_fst" + interpret nonerasing_morphism "(map sucs_encoding) \ 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) \ 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) \ suc_fst" proof show "hd ((map sucs_encoding \ suc_fst)\<^sup>\ a) = hd ((map sucs_encoding \ suc_fst)\<^sup>\ b) \ 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. + unfolding blockP_D_hd[OF assms] using g.marked_morph. qed - interpret marked_morphism "(map sucs_encoding) \ suc_snd" + interpret marked_morphism "(map sucs_encoding) \ suc_snd" proof show "hd ((map sucs_encoding \ suc_snd)\<^sup>\ a) = hd ((map sucs_encoding \ suc_snd)\<^sup>\ b) \ 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) \ suc_fst) ((map sucs_encoding) \ 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 +end 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,503 +1,530 @@ (* 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\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\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\.\ +It is also known as the Fine and Wilf theorem due to its authors @{cite FineWilf}.\ text\ -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]}. +If we relax the requirement to @{term "p + q"}, then the claim becomes easy, and it is proved in @{theory Combinatorics_Words.CoWBasic} as @{term two_pers_root}: @{thm[names_long] two_pers_root[no_vars]}. \ theorem per_lemma_relaxed: assumes "period w p" and "period w q" and "p + q \ \<^bold>|w\<^bold>|" shows "(take p w)\(take q w) = (take q w)\(take p w)" using two_pers_root[OF \period w p\[unfolded period_def[of w p]] - \period w q\[unfolded period_def[of w q]], unfolded - take_len[OF add_leD1[OF \p + q \ \<^bold>|w\<^bold>|\]] - take_len[OF add_leD2[OF \p + q \ \<^bold>|w\<^bold>|\]], OF \p + q \ \<^bold>|w\<^bold>|\]. + \period w q\[unfolded period_def[of w q]], unfolded + take_len[OF add_leD1[OF \p + q \ \<^bold>|w\<^bold>|\]] + take_len[OF add_leD2[OF \p + q \ \<^bold>|w\<^bold>|\]], OF \p + q \ \<^bold>|w\<^bold>|\]. text\Also in terms of the numeric period:\ thm two_periods section \Main claim\ text\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. \ + theorem per_lemma_comm: - assumes "w \p r \ w" and "w \p s \ w" - and len: "\<^bold>|s\<^bold>| + \<^bold>|r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|r\<^bold>|) \ \<^bold>|w\<^bold>|" - shows "s \ r = r \ s" + assumes "w \p r \ w" and "w \p s \ w" + and len: "\<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| - (gcd \<^bold>|r\<^bold>| \<^bold>|s\<^bold>|) \ \<^bold>|w\<^bold>|" + shows "r \ s = s \ r" 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 = \" | (short) "\<^bold>|r\<^bold>| < \<^bold>|s\<^bold>|" | (step) "s \ \ \ \<^bold>|s\<^bold>| \ \<^bold>|r\<^bold>|" by force - then show ?case + then show ?case proof (cases) - case (empty) - thus "s \ r = r \ s" by fastforce + case (empty) + thus "r \ s = s \ r" by fastforce next case (short) - thus "s \ r = r \ s" - using "less.hyps"[OF _ \ w \p s \ w\ \ w \p r \ w\ - \\<^bold>|s\<^bold>| + \<^bold>|r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|r\<^bold>|) \ \<^bold>|w\<^bold>|\[unfolded gcd.commute[of "\<^bold>|s\<^bold>|"] add.commute[of "\<^bold>|s\<^bold>|"]]] by fastforce + thus "r \ s = s \ r" + using "less.hyps"[OF _ \ w \p s \ w\ \ w \p r \ w\ + \\<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| - (gcd \<^bold>|r\<^bold>| \<^bold>|s\<^bold>|) \ \<^bold>|w\<^bold>|\[unfolded gcd.commute[of "\<^bold>|r\<^bold>|"] add.commute[of "\<^bold>|r\<^bold>|"]]] by fastforce next case (step) hence "s \ \" and "\<^bold>|s\<^bold>| \ \<^bold>|r\<^bold>|" by blast+ - from le_add_diff[OF gcd_le2_nat[OF \s \ \\[folded length_0_conv], of "\<^bold>|r\<^bold>|"], unfolded gcd.commute[of "\<^bold>|r\<^bold>|"]] - have "\<^bold>|r\<^bold>| \ \<^bold>|w\<^bold>|" - using \\<^bold>|s\<^bold>| + \<^bold>|r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|r\<^bold>|) \ \<^bold>|w\<^bold>|\ order.trans by fast + from le_add_diff[OF gcd_le2_nat[OF \s \ \\[folded length_0_conv], of "\<^bold>|r\<^bold>|"], unfolded gcd.commute[of "\<^bold>|r\<^bold>|"], of "\<^bold>|r\<^bold>|"] + have "\<^bold>|r\<^bold>| \ \<^bold>|w\<^bold>|" + using \\<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| - (gcd \<^bold>|r\<^bold>| \<^bold>|s\<^bold>|) \ \<^bold>|w\<^bold>|\[unfolded gcd.commute[of "\<^bold>|r\<^bold>|"] add.commute[of "\<^bold>|r\<^bold>|"]] order.trans by blast hence "\<^bold>|s\<^bold>| \ \<^bold>|w\<^bold>|" using \\<^bold>|s\<^bold>| \ \<^bold>|r\<^bold>|\ order.trans by blast - from pref_prod_long[OF \w \p s \ w\ this] + from pref_prod_long[OF \w \p s \ w\ this] have "s \p w". - - obtain w' where "s \ w' = w" and "\<^bold>|w'\<^bold>| < \<^bold>|w\<^bold>|" - using \s \ \\ \s \p w\[unfolded prefix_def] + + obtain w' where "s \ w' = w" and "\<^bold>|w'\<^bold>| < \<^bold>|w\<^bold>|" + using \s \ \\ \s \p w\[unfolded prefix_def] by force have "w' \p w" using \w \p s \ w\ unfolding \s \ w' = w\[symmetric] pref_cancel_conv. from this[folded \s \ w' = w\] have "w' \p s\w'". have "s \p r" using pref_prod_le[OF prefix_order.trans[OF \s \p w\ \w \p r \ w\] \\<^bold>|s\<^bold>| \ \<^bold>|r\<^bold>|\]. hence "w' \p (s\\<^sup>>r) \ w'" - using \w \p r \ w\ \s \ w' = w\ pref_prod_pref[OF _ \w' \p w\, of "s\\<^sup>>r"] + using \w \p r \ w\ \s \ w' = w\ pref_prod_pref[OF _ \w' \p w\, of "s\\<^sup>>r"] unfolding prefix_def by fastforce - have ind_len: "\<^bold>|s\<^bold>| + \<^bold>|s\\<^sup>>r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|s\\<^sup>>r\<^bold>|) \ \<^bold>|w'\<^bold>|" - using \\<^bold>|s\<^bold>| + \<^bold>|r\<^bold>| - (gcd \<^bold>|s\<^bold>| \<^bold>|r\<^bold>|) \ \<^bold>|w\<^bold>|\[folded \s \ w' = w\] - unfolding pref_gcd_lq[OF \s \p r\] lenmorph lq_len[OF \s \p r\] by force + have ind_len: "\<^bold>|s\\<^sup>>r\<^bold>| + \<^bold>|s\<^bold>| - (gcd \<^bold>|s\\<^sup>>r\<^bold>| \<^bold>|s\<^bold>|) \ \<^bold>|w'\<^bold>|" + using \\<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| - (gcd \<^bold>|r\<^bold>| \<^bold>|s\<^bold>|) \ \<^bold>|w\<^bold>|\[folded \s \ w' = w\] + unfolding pref_gcd_lq[OF \s \p r\, unfolded gcd.commute[of "\<^bold>|s\<^bold>|"]] lenmorph lq_short_len[OF \s \p r\, unfolded add.commute[of "\<^bold>|s\<^bold>|"]] by force - have "s \ s\\<^sup>>r = s\\<^sup>>r \ s" - using "less.hyps"[OF _ \w' \p (s\\<^sup>>r) \ w'\ \w' \p s \ w'\ ind_len] \s \p r\ \\<^bold>|w'\<^bold>| < \<^bold>|w\<^bold>|\ - unfolding prefix_def by force + have "s \ s\\<^sup>>r = s\\<^sup>>r \ s" + using "less.hyps"[OF _ \w' \p (s\\<^sup>>r) \ w'\ \w' \p s \ w'\ ind_len] \s \p r\ \\<^bold>|w'\<^bold>| < \<^bold>|w\<^bold>|\ + unfolding prefix_def + by force - thus "s \ r = r \ s" + thus "r \ s = s \ r" using \s \p r\ by (fastforce simp add: prefix_def) - qed + qed qed lemma per_lemma_comm_pref: assumes "u \p r\<^sup>@k" "u \p s\<^sup>@l" and len: "\<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| - gcd (\<^bold>|r\<^bold>|) (\<^bold>|s\<^bold>|) \ \<^bold>|u\<^bold>|" shows "r \ s = s \ r" using pref_prod_root[OF assms(2)] pref_prod_root[OF assms(1)] per_lemma_comm[OF _ _ len] by blast text\We can now prove the numeric version.\ theorem per_lemma: assumes "period w p" and "period w q" and len: "p + q - gcd p q \ \<^bold>|w\<^bold>|" shows "period w (gcd p q)" proof- have takep: "w \p (take p w) \ w" and takeq: "w \p (take q w) \ w" - using \period w p\ \period w q\ period_D3 by blast+ + using \period w p\ \period w q\ per_pref by blast+ + have "p \ \<^bold>|w\<^bold>|" + using per_lemma_len_le[OF len] per_not_zero[OF \period w q\]. have lenp: "\<^bold>|take p w\<^bold>| = p" - using gcd_le2_nat[OF per_positive[OF \period w q\], of p] len take_len + using gcd_le2_pos[OF per_not_zero[OF \period w q\], of p] len take_len by auto have lenq: "\<^bold>|take q w\<^bold>| = q" - using gcd_le1_nat[OF per_positive[OF \period w p\], of q] len take_len + using gcd_le1_pos[OF per_not_zero[OF \period w p\], of q] len take_len by simp - obtain t where "take p w \ t*" and "take q w \ t*" - using comm_rootE[OF per_lemma_comm[OF takeq takep, unfolded lenp lenq, OF len], of thesis] by blast - hence "w \p t\<^sup>\" - using \period w p\ period_def per_root_trans by blast + obtain t where "take p w \ t*" and "take q w \ t*" + using comm_rootE[OF per_lemma_comm[OF takep takeq, unfolded lenp lenq, OF len], of thesis] by blast + have "w

w" + using \period w p\[unfolded period_def, THEN per_root_trans, OF \take p w \ t*\]. + with per_nemp[OF \period w q\] have "period w \<^bold>|t\<^bold>|" - using root_period[OF per_nemp[OF \period w p\] \w \p t\<^sup>\\]. + by (rule periodI) have "\<^bold>|t\<^bold>| dvd (gcd p q)" using common_root_len_gcd[OF \take p w \ t*\ \take q w \ t*\] 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 \ 0" - using \period w p\ by auto + using \period w p\ by auto from this[folded dvd_div_eq_0_iff[OF \\<^bold>|t\<^bold>| dvd (gcd p q)\]] show "period w (gcd p q)" using per_mult[OF \period w \<^bold>|t\<^bold>|\, of "gcd p q div \<^bold>|t\<^bold>|", unfolded dvd_div_mult_self[OF \\<^bold>|t\<^bold>| dvd (gcd p q)\]] by blast qed section \Optimality\ -text\@{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\@{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.\ term "butlast ([0..<(gcd p q)]\<^sup>@(p div (gcd p q)))\[gcd p q]\(butlast ([0..<(gcd p q)]\<^sup>@(p div (gcd p q))))" \ \an auxiliary claim\ -lemma ext_per_sum: assumes "period w p" and "period w q" and "p \ \<^bold>|w\<^bold>|" +lemma ext_per_sum: assumes "period w p" and "period w q" and "p \ \<^bold>|w\<^bold>|" shows "period ((take p w) \ w) (p+q)" proof- have nemp: "take p w \ take q w \ \" using \period w p\ by auto have "take (p + q) (take p w \ w) = take p (take p w \ w) \ take q (drop p (take p w \ w))" using take_add by blast also have "... = take p w \ take q w" by (simp add: \p \ \<^bold>|w\<^bold>|\) ultimately have sum: "take (p + q) (take p w \ w) = take p w \ take q w" by presburger + note assms[unfolded period_def] show ?thesis - using assms(1) assms(2) nemp - unfolding period_def period_root_def sum rassoc same_prefix_prefix - using pref_prolong by blast + unfolding period_def sum rassoc + using pref_spref_prolong[OF self_pref spref_spref_prolong[OF \w

w\ \w

w\]]. qed definition "fw_p_per p q \ butlast ([0..<(gcd p q)]\<^sup>@(p div (gcd p q)))" definition "fw_base p q \ fw_p_per p q \ [gcd p q]\ fw_p_per p q" fun FW_word :: "nat \ nat \ nat list" where - FW_word_def: "FW_word p q = -\\symmetry\ (if q < p then FW_word q p else -\\artificial value\ if p = 0 then \ else + FW_word_def: "FW_word p q = +\\symmetry\ (if q < p then FW_word q p else +\\artificial value\ if p = 0 then \ else \\artificial value\ if p = q then \ else \\base case\ if gcd p q = q - p then fw_base p q \\step\ else (take p (FW_word p (q-p))) \ 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+) + by (cases rule: linorder_cases[of p q]) simp+ theorem fw_word': "\ p dvd q \ \ q dvd p \ \<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1 \ period (FW_word p q) p \ period (FW_word p q) q \ \ period (FW_word p q) (gcd p q)" proof (induction "p + p + q" arbitrary: p q rule: less_induct) case less have "p \ 0" - using \\ q dvd p\ dvd_0_right[of q] by meson + using \\ q dvd p\ dvd_0_right[of q] by meson have "p \ q" using \\ p dvd q\ 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: \q < p\) thus ?case - using "less.hyps"[OF _ \\ q dvd p\ \\ p dvd q\] - unfolding FW_sym[of p q] gcd.commute[of p q] add.commute[of p q] by blast + using "less.hyps"[OF _ \\ q dvd p\ \\ p dvd q\] + 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 \p < q\ by auto - hence "p \ q" and "\ q < p" using \p \ 0\ \p < q\ by fastforce+ + hence "p \ q" and "\ q < p" using \p \ 0\ \p < q\ by fastforce+ hence fw: "FW_word p q = fw_base p q" - unfolding FW_word_def[of p q] using \p \ 0\ \gcd p q = q - p\ by presburger + unfolding FW_word_def[of p q] using \p \ 0\ \gcd p q = q - p\ by presburger + + have "\<^bold>|[0..| = gcd p q" + by simp + hence *: "p div gcd p q * \<^bold>|[0..| = p" + by fastforce have ppref: "\<^bold>|butlast (?dw\<^sup>@?pd)\[?d]\<^bold>| = p" - using \p \ 0\ pow_len[of "?dw" "?pd"] unfolding lenmorph sing_len - by auto + using \p \ 0\ unfolding lenmorph pow_len length_butlast sing_len * by fastforce note ppref' = this[unfolded lenmorph] have qpref: "\<^bold>|butlast (?dw\<^sup>@?pd)\[?d]\?dw\<^bold>| = q" - unfolding lassoc lenmorph ppref' using \p + gcd p q = q\ by simp + unfolding lassoc lenmorph ppref' using \p + gcd p q = q\ by simp have "butlast (?dw\<^sup>@?pd)\[?d] \p FW_word p q" - unfolding fw fw_base_def fw_p_per_def by force + unfolding fw fw_base_def fw_p_per_def lassoc using triv_pref. from pref_take[OF this] have takep: "take p (FW_word p q) = butlast (?dw\<^sup>@?pd)\[?d]" unfolding ppref. have "?dw \ \" and "\<^bold>|?dw\<^bold>| = ?d" using \p \ 0\ by auto have "?pd \ 0" - by (simp add: \p \ 0\ dvd_div_eq_0_iff) + by (simp add: \p \ 0\ dvd_div_eq_0_iff) from not0_implies_Suc[OF this] obtain e where "?pd = Suc e" by blast have "gcd p q \ p" - using \\ p dvd q\ gcd_dvd2[of p q] by force + using \\ p dvd q\ gcd_dvd2[of p q] by force hence "Suc e \ 1" using dvd_mult_div_cancel[OF gcd_dvd1[of p q], unfolded \?pd = Suc e\] by force hence "e \ 0" by simp have "[0..@ e \ \" using \[0.. \\ \e \ 0\ nonzero_pow_emp by blast hence but_dec: "butlast (?dw\<^sup>@?pd) = ?dw \ butlast (?dw\<^sup>@e)" unfolding \?pd = Suc e\ pow_Suc butlast_append if_not_P[OF \[0..@ e \ \\] by blast - have but_dec_b: "butlast (?dw\<^sup>@?pd) = ?dw\<^sup>@e \ butlast ?dw" - unfolding \?pd = Suc e\ pow_Suc2 butlast_append if_not_P[OF \?dw \ \\] by blast + have but_dec_b: "butlast (?dw\<^sup>@?pd) = ?dw\<^sup>@e \ butlast ?dw" + unfolding \?pd = Suc e\ pow_Suc' butlast_append if_not_P[OF \?dw \ \\] by blast have "butlast (?dw\<^sup>@?pd)\[?d]\?dw \p FW_word p q" 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 \p + gcd p q = q\ 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 + unfolding pow_len \\<^bold>|[0..| = gcd p q\ by force hence "\<^bold>|butlast (?dw\<^sup>@?pd)\<^bold>| = p - 1" - by simp + unfolding length_butlast by argo hence "\<^bold>|FW_word p q\<^bold>| = (p - 1) + 1 + (p - 1)" - unfolding fw lenmorph sing_len fw_base_def fw_p_per_def by presburger + 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 \gcd p q = q - p\ \p + q - (q - p) = p + p\ using \p \ 0\ by fastforce - qed + qed have "period (FW_word p q) p" - proof- - have "take p (FW_word p q) \ \" + unfolding period_def + proof (rule per_rootI) + show "take p (FW_word p q) \ \" using \p \ 0\ unfolding length_0_conv[symmetric] ppref[folded takep]. - moreover have "fw_base p q \p fw_p_per p q \ [gcd p q] \ 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 + have "fw_base p q \p fw_p_per p q \ [gcd p q] \ fw_base p q" + unfolding rassoc pref_cancel_conv fw_base_def fw_p_per_def by blast + thus "FW_word p q \p take p (FW_word p q) \ FW_word p q" + unfolding fw rassoc fw_p_per_def takep[unfolded fw]. qed have "period (FW_word p q) q" - unfolding period_def period_root_def - proof + unfolding period_def + proof (rule per_rootI) show "take q (FW_word p q) \ \" unfolding length_0_conv[symmetric] qpref[folded takeq] using \p \ 0\ \p < q\ by linarith - next - show "FW_word p q \p take q (FW_word p q) \ FW_word p q" - unfolding takeq - unfolding fw fw_base_def fw_p_per_def rassoc pref_cancel_conv but_dec but_dec_b \?pd = Suc e\ pow_Suc2 butlast_append pow_Suc if_not_P[OF \?dw \ \\] - unfolding lassoc power_commutes[symmetric] unfolding rassoc pref_cancel_conv - using pref_ext[OF prefixeq_butlast, of "?dw"] - by blast + have "butlast ([0..@ (p div gcd p q)) \p [0.. butlast ([0..@ (p div gcd p q))" + using pref_prod_root[OF prefixeq_butlast[of "[0..@ (p div gcd p q)"]]. + from pref_ext[OF this, unfolded rassoc] + have "fw_base p q \p fw_p_per p q \ [gcd p q] \ [0.. fw_base p q" + unfolding rassoc pref_cancel_conv fw_base_def fw_p_per_def. + thus "FW_word p q \p take q (FW_word p q) \ FW_word p q" + unfolding fw rassoc fw_p_per_def takeq[unfolded fw]. qed have "\ 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" \] last_snoc by blast have "?dw \p FW_word p q" unfolding fw but_dec rassoc fw_base_def fw_p_per_def by blast from pref_take[OF this, unfolded \\<^bold>|?dw\<^bold>| = ?d\] have takegcd: "take (gcd p q) (FW_word p q) = [0..@e \ butlast ([0.. [?d] \ (butlast ([0..@(p div gcd p q)))" unfolding fw but_dec_b rassoc fw_base_def fw_p_per_def .. have gcdepref: "[0..@ Suc e \p take (gcd p q) (FW_word p q) \ FW_word p q" unfolding takegcd pow_Suc pref_cancel_conv unfolding fw_dec_b by blast have "\<^bold>|[0..@ Suc e\<^bold>| = p" - unfolding pow_len \\<^bold>|?dw\<^bold>| = ?d\ \?pd = Suc e\[symmetric] using + unfolding pow_len \\<^bold>|?dw\<^bold>| = ?d\ \?pd = Suc e\[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) \ (FW_word p q)) = [0..@e \ [0..p \ 0\) from last_upt[OF this] have last_b: "last (take p (take (gcd p q) (FW_word p q) \ (FW_word p q))) = gcd p q - 1" unfolding takegcdp last_appendR[of "[0..@e", OF \[0.. \\]. have "p \ \<^bold>|FW_word p q\<^bold>|" - unfolding \\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1\ \gcd p q = q - p\ using \p < q\ by auto + unfolding \\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1\ \gcd p q = q - p\ using \p < q\ by auto have "gcd p q \ gcd p q - 1" using \gcd p q = q - p\ \p < q\ by linarith hence "take p (FW_word p q) \ take p (take (gcd p q) (FW_word p q) \ (FW_word p q))" unfolding last_b[symmetric] unfolding last_a[symmetric] using arg_cong[of _ _ last] by blast - hence "\ FW_word p q \p take (gcd p q) (FW_word p q) \ FW_word p q " + hence "\ FW_word p q \p take (gcd p q) (FW_word p q) \ FW_word p q " using pref_share_take[OF _ \p \ \<^bold>|FW_word p q\<^bold>|\, of "take (gcd p q) (FW_word p q) \ FW_word p q"] by blast - thus "\ period (FW_word p q) (gcd p q)" - unfolding period_def period_root_def by blast - qed + thus "\ period (FW_word p q) (gcd p q)" + unfolding period_def by blast + qed show ?thesis using \period (FW_word p q) p\ \period (FW_word p q) q\ \\<^bold>|FW_word p q\<^bold>| = p + q - gcd p q - 1\ \\ period (FW_word p q) (gcd p q)\ by blast next - let ?d' = "gcd p (q-p)" + let ?d' = "gcd p (q-p)" assume "gcd p q \ q - p" - hence fw: "FW_word p q = (take p (FW_word p (q-p))) \ FW_word p (q-p)" + hence fw: "FW_word p q = (take p (FW_word p (q-p))) \ FW_word p (q-p)" using FW_word_def \p \ 0\ \p \ q\ \p < q\ by (meson less_Suc_eq not_less_eq) have divhyp1: "\ p dvd q - p" using \\ p dvd q\ \p < q\ dvd_minus_self by auto have divhyp2: "\ q - p dvd p" proof (rule notI) assume "q - p dvd p" have "q = p + (q - p)" by (simp add: \p < q\ less_or_eq_imp_le) - from gcd_add2[of p "q - p", folded this, unfolded gcd_nat.absorb2[of "q - p" p, OF \q - p dvd p\]] + from gcd_add2[of p "q - p", folded this, unfolded gcd_nat.absorb2[of "q - p" p, OF \q - p dvd p\]] show "False" using \gcd p q \ q - p\ by blast qed have lenhyp: "p + p + (q - p) < p + p + q" - using \p < q\ \p \ 0\ by linarith + using \p < q\ \p \ 0\ by linarith -\ \induction assumption\ +\ \induction assumption\ 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 - "\ period (FW_word p (q-p)) (gcd p (q-p))" + "\ period (FW_word p (q-p)) (gcd p (q-p))" using "less.hyps"[OF _ divhyp1 divhyp2] lenhyp - by blast+ + by blast+ \ \auxiliary facts\ 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 \p < q\]]]. have "?d \ q" using \\ q dvd p\ 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 \p < q\ nat_dvd_not_less by blast hence "1 \ q - ?d" by linarith have "?d' < q - p" - using gcd_le2_nat[OF per_positive[OF \period (FW_word p (q - p)) (q - p)\], of p] divhyp2[unfolded gcd_nat.absorb_iff2] nat_less_le by blast + using gcd_le2_pos[OF per_not_zero[OF \period (FW_word p (q - p)) (q - p)\], of p] divhyp2[unfolded gcd_nat.absorb_iff2] nat_less_le by blast hence "p \ \<^bold>|(FW_word p (q - p))\<^bold>|" unfolding \\<^bold>|FW_word p (q - p)\<^bold>| = p + (q - p) - ?d' - 1\ diff_diff_left discrete by linarith - have "FW_word p (q - p) \ \" - unfolding length_0_conv[symmetric] using \p \ \<^bold>|FW_word p (q - p)\<^bold>|\ \p \ 0\[folded le_zero_eq] + have "FW_word p (q - p) \ \" + unfolding length_0_conv[symmetric] using \p \ \<^bold>|FW_word p (q - p)\<^bold>|\ \p \ 0\[folded le_zero_eq] by linarith \ \claim 1\ - 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 \p < q\] 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 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 \\<^bold>|FW_word p (q - p)\<^bold>| = p + (q - p) - ?d' - 1\ + unfolding \\<^bold>|FW_word p (q - p)\<^bold>| = p + (q - p) - ?d' - 1\ take_len[OF \p \ \<^bold>|FW_word p (q - p)\<^bold>|\] by blast also have "... = p + (q - ?d - 1)" unfolding \?d = ?d'\ \p + (q - p) = q\.. also have "... = p + (q - ?d) - 1" using Nat.add_diff_assoc[OF \1 \ q - ?d\]. also have "... = p + q - ?d - 1" by (simp add: \?d < q\ 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 \ \claim 2\ have "period (FW_word p q) p" using fw ext_per_left[OF \period (FW_word p (q-p)) p\ \p \ \<^bold>|FW_word p (q - p)\<^bold>|\] by presburger \ \claim 3\ have "period (FW_word p q) q" using ext_per_sum[OF \period (FW_word p (q - p)) p\ \period (FW_word p (q - p)) (q - p)\ \p \ \<^bold>|FW_word p (q - p)\<^bold>|\, folded fw, unfolded \p + (q-p) = q\]. \ \claim 4\ - have "\ period (FW_word p q) ?d" - using \\ period (FW_word p (q -p)) (gcd p (q-p))\ - unfolding \?d = ?d'\[symmetric] - using period_fac[of "take p (FW_word p (q - p))" "FW_word p (q - p)" \ "?d", unfolded append_Nil2, + have "\ period (FW_word p q) ?d" + using \\ period (FW_word p (q -p)) (gcd p (q-p))\ + unfolding \?d = ?d'\[symmetric] + using period_fac[of "take p (FW_word p (q - p))" "FW_word p (q - p)" \ "?d", unfolded append_Nil2, OF _ \FW_word p (q - p) \ \\, folded fw] by blast thus ?thesis - using \period (FW_word p q) p\ \period (FW_word p q) q\ \\<^bold>|FW_word p q\<^bold>| = p + q - ?d - 1\ by blast + using \period (FW_word p q) p\ \period (FW_word p q) q\ \\<^bold>|FW_word p q\<^bold>| = p + q - ?d - 1\ by blast qed qed qed theorem fw_word: assumes "\ p dvd q" "\ q dvd p" 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 "\ period (FW_word p q) (gcd p q)" using fw_word'[OF assms] by blast+ text\Calculation examples\ -(* 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 \Periodicity lemma is one of the most frequent tools in Combinatorics on words. Here are some useful variants.\ -lemma fac_two_conjug_primroot: - assumes facs: "u \f r\<^sup>@k" "u \f s\<^sup>@l" and nemps: "r \ \" "s \ \" and len: "\<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| - gcd (\<^bold>|r\<^bold>|) (\<^bold>|s\<^bold>|) \ \<^bold>|u\<^bold>|" - shows "\ r \ \ s" -proof - - obtain r' s' where prefr': "u \p r'\<^sup>@k" and prefs': "u \p s'\<^sup>@l" - and conjugs: "r \ r'" "s \ s'" - using facs by (elim fac_pow_pref_conjug) - have rootr': "u \p r' \ u" and roots': "u \p s' \ u" - using pref_prod_root[OF prefr'] pref_prod_root[OF prefs']. - have nemps': "r' \ \" "s'\ \" using nemps conjugs conjug_nemp_iff by blast+ - have "\<^bold>|r'\<^bold>| + \<^bold>|s'\<^bold>| - gcd (\<^bold>|r'\<^bold>|) (\<^bold>|s'\<^bold>|) \ \<^bold>|u\<^bold>|" using len - unfolding conjug_len[OF \r \ r'\] conjug_len[OF \s \ s'\]. - from per_lemma_comm[OF roots' rootr' this] have "r' \ s' = s' \ r'". - then have "\ r' = \ s'" using comm_primroots[OF nemps'] by force - also have "\ s \ \ s'" using conjug_primroot[OF \s \ s'\]. - also have [symmetric]: "\ r \ \ r'" using conjug_primroot[OF \r \ r'\]. - finally show "\ r \ \ s".. +text\Note that the following lemmas are stronger versions of @{thm per_lemma_pref_suf fac_two_conjug_primroot fac_two_conjug_primroot' fac_two_conjug_primroot'' fac_two_prim_conjug} that have a relaxed length assumption @{term "\<^bold>|p\<^bold>| + \<^bold>|q\<^bold>| \ \<^bold>|w\<^bold>|"} instead of @{term "\<^bold>|p\<^bold>| + \<^bold>|q\<^bold>| - (gcd \<^bold>|p\<^bold>| \<^bold>|q\<^bold>|) \ \<^bold>|w\<^bold>|"} (and which follow from the relaxed version of periodicity lemma @{thm two_pers}.\ + + +lemma per_lemma_pref_suf_gcd: assumes "w

w" and "w q" and + fw: "\<^bold>|p\<^bold>| + \<^bold>|q\<^bold>| - (gcd \<^bold>|p\<^bold>| \<^bold>|q\<^bold>|) \ \<^bold>|w\<^bold>|" +obtains r s k l m where "p = (r \ s)\<^sup>@k" and "q = (s \ r)\<^sup>@l" and "w = (r \ s)\<^sup>@m \ r" and "primitive (r\s)" +proof- + let ?q = "(w \ q)\<^sup><\w" + have "w

w" + using ssufD1[OF \w q\] rq_suf[symmetric, THEN per_rootI[OF prefI rq_ssuf[OF \w q\]]] + by argo + have "q \ ?q" + by (meson assms(2) conjugI1 conjug_sym rq_suf suffix_order.less_imp_le) + + have nemps': "p \ \" "?q \ \" + using assms(1) \w

w\ by fastforce+ + have "\<^bold>|p\<^bold>| + \<^bold>|?q\<^bold>| - gcd (\<^bold>|p\<^bold>|) (\<^bold>|?q\<^bold>|) \ \<^bold>|w\<^bold>|" using fw + unfolding conjug_len[OF \q \ ?q\]. + from per_lemma_comm[OF sprefD1[OF \w

w\] sprefD1[OF \w

w\] this] + have "p \ ?q = ?q \ p". + then have "\ p = \ ?q" using comm_primroots[OF nemps'] by force + hence [symmetric]: "\ q \ \ p" + using conjug_primroot[OF \q \ (w \ q)\<^sup><\w\] + by argo + from conjug_primrootsE[OF this] + obtain r s k l where + "p = (r \ s) \<^sup>@ k" and + "q = (s \ r) \<^sup>@ l" and + "primitive (r \ s)". + have "w \p (r\s)\w" + using assms per_root_drop_exp sprefD1 \p = (r \ s) \<^sup>@ k\ + by meson + have "w \s w\(s\r)" + using assms(2) per_root_drop_exp[reversed] ssufD1 \q = (s \ r) \<^sup>@ l\ + by meson + have "\<^bold>|r \ s\<^bold>| \ \<^bold>|w\<^bold>|" + using conjug_nemp_iff[OF \q \ ?q\] dual_order.trans length_0_conv nemps' per_lemma_len_le[OF fw] primroot_len_le[OF nemps'(1)] + unfolding primroot_unique[OF nemps'(1) \primitive (r \ s)\ \p = (r \ s) \<^sup>@ k\] + by blast + from root_suf_conjug[OF \primitive (r \ s)\ \w \p (r\s)\w\ \w \s w\(s\r)\ this] + obtain m where "w = (r \ s) \<^sup>@ m \ r". + from that[OF \p = (r \ s) \<^sup>@ k\ \q = (s \ r) \<^sup>@ l\ this \primitive (r \ s)\] + show ?thesis. qed -lemma fac_two_conjug_primroot': +lemma fac_two_conjug_primroot_gcd: + assumes facs: "w \f p\<^sup>@k" "w \f q\<^sup>@l" and nemps: "p \ \" "q \ \" and len: "\<^bold>|p\<^bold>| + \<^bold>|q\<^bold>| - gcd (\<^bold>|p\<^bold>|) (\<^bold>|q\<^bold>|) \ \<^bold>|w\<^bold>|" + obtains r s m where "\ p \ r \ s" and "\ q \ r \ s" and "w = (r \ s)\<^sup>@m \ r" and "primitive (r\s)" +proof - + obtain p' where "w

w" "p \ p'" "p' \ \" + using conjug_nemp_iff fac_pow_pref_conjug[OF facs(1)] nemps(1) per_rootI' by metis + obtain q' where "w q'" "q \ q'" "q' \ \" + using fac_pow_pref_conjug[reversed, OF \w \f q\<^sup>@l\] conjug_nemp_iff nemps(2) per_rootI'[reversed] by metis + from per_lemma_pref_suf_gcd[OF \w

w\ \w q'\] + obtain r s k l m where + "p' = (r \ s) \<^sup>@ k" and + "q' = (s \ r) \<^sup>@ l" and + "w = (r \ s) \<^sup>@ m \ r" and + "primitive (r \ s)" + using len[unfolded conjug_len[OF \p \ p'\] conjug_len[OF \q \ q'\]] + by blast + moreover have "\ p' = r\s" + using \p' = (r \ s) \<^sup>@ k\ \primitive (r \ s)\ \p' \ \\ primroot_unique by blast + hence "\ p \ r\s" + using conjug_primroot[OF \p \ p'\] + by simp + moreover have "\ q' = s\r" + using \q' = (s \ r) \<^sup>@ l\ \primitive (r \ s)\[unfolded conjug_prim_iff'[of r]] \q' \ \\ primroot_unique by blast + hence "\ q \ s\r" + using conjug_primroot[OF \q \ q'\] by simp + hence "\ q \ r\s" + using conjug_trans[OF _ conjugI'] + by meson + ultimately show ?thesis + using that by blast +qed + +corollary fac_two_conjug_primroot'_gcd: + assumes facs: "u \f r\<^sup>@k" "u \f s\<^sup>@l" and nemps: "r \ \" "s \ \" and len: "\<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| - gcd (\<^bold>|r\<^bold>|) (\<^bold>|s\<^bold>|) \ \<^bold>|u\<^bold>|" + shows "\ r \ \ s" + using fac_two_conjug_primroot_gcd[OF assms] conjug_trans[OF _ conjug_sym[of "\ s"]]. + +lemma fac_two_conjug_primroot''_gcd: assumes facs: "u \f r\<^sup>@k" "u \f s\<^sup>@l" and "u \ \" and len: "\<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| - gcd (\<^bold>|r\<^bold>|) (\<^bold>|s\<^bold>|) \ \<^bold>|u\<^bold>|" shows "\ r \ \ s" proof - have nemps: "r \ \" "s \ \" using facs \u \ \\ by auto - show "conjugate (\ r) (\ s)" using fac_two_conjug_primroot[OF facs nemps len]. + show "conjugate (\ r) (\ s)" using fac_two_conjug_primroot'_gcd[OF facs nemps len]. qed -lemma fac_two_nconj_prim_pow: - assumes prims: "primitive r" "primitive s" and "\ r \ s" - and facs: "u \f r\<^sup>@k" "u \f s\<^sup>@l" - shows "\<^bold>|u\<^bold>| < \<^bold>|r\<^bold>| + \<^bold>|s\<^bold>| - gcd (\<^bold>|r\<^bold>|) (\<^bold>|s\<^bold>|)" - using \\ r \ s\ fac_two_conjug_primroot[OF facs prim_nemp prim_nemp leI, OF prims] - unfolding prim_self_root[OF \primitive r\] prim_self_root[OF \primitive s\] - by (rule contrapos_np) +lemma fac_two_prim_conjug_gcd: + assumes "w \f u\<^sup>@n" "w \f v\<^sup>@m" "primitive u" "primitive v" "\<^bold>|u\<^bold>| + \<^bold>|v\<^bold>| - gcd (\<^bold>|u\<^bold>|) (\<^bold>|v\<^bold>|) \ \<^bold>|w\<^bold>|" + shows "u \ v" + using fac_two_conjug_primroot'_gcd[OF assms(1-2) _ _ assms(5)] prim_nemp[OF \primitive u\] prim_nemp[OF \primitive v\] + unfolding prim_self_root[OF \primitive u\] prim_self_root[OF \primitive v\]. -lemma per_lemma_pref_suf: assumes "w \p p \ w" and "w \s w \ q" and "p \ \" and "q \ \" and - fw: "\<^bold>|p\<^bold>| + \<^bold>|q\<^bold>| - (gcd \<^bold>|p\<^bold>| \<^bold>|q\<^bold>|) \ \<^bold>|w\<^bold>|" -obtains r s k l m where "p = (r \ s)\<^sup>@k" and "q = (s \ r)\<^sup>@l" and "w = (r \ s)\<^sup>@m \ r" and "primitive (r\s)" -proof- - obtain kp where "w \f p\<^sup>@kp" - using per_root_fac[OF \w \p p \ w\ \p \ \\]. - obtain kq where "w \f q\<^sup>@kq" - using per_root_fac[reversed, OF \w \s w \ q\] using \q \ \\ by blast - from fac_two_conjug_primroot[OF \w \f p\<^sup>@kp\ \w \f q\<^sup>@kq\ \p \ \\ \q \ \\ fw] - have "\ p \ \ q". - have "\<^bold>|p\<^bold>| \ \<^bold>|w\<^bold>|" - using per_lemma_len_le[OF fw] \q \ \\ by simp - hence "\<^bold>|\ p\<^bold>| \ \<^bold>|w\<^bold>|" and "\<^bold>|\ q\<^bold>| \ \<^bold>|w\<^bold>|" - using conjug_len[OF \\ p \ \ q\] dual_order.trans primroot_len_le[OF \p \ \\] by metis+ - hence "\ q \s w" - using \w \s w \ q\ primroot_suf[OF \q \ \\] suffix_appendI suffix_length_suffix by metis - have "w \p \ p \ w" - using per_root_primroot[OF \w \p p \ w\ \p \ \\]. - obtain r s k where "\ p = r \ s" and "w = (r \ s)\<^sup>@k \ r" - using per_root_eq[OF \w \p \ p \ w\ primroot_nemp[OF \p \ \\]]. - have "\<^bold>|\ q\<^bold>| = \<^bold>|s \ r\<^bold>|" - using lenarg[OF \\ p = r \ s\] conjug_len[OF \\ p \ \ q\] unfolding lenmorph by linarith - hence "\ q = s \ r" - proof (cases "k = 0") - assume "k = 0" - hence "w = r" - using \w = (r \ s)\<^sup>@k \ r\ pow_zero by force - hence "s = \" - using \\<^bold>|\ p\<^bold>| \ \<^bold>|w\<^bold>|\ \\ p = r \ s\ by auto - have "\ q = r" - using conjug_sym[OF \\ p \ \ q\] suf_same_len[OF \\ q \s w\ conjug_len] - unfolding \s = \\ clean_emp \w = r\ \\ p = r \ s\ by blast - thus "\ q = s \ r" - using \s = \\ by simp - next - assume "k \ 0" - hence "w = (r \ (s \ r)\<^sup>@(k-1)) \ s \ r" - unfolding \w = (r \ s)\<^sup>@k \ r\ by comparison - from suf_prod_eq[OF \\ q \s w\[unfolded this] \\<^bold>|\ q\<^bold>| = \<^bold>|s \ r\<^bold>|\] - show "\ q = s \ r". - qed - from that[OF _ _ \w = (r \ s)\<^sup>@k \ r\] \\ q = s \ r\ \q \ \\ \\ p = r \ s\ \p \ \\ - show thesis - using primroot_expE primroot_prim by metis +lemma two_pers_1: + assumes pu: "w \p u \ w" and pv: "w \p v \ w" and len: "\<^bold>|u\<^bold>| + \<^bold>|v\<^bold>| - 1 \ \<^bold>|w\<^bold>|" + shows "u \ v = v \ u" +proof + assume "u \ \" "v \ \" + hence "1 \ gcd \<^bold>|u\<^bold>| \<^bold>|v\<^bold>|" + using nemp_len by (simp add: Suc_leI) + thus ?thesis + using per_lemma_comm[OF pu pv] len by linarith 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,20 +1,18 @@ chapter AFP session Combinatorics_Words = "HOL-Eisbach" + options [timeout = 600] theories Arithmetical_Hints Border_Array Reverse_Symmetry CoWBasic Submonoids Morphisms Periodicity_Lemma 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,713 +1,720 @@ (* 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 \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 "\(xs::'a list). P xs"} is substituted by (logically equivalent) quantification @{term "\xs. P (rev xs)"}, similarly for $\forall$, $\exists$ and $\exists!$ quantifiers; each bounded quantification of @{typ "'a list"} type variable @{term "\(xs::'a list) \ A. P xs"} is substituted by (logically equivalent) quantification @{term "\xs\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. +``add'' and ``del'' options. See examples at the end of the file. \ section \Quantifications and maps\ lemma all_surj_conv: assumes "surj f" shows "(\x. PROP P (f x)) \ (\y. PROP P y)" proof fix y assume "\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 "(\x. P (f x)) \ (\y. P y)" proof (intro iffI allI) fix y assume "\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 "(\x. P (f x)) \ (\y. P y)" proof assume "\x. P (f x)" then obtain x where "P (f x)".. then show "\x. P x".. -next +next assume "\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 "\x. P (f x)".. qed lemma Ex1_bij_conv: assumes "bij f" shows "(\!x. P (f x)) \ (\!y. P y)" proof have imp: "\!y. Q y" if bij: "bij g" and ex1: "\!x. Q (g x)" for g Q proof - from ex1E[OF ex1, rule_format] obtain x where ex: "Q (g x)" and uniq: "\x'. Q (g x') \ 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 "\!y. Q y".. qed show "\!x. P (f x) \ \!y. P y" using imp[OF assms]. assume "\!y. P y" then have "\!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 "\!x. P (f x)". qed lemma Ball_inj_conv: assumes "inj f" shows "(\y\f ` A. P (inv f y)) \ (\x\A. P x)" using ball_simps(9)[of f A "\y. P (inv f y)"] unfolding inv_f_f[OF assms]. lemma Bex_inj_conv: assumes "inj f" shows "(\y\f ` A. P (inv f y)) \ (\x\A. P x)" using bex_simps(7)[of f A "\y. P (inv f y)"] unfolding inv_f_f[OF assms]. subsection \Quantifications and reverse\ lemma rev_involution': "rev \ rev = id" by auto lemma rev_inv: "inv rev = rev" using inv_unique_comp[OF rev_involution' rev_involution']. section \Attributes\ context begin subsection \Cons reversion\ definition snocs :: "'a list \ 'a list \ 'a list" where "snocs xs ys = xs @ ys" subsection \Final corrections\ lemma snocs_snocs: "snocs (snocs xs (y # ys)) zs = snocs xs (y # snocs ys zs)" unfolding snocs_def by simp 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_correct3 = snocs_is_append subsection \Declaration attribute \reversal_rule\\ ML \ -structure Reversal_Rules = +structure Reversal_Rules = Named_Thms( val name = @{binding "reversal_rule"} val description = "Rules performing reverse-symmetry transformation on theorems on lists" ) \ -attribute_setup reversal_rule = +attribute_setup reversal_rule = \Attrib.add_del (Thm.declaration_attribute Reversal_Rules.add_thm) (Thm.declaration_attribute Reversal_Rules.del_thm)\ "maintaining a list of reversal rules" subsection \Tracing attribute\ ML \ 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) \ attribute_setup reversed_trace = tracing_parser "reversed trace configuration" subsection \Rule attribute \reversed\\ private lemma rev_Nil: "rev [] \ []" by simp private lemma map_Nil: "map f [] \ []" by simp private lemma image_empty: "f ` Set.empty \ Set.empty" by simp definition COMP :: "('b \ prop) \ ('a \ 'b) \ 'a \ prop" (infixl "oo" 55) where "F oo g \ (\x. F (g x))" lemma COMP_assoc: "F oo (f o g) \ (F oo f) oo g" unfolding COMP_def o_def. private lemma image_comp_image: "(`) f \ (`) g \ (`) (f \ g)" unfolding comp_def image_comp. private lemma rev_involution: "rev \ rev \ id" unfolding comp_def rev_rev_ident id_def. private lemma map_involution: assumes "f \ f \ id" shows "(map f) \ (map f) \ id" unfolding map_comp_map \f \ f \ id\ List.map.id. private lemma image_involution: assumes "f \ f \ id" shows "(image f) \ (image f) \ id" unfolding image_comp_image \f \ f \ id\ image_id. private lemma rev_map_comm: "rev \ map f \ map f \ rev" unfolding comp_def rev_map. private lemma involut_comm_comp: assumes "f o f \ id" and "g o g \ id" and "f o g \ g o f" shows "(f \ g) \ (f \ g) \ id" by (simp add: comp_assoc comp_assoc[symmetric] assms) private lemma rev_map_involution: assumes "g o g \ id" shows "(rev \ map g) \ (rev \ map g) \ id" using involut_comm_comp[OF rev_involution map_involution[OF \g o g \ id\] rev_map_comm]. private lemma prop_abs_subst: assumes "f o f \ id" shows "(\x. F (f x)) oo f \ (\x. F x)" unfolding COMP_def o_apply[symmetric] unfolding \f o f \ id\ id_def. private lemma prop_abs_subst_comm: assumes "f o f \ id" and "g o g \ id" and "f o g \ g o f" shows "(\x. F (f (g x))) oo (f o g) \ (\x. F x)" unfolding \f o g \ g o f\ unfolding COMP_assoc unfolding prop_abs_subst[OF \g o g \ id\, of "\x. F (f x)"] prop_abs_subst[OF \f o f \ id\]. private lemma prop_abs_subst_rev_map: assumes "g o g \ id" shows "(\x. F (rev (map g x))) oo (rev o map g) \ (\x. F x)" using prop_abs_subst_comm[OF rev_involution map_involution[OF \g o g \ id\] rev_map_comm]. private lemma obj_abs_subst: assumes "f o f \ id" shows "(\x. F (f x)) o f \ (\x. F x)" unfolding comp_def unfolding o_apply[of f, symmetric] \f o f \ id\ id_def. private lemma obj_abs_subst_comm: assumes "f o f \ id" and "g o g \ id" and "f o g \ g o f" shows "(\x. F (f (g x))) o (f o g) \ (\x. F x)" unfolding \f o g \ g o f\ unfolding comp_assoc[symmetric] unfolding obj_abs_subst[OF \g o g \ id\, of "\x. F (f x)"] obj_abs_subst[OF \f o f \ id\]. private lemma obj_abs_subst_rev_map: assumes "g o g \ id" shows "(\x. F (rev (map g x))) o (rev o map g) \ (\x. F x)" using obj_abs_subst_comm[OF rev_involution map_involution[OF \g o g \ id\] rev_map_comm]. ML \ local fun comp_const T = Const(\<^const_name>\comp\, (T --> T) --> (T --> T) --> T --> T) fun rev_const T = Const(\<^const_name>\rev\, T --> T) fun map_const S T = Const(\<^const_name>\map\, (S --> S) --> T --> T) fun image_const S T = Const(\<^const_name>\image\, (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>\list\, [S])) = [rev_const T] @ ( case tr S of [] => [] | (g :: gs') => [map_const S T $ comp S g gs']) | tr (T as Type(\<^type_name>\set\, [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>\list\, [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>\set\, [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>\Nil\, T) => Nil_cv ctxt T ct | Const(\<^const_name>\bot\, T as Type(\<^type_name>\set\, _)) => empty_cv ctxt T ct | _ => Thm.reflexive ct \ ML \ 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 + [(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 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 Drule.zero_var_indexes th_export end 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)) \ attribute_setup reversed = \reversed\ "Transforms the theorem on lists to reverse-symmetric version" end section \Declaration of basic reversal rules\ subsection \Pure\ \ \\<^const>\Pure.all\\ lemma all_surj_conv' [reversal_rule]: assumes "surj f" shows "Pure.all (P oo f) \ Pure.all P" unfolding COMP_def using all_surj_conv[OF assms]. subsection \\<^theory>\HOL.HOL\\ \ \\<^const>\HOL.eq\\ lemmas [reversal_rule] = rev_is_rev_conv inj_eq \ \\<^const>\All\\ 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]. \ \\<^const>\Ex\\ lemma Ex_surj_conv' [reversal_rule]: assumes "surj f" shows "Ex (P o f) \ Ex P" unfolding comp_def using Ex_surj_conv[OF assms]. \ \\<^const>\Ex1\\ lemma Ex1_bij_conv' [reversal_rule]: assumes "bij f" shows "Ex1 (P o f) \ Ex1 P" unfolding comp_def using Ex1_bij_conv[OF assms]. \ \\<^const>\If\\ lemma if_image [reversal_rule]: "(if P then f u else f v) = f (if P then u else v)" by simp subsection \\<^theory>\HOL.Set\\ \ \\<^const>\Collect\\ lemma collect_image: "Collect (P \ f) = f -` (Collect P)" by fastforce lemma collect_image' [reversal_rule]: assumes "f \ f = id" shows "Collect (P \ 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].. \ \\<^const>\Ball\\ lemma Ball_image [reversal_rule]: assumes "(g \ f) ` A = A" shows "Ball (f ` A) (P \ g) = Ball A P" unfolding Ball_image_comp[symmetric] image_comp \(g \ f) ` A = A\.. \ \\<^const>\Bex\\ lemma Bex_image_comp: "Bex (f ` A) g = Bex A (g \ f)" by simp lemma Bex_image [reversal_rule]: assumes "(g \ f) ` A = A" shows "Bex (f ` A) (P \ g) = Bex A P" unfolding Bex_image_comp[symmetric] image_comp \(g \ f) ` A = A\.. - + \ \\<^const>\insert\\ lemma insert_image [reversal_rule]: "insert (f x) (f ` X) = f ` (insert x X)" by blast \ \\<^const>\List.member\\ lemmas [reversal_rule] = inj_image_mem_iff + \ \\<^const>\subset_eq\\ +lemmas [reversal_rule] = inj_image_subset_iff + subsection \\<^theory>\HOL.List\\ \ \\<^const>\set\\ lemmas [reversal_rule] = set_rev set_map \ \\<^const>\Cons\\ 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 \ \\<^const>\hd\\ lemmas [reversal_rule] = hd_rev hd_map \ \\<^const>\tl\\ 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] \ \\<^const>\last\\ lemmas [reversal_rule] = last_rev last_map \ \\<^const>\butlast\\ lemmas [reversal_rule] = butlast_rev map_butlast[symmetric] \ \\<^const>\List.coset\\ 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 \bij f\, symmetric] unfolding coset_def set_map. lemmas [reversal_rule] = coset_rev coset_map \ \\<^const>\append\\ lemmas [reversal_rule] = rev_append[symmetric] map_append[symmetric] \ \\<^const>\concat\\ 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 \ 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' \ \\<^const>\drop\\ lemmas [reversal_rule] = drop_rev drop_map - + \ \\<^const>\take\\ lemmas [reversal_rule] = take_rev take_map \ \\<^const>\nth\\ lemmas [reversal_rule] = rev_nth nth_map \ \\<^const>\List.insert\\ 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 \inj f\] Cons_map if_image.. \ \\<^const>\List.union\\ 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 \inj f\]. qed (simp add: List.union_def) \ \\<^const>\length\\ lemmas [reversal_rule] = length_rev length_map - + \ \\<^const>\rotate\\ lemmas [reversal_rule] = rotate_rev rotate_map \ \\<^const>\lists\\ lemma rev_in_lists: "rev u \ lists A \ u \ lists A" by auto lemma map_in_lists: "inj f \ map f u \ lists (f ` A) \ u \ lists A" by (simp add: lists_image inj_image_mem_iff inj_mapI) lemmas [reversal_rule] = rev_in_lists map_in_lists + \ \\<^const>\list_all\\ +lemmas [reversal_rule] = list_all_rev + + \ \\<^const>\list_ex\\ +lemmas [reversal_rule] = list_ex_rev + subsection \Reverse Symmetry\ \ \\<^const>\snocs\\ lemma snocs_map [reversal_rule]: "snocs (map f u) [f a] = map f (snocs u [a])" unfolding snocs_def by simp section \\ lemma bij_rev: "bij rev" using o_bij[OF rev_involution' rev_involution']. lemma bij_map: "bij f \ bij (map f)" using bij_betw_def inj_mapI lists_UNIV lists_image by metis lemma surj_map: "surj f \ surj (map f)" using lists_UNIV lists_image by metis lemma bij_image: "bij f \ bij (image f)" using bij_betw_Pow by force lemma inj_image: "inj f \ inj (image f)" by (simp add: inj_on_image) lemma surj_image: "surj f \ 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 \Examples\ context begin subsection \Cons and append\ 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 \Induction rules\ thm list_nonempty_induct - list_nonempty_induct[reversed] (* needs work *) - list_nonempty_induct[reversed, where P="\x. P (rev x)" for P, unfolded rev_rev_ident] + list_nonempty_induct[reversed] list_nonempty_induct[reversed, where P="\x. P (rev x)" for P, unfolded rev_rev_ident] thm list_induct2 - list_induct2[reversed] (* needs work *) - list_induct2[reversed, where P="\x y. P (rev x) (rev y)" for P, unfolded rev_rev_ident] + list_induct2[reversed] list_induct2[reversed, where P="\x y. P (rev x) (rev y)" for P, unfolded rev_rev_ident] subsection \hd, tl, last, butlast\ 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 \set\ 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 \rotate\ private lemma rotate1_hd_tl: "xs \ [] \ rotate 1 xs = tl xs @ [hd xs]" by (cases xs) simp_all thm rotate1_hd_tl rotate1_hd_tl[reversed] end -end \ No newline at end of file +end 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,2503 +1,2710 @@ (* Title: CoW/Submonoids.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 Submonoids imports CoWBasic begin chapter \Submonoids of a free monoid\ text\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\. +See more in Chapter 1 of @{cite Lo83}. \ section \Hull\ text\First, we define the hull of a set of words, that is, the monoid generated by them.\ inductive_set hull :: "'a list set \ 'a list set" ("\_\") for G where - emp_in[simp]: "\ \ \G\" | - prod_cl: "w1 \ G \ w2 \ \G\ \ w1 \ w2 \ \G\" + emp_in[simp]: "\ \ \G\" | + prod_cl: "w1 \ G \ w2 \ \G\ \ w1 \ w2 \ \G\" lemmas [intro] = hull.intros lemma hull_closed[intro]: "w1 \ \G\ \ w2 \ \G\ \ w1 \ w2 \ \G\" - by (rule hull.induct[of w1 G "\ x. (x\w2)\\G\"]) auto+ + by (rule hull.induct[of w1 G "\ x. (x\w2)\\G\"]) auto+ lemma gen_in [intro]: "w \ G \ w \ \G\" - using hull.prod_cl by fastforce - -lemma hull_induct: assumes "x \ \G\" "P \" "\w. w \ G \ P w" -"\w1 w2. w1 \ \G\ \ P w1 \ w2 \ \G\ \ P w2 \ P (w1 \ w2)" shows "P x" - using hull.induct[of _ _ P, OF \x \ \G\\ \P \\] - assms by (simp add: gen_in) - + using hull.prod_cl by force + +lemma hull_induct: assumes "x \ \G\" "P \" "\w. w \ G \ P w" + "\w1 w2. w1 \ \G\ \ P w1 \ w2 \ \G\ \ P w2 \ P (w1 \ w2)" shows "P x" + using hull.induct[of _ _ P, OF \x \ \G\\ \P \\] + assms by (simp add: gen_in) + lemma genset_sub[simp]: "G \ \G\" - using gen_in .. + using gen_in .. lemma genset_sub_lists: "ws \ lists G \ ws \ lists \G\" using sub_lists_mono[OF genset_sub]. lemma in_lists_conv_set_subset: "set ws \ G \ ws \ lists G" by blast lemma concat_in_hull [intro]: assumes "set ws \ G" shows "concat ws \ \G\" using assms by (induction ws) auto lemma concat_in_hull' [intro]: assumes "ws \ lists G" shows "concat ws \ \G\" using assms by (induction ws) auto -lemma hull_concat_lists0: "w \ \G\ \ (\ ws \ lists G. concat ws = w)" -proof(rule hull.induct[of _ G], simp) +lemma hull_concat_lists0: "w \ \G\ \ (\ ws \ lists G. concat ws = w)" +proof(rule hull.induct[of _ G]) show "\ws\lists G. concat ws = \" using concat.simps(1) lists.Nil[of G] exI[of "\ x. concat x = \", OF concat.simps(1)] by blast show " \w1 w2. w1 \ G \ w2 \ \G\ \ \ws\lists G. concat ws = w2 \ \ws\lists G. concat ws = w1 \ w2" - using Cons_in_lists_iff concat.simps(2) by metis -qed - -lemma hull_concat_listsE: assumes "w \ \G\" + using Cons_in_lists_iff concat.simps(2) by metis +qed simp + +lemma hull_concat_listsE: assumes "w \ \G\" obtains ws where "ws \ lists G" and "concat ws = w" - using assms hull_concat_lists0 by auto + using assms hull_concat_lists0 by blast lemma hull_concat_lists: "\G\ = concat ` lists G" - using hull_concat_lists0 by blast + using hull_concat_lists0 by blast lemma concat_tl: "x # xs \ lists G \ concat xs \ \G\" by (simp add: hull_concat_lists) -lemma nemp_concat_hull: assumes "us \ \" and "us \ lists G\<^sub>+" +lemma nemp_concat_hull: assumes "us \ \" and "us \ lists (G - {\})" shows "concat us \ \G\" and "concat us \ \" using assms by fastforce+ -lemma hull_mono: "A \ B \ \A\ \ \B\" -proof +lemma hull_mono: "A \ B \ \A\ \ \B\" +proof fix x assume "A \ B" "x \ \A\" - thus "x \ \B\" + thus "x \ \B\" unfolding image_def hull_concat_lists using sub_lists_mono[OF \A \ B\] by blast qed lemma emp_gen_set: "\{}\ = {\}" - unfolding hull_concat_lists by auto - -lemma hull_drop_one: "\G\ = \G\<^sub>+\" + unfolding hull_concat_lists by auto + +lemma concat_lists_minus[simp]: "concat ` lists (G - {\}) = concat ` lists G" +proof + show "concat ` lists G \ concat ` lists (G - {\})" + proof + fix x assume "x \ concat ` lists G" + from imageE[OF this] + obtain y where "x = concat y" "y \ lists G". + from lists_minus'[OF \y \ lists G\] del_emp_concat[of y, folded \x = concat y\] + show "x \ concat ` lists (G - {\})" + by blast + qed +qed (simp add: image_mono lists_mono) + +lemma hull_drop_one: "\G - {\}\ = \G\" proof (intro equalityI subsetI) - fix x assume "x \ \G\" thus "x \ \G\<^sub>+\" - unfolding hull_concat_lists using del_emp_concat lists_drop_emp' by blast + fix x assume "x \ \G\" thus "x \ \G - {\}\" + unfolding hull_concat_lists by simp next - fix x assume "x \ \G\<^sub>+\" thus "x \ \G\" + fix x assume "x \ \G - {\}\" thus "x \ \G\" unfolding hull_concat_lists image_iff by auto -qed - -lemma sing_gen_power: "u \ \{x}\ \ \k. u = x\<^sup>@k" - unfolding hull_concat_lists using one_generated_list_power by auto - -lemma sing_gen: "w \ \{z}\ \ w \ z*" +qed + +lemma sing_gen_power: "u \ \{x}\ \ \k. u = x\<^sup>@k" + unfolding hull_concat_lists using one_generated_list_power by auto + +lemma sing_gen[intro]: "w \ \{z}\ \ w \ z*" using rootI sing_gen_power by blast -lemma sing_genE: +lemma pow_sing_gen[simp]: "x\<^sup>@k \ \{x}\" + using concat_in_hull[OF sing_pow_set_sub, unfolded concat_sing_pow]. + +lemma root_sing_gen: "w \ z* \ w \ \{z}\" + by (elim rootE) force + +lemma sing_genE[elim]: assumes "u \ \{x}\" obtains k where "x\<^sup>@k = u" -using assms using sing_gen_power by blast - -lemma lists_gen_to_hull: "us \ lists G\<^sub>+ \ us \ lists \G\\<^sub>+" + using assms using sing_gen_power by blast + +lemma sing_gen_root_conv: "w \ \{z}\ \ w \ z*" + using root_sing_gen by blast + +lemma lists_gen_to_hull: "us \ lists (G - {\}) \ us \ lists (\G\ - {\})" using lists_mono genset_sub by force -lemma rev_hull0: "x \ rev ` \G\ \ x \ \rev ` G\" -proof- - assume "x \ rev ` \G\" - then obtain xs where "x = rev (concat xs)" and "xs \ lists G" - unfolding hull_concat_lists by auto - thus "x \ \rev ` G\" unfolding image_iff hull_concat_lists using rev_concat[of xs] - by fastforce -qed - -lemma rev_hull1: "x \ \rev ` G\ \ x \ rev ` \G\" -proof- - assume "x \ \rev ` G\" - then obtain xs where "x = concat xs" and "xs \ lists (rev ` G)" - unfolding hull_concat_lists by blast - hence "rev x \ \G\" - unfolding hull_concat_lists using rev_concat by fastforce - thus "x \ rev ` \G\" - by (simp add: rev_image_eqI) -qed - lemma rev_hull: "rev`\G\ = \rev`G\" - by (simp add: rev_hull0 rev_hull1 set_eq_subset subsetI) +proof + show "rev ` \G\ \ \rev ` G\" + proof + fix x assume "x \ rev ` \G\" + then obtain xs where "x = rev (concat xs)" and "xs \ lists G" + unfolding hull_concat_lists by auto + from rev_in_lists[OF \xs \ lists G\] + have "(map rev (rev xs)) \ lists (rev ` G)" + by fastforce + thus "x \ \rev ` G\" + unfolding image_iff hull_concat_lists + using \x = rev (concat xs)\[unfolded rev_concat] by blast + qed + show "\rev ` G\ \ rev ` \G\" + proof + fix x assume "x \ \rev ` G\" + then obtain xs where "x = concat xs" and "xs \ lists (rev ` G)" + unfolding hull_concat_lists by blast + from rev_in_lists[OF \xs \ lists ((rev ` G))\] + have "map rev (rev xs) \ lists G" + by fastforce + hence "rev x \ \G\" + unfolding \x = concat xs\ rev_concat + by fast + thus "x \ rev ` \G\" + unfolding rev_in_conv. + qed +qed lemma power_in[intro]: "x \ \G\ \ x\<^sup>@k \ \G\" by (induction k, auto) lemma hull_closed_lists: "us \ lists \G\ \ concat us \ \G\" by (induct us, auto) lemma hull_I [intro]: - "\ \ H \ (\ x y. x \ H \ y \ H \ x \ y \ H) \ \H\ = H" - by (standard, use hull.induct[of _ H "\ x. x \ H"] in blast) (simp only: genset_sub) + "\ \ H \ (\ x y. x \ H \ y \ H \ x \ y \ H) \ \H\ = H" + by (standard, use hull.induct[of _ H "\ x. x \ H"] in force) (simp only: genset_sub) lemma self_gen: "\\G\\ = \G\" using image_subsetI[of "lists \G\" concat "\G\", unfolded hull_concat_lists[of "\G\", symmetric], - THEN subset_antisym[OF _ genset_sub[of "\G\"]]] hull_closed_lists[of _ G] by blast - -lemma hull_mono'[intro]: "A \ \B\ \ \A\ \ \B\" + THEN subset_antisym[OF _ genset_sub[of "\G\"]]] hull_closed_lists[of _ G] by blast + +lemma hull_mono'[intro]: "A \ \B\ \ \A\ \ \B\" using hull_mono self_gen by blast lemma hull_conjug [elim]: "w \ \{r\s,s\r}\ \ w \ \{r,s}\" using hull_mono[of "{r\s,s\r}" "\{r,s}\", unfolded self_gen] by blast text\Intersection of hulls is a hull.\ lemma hulls_inter: "\\ {\G\ | G. G \ S}\ = \ {\G\ | G. G \ S}" proof {fix G assume "G \ S" - hence "\\ {\G\ |G. G \ S}\ \ \G\" - using Inter_lower[of "\G\" "{\G\ |G. G \ S}"] mem_Collect_eq[of "\G\" "\ A. \ G. G \ S \ A = \G\"] + hence "\\ {\G\ |G. G \ S}\ \ \G\" + using Inter_lower[of "\G\" "{\G\ |G. G \ S}"] mem_Collect_eq[of "\G\" "\ A. \ G. G \ S \ A = \G\"] hull_mono[of "\ {\G\ |G. G \ S}" "\G\"] unfolding self_gen by auto} - thus "\\ {\G\ |G. G \ S}\ \ \ {\G\ |G. G \ S}" by blast -next + thus "\\ {\G\ |G. G \ S}\ \ \ {\G\ |G. G \ S}" by blast +next show "\ {\G\ |G. G \ S} \ \\ {\G\ |G. G \ S}\" by simp qed lemma hull_keeps_root: "\ u \ A. u \ r* \ w \ \A\ \ w \ r*" by (rule hull.induct[of _ _ "\ x. x \ r*"], auto) -lemma bin_hull_keeps_root [intro]: "u \ r* \ v \ r* \ w \ \{u,v}\ \ w \ r*" +lemma bin_hull_keeps_root [intro]: "u \ r* \ v \ r* \ w \ \{u,v}\ \ w \ r*" by (rule hull.induct[of _ _ "\ x. x \ r*"], auto) lemma bin_comm_hull_comm: "x \ y = y \ x \ u \ \{x,y}\ \ v \ \{x,y}\ \ u \ v = v \ u" - unfolding comm_root using bin_hull_keeps_root by blast + unfolding comm_root using bin_hull_keeps_root by blast lemma[reversal_rule]: "rev ` \{rev u, rev v}\ = \{u,v}\" - by (simp add: rev_hull) + by (simp add: rev_hull) lemma[reversal_rule]: "rev w \ \rev ` G\ \ w \ \G\" unfolding rev_in_conv rev_hull rev_rev_image_eq. section "Factorization into generators" -text\We define a decomposition (or a factorization) of a into elements of a given generating set. Such a decomposition is well defined only +text\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.\ definition decompose :: "'a list set \ 'a list \ 'a list list" ("Dec _ _" [55,55] 56) where - "decompose G u = (SOME us. us \ lists G\<^sub>+ \ concat us = u)" - -lemma dec_ex: assumes "u \ \G\" shows "\ us. (us \ lists G\<^sub>+ \ 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 \ \G\ \ (Dec G u) \ lists G\<^sub>+" + "decompose G u = (SOME us. us \ lists (G - {\}) \ concat us = u)" + +lemma dec_ex: assumes "u \ \G\" shows "\ us. (us \ lists (G - {\}) \ concat us = u)" + using assms unfolding image_def hull_concat_lists[of G] mem_Collect_eq + using del_emp_concat lists_minus' by metis + +lemma dec_in_lists': "u \ \G\ \ (Dec G u) \ lists (G - {\})" unfolding decompose_def using someI_ex[OF dec_ex] by blast lemma concat_dec[simp, intro] : "u \ \G\ \ concat (Dec G u) = u" unfolding decompose_def using someI_ex[OF dec_ex] by blast -lemma dec_emp [simp]: "Dec G \ = \" +lemma dec_emp [simp]: "Dec G \ = \" proof- - have ex: "\ \ lists G\<^sub>+ \ concat \ = \" + have ex: "\ \ lists (G - {\}) \ concat \ = \" by simp - have all: "(us \ lists G\<^sub>+ \ concat us = \) \ us = \" for us + have all: "(us \ lists (G - {\}) \ concat us = \) \ us = \" for us using emp_concat_emp by auto - show ?thesis + show ?thesis unfolding decompose_def - using all[OF someI[of "\ x. x \ lists G\<^sub>+ \ concat x = \", OF ex]]. + using all[OF someI[of "\ x. x \ lists (G - {\}) \ concat x = \", OF ex]]. qed -lemma dec_nemp: "u \ \G\\<^sub>+ \ Dec G u \ \" - using concat_dec[of u G] by force +lemma dec_nemp: "u \ \G\ - {\} \ Dec G u \ \" + using concat_dec[of u G] by force lemma dec_nemp'[simp, intro]: "u \ \ \ u \ \G\ \ Dec G u \ \" using dec_nemp by blast lemma dec_eq_emp_iff [simp]: assumes "u \ \G\" shows "Dec G u = \ \ u = \" using dec_nemp'[OF _ \u \ \G\\] by auto lemma dec_in_lists[simp]: "u \ \G\ \ Dec G u \ lists G" - using decI' by auto + using dec_in_lists' by auto lemma set_dec_sub: "x \ \G\ \ set (Dec G x) \ G" using dec_in_lists by blast lemma dec_hd: "u \ \ \ u \ \G\ \ hd (Dec G u) \ G" - by simp - -lemma non_gen_dec: "u \ \G\ \ u \ G \ Dec G u \ [u]" - using decI' Cons_in_lists_iff by fastforce + by simp + +lemma non_gen_dec: assumes "u \ \G\" "u \ G" shows "Dec G u \ [u]" + using dec_in_lists[OF \u \ \G\\] Cons_in_lists_iff[of u \ G] \u \ G\ by argo subsection \Refinement into a specific decomposition\ text\We extend the decomposition to lists of words. This can be seen as a refinement of a previous decomposition of some word.\ definition refine :: "'a list set \ 'a list list \ 'a list list" ("Ref _ _" [51,51] 65) where "refine G us = concat(map (decompose G) us)" lemma ref_morph: "us \ lists \G\ \ vs \ lists \G\ \ refine G (us \ vs) = refine G us \ refine G vs" unfolding refine_def by simp lemma ref_conjug: "u \ v \ (Ref G u) \ Ref G v" unfolding refine_def by (intro conjug_concat_conjug map_conjug) -lemma ref_morph_plus: "us \ lists \G\\<^sub>+ \ vs \ lists \G\\<^sub>+ \ refine G (us \ vs) = refine G us \ refine G vs" - unfolding refine_def by simp +lemma ref_morph_plus: "us \ lists (\G\ - {\}) \ vs \ lists (\G\ - {\}) \ refine G (us \ vs) = refine G us \ refine G vs" + unfolding refine_def by simp lemma ref_pref_mono: "ws \ lists \G\ \ us \p ws \ Ref G us \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 \ lists \G\ \ us \s ws \ (Ref G us) \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 \ lists \G\ \ us \f ws \ (Ref G us) \f Ref G ws" unfolding sublist_altdef' using ref_pref_mono ref_suf_mono suf_in_lists by metis lemma ref_pop_hd: "us \ \ \ us \ lists \G\ \ refine G us = decompose G (hd us) \ refine G (tl us)" - unfolding refine_def using list.simps(9)[of "decompose G" "hd us" "tl us"] by simp - -lemma ref_in: "us \ lists \G\ \ (Ref G us) \ lists G\<^sub>+" - proof (induction us, simp add: refine_def) - case (Cons a us) - then show ?case - using Cons.IH Cons.prems decI' by (auto simp add: refine_def) -qed + unfolding refine_def using list.simps(9)[of "decompose G" "hd us" "tl us"] by simp + +lemma ref_in: "us \ lists \G\ \ (Ref G us) \ lists (G - {\})" +proof (induction us) + case (Cons a us) + then show ?case + using Cons.IH Cons.prems dec_in_lists' by (auto simp add: refine_def) +qed (simp add: refine_def) lemma ref_in'[intro]: "us \ lists \G\ \ (Ref G us) \ lists G" - using ref_in by fast + using ref_in by auto lemma concat_ref: "us \ lists \G\ \ concat (Ref G us) = concat us" -proof (induction us, simp add: refine_def) +proof (induction us) case (Cons a us) then show ?case - using Cons.IH Cons.prems concat_dec refine_def by (auto simp add: refine_def) - qed - -lemma ref_gen: "us \ lists B \ B \ \G\ \ Ref G us \ \decompose G ` B\" + using Cons.IH Cons.prems concat_dec refine_def by (auto simp add: refine_def) +qed (simp add: refine_def) + +lemma ref_gen: "us \ lists B \ B \ \G\ \ Ref G us \ \decompose G ` B\" by (induct us, auto simp add: refine_def) lemma ref_set: "ws \ lists \G\ \ set (Ref G ws) = \ (set`(decompose G)`set ws)" by (simp add: refine_def) -lemma emp_ref: assumes "us \ lists \G\\<^sub>+" and "Ref G us = \" shows "us = \" - using emp_concat_emp[OF \us \ lists \G\\<^sub>+\] - concat_ref [OF lists_drop_emp[OF assms(1)], unfolded \Ref G us = \\ concat.simps(1),symmetric] by blast - -lemma sing_ref_sing: - assumes "us \ lists \G\\<^sub>+" and "refine G us = [b]" +lemma emp_ref: assumes "us \ lists (\G\ - {\})" and "Ref G us = \" shows "us = \" + using emp_concat_emp[OF \us \ lists (\G\ - {\})\] + concat_ref [OF lists_minus[OF assms(1)], unfolded \Ref G us = \\ concat.simps(1),symmetric] by blast + +lemma sing_ref_sing: + assumes "us \ lists (\G\ - {\})" and "refine G us = [b]" shows "us = [b]" proof- have "us \ \" using \refine G us = [b]\ by (auto simp add: refine_def) - have "tl us \ lists \G\\<^sub>+" and "hd us \ \G\\<^sub>+" - using list.collapse[OF \us \ \\] \us \ lists \G\\<^sub>+\ Cons_in_lists_iff[of "hd us" "tl us" "\G\\<^sub>+"] + have "tl us \ lists (\G\ - {\})" and "hd us \ \G\ - {\}" + using list.collapse[OF \us \ \\] \us \ lists (\G\ - {\})\ Cons_in_lists_iff[of "hd us" "tl us" "\G\ - {\}"] by auto - have "Dec G (hd us) \ \" - using dec_nemp[OF \hd us \ \G\\<^sub>+\]. + have "Dec G (hd us) \ \" + using dec_nemp[OF \hd us \ \G\ - {\}\]. have "us \ lists \G\" - using \us \ lists \G\\<^sub>+\ lists_drop_emp by auto + using \us \ lists (\G\ - {\})\ lists_minus by auto have "concat us = b" - using \us \ lists \G\\ assms(2) concat_ref by force + using \us \ lists \G\\ assms(2) concat_ref by force have "refine G (tl us) = \" - using ref_pop_hd[OF \us \ \\ \us \ lists \G\\] unfolding \refine G us = [b]\ + using ref_pop_hd[OF \us \ \\ \us \ lists \G\\] unfolding \refine G us = [b]\ using \Dec G (hd us) \ \\ Cons_eq_append_conv[of b \ "(Dec G (hd us))" "(Ref G (tl us))"] Cons_eq_append_conv[of b \ "(Dec G (hd us))" "(Ref G (tl us))"] append_is_Nil_conv[of _ "(Ref G (tl us))"] by blast - from emp_ref[OF \tl us \ lists \G\\<^sub>+\ this, symmetric] + from emp_ref[OF \tl us \ lists (\G\ - {\})\ this, symmetric] have "\ = tl us". from this[unfolded Nil_tl] show ?thesis - using \us \ \\ \concat us = b\ by auto + using \us \ \\ \concat us = b\ by auto qed -lemma ref_ex: assumes "Q \ \G\" and "us \ lists Q" - shows "Ref G us \ lists G\<^sub>+" and "concat (Ref G us) = concat us" +lemma ref_ex: assumes "Q \ \G\" and "us \ lists Q" + shows "Ref G us \ lists (G - {\})" and "concat (Ref G us) = concat us" using ref_in[OF sub_lists_mono[OF assms]] concat_ref[OF sub_lists_mono[OF assms]]. section "Basis" text\An important property of monoids of words is that they have a unique minimal generating set. Which is the set consisting of indecomposable elements.\ text\The simple element is defined as a word which has only trivial decomposition into generators: a singleton.\ definition simple_element :: "'a list \ 'a list set \ bool" (" _ \B _ " [51,51] 50) where - "simple_element b G = (b \ G \ (\ us. us \ lists G\<^sub>+ \ concat us = b \ \<^bold>|us\<^bold>| = 1))" + "simple_element b G = (b \ G \ (\ us. us \ lists (G - {\}) \ concat us = b \ \<^bold>|us\<^bold>| = 1))" lemma simp_el_el: "b \B G \ b \ G" - unfolding simple_element_def by blast - -lemma simp_elD: "b \B G \ us \ lists G\<^sub>+ \ concat us = b \ \<^bold>|us\<^bold>| = 1" - unfolding simple_element_def by blast - -lemma simp_el_sing: assumes "b \B G" "us \ lists G\<^sub>+" "concat us = b" shows "us = [b]" - using simp_elD[OF assms] \concat us = b\ concat_len_one sing_word by fastforce - -lemma nonsimp: "us \ lists G\<^sub>+ \ concat us \B G \ us = [concat us]" - using simp_el_sing[of "concat us" G us] unfolding simple_element_def + unfolding simple_element_def by blast + +lemma simp_elD: "b \B G \ us \ lists (G - {\}) \ concat us = b \ \<^bold>|us\<^bold>| = 1" + unfolding simple_element_def by blast + +lemma simp_el_sing: assumes "b \B G" "us \ lists (G - {\})" "concat us = b" shows "us = [b]" + using \concat us = b\ concat_len_one[OF simp_elD[OF assms]] sing_word[OF simp_elD[OF assms]] by simp + +lemma nonsimp: "us \ lists (G - {\}) \ concat us \B G \ us = [concat us]" + using simp_el_sing[of "concat us" G us] unfolding simple_element_def by blast -lemma emp_nonsimp: "\ \ \B G" - unfolding simple_element_def using list.size(3) concat.simps(1) lists.Nil[of "G\<^sub>+"] - by fastforce +lemma emp_nonsimp: assumes "b \B G" shows "b \ \" + using simp_elD[OF assms, of \] by force lemma basis_no_fact: assumes "u \ \G\" and "v \ \G\" and "u \ v \B G" shows "u = \ \ v = \" proof- have eq1: "concat ((Dec G u) \ (Dec G v)) = u \ v" - using concat_morph[of "Dec G u" "Dec G v"] + using concat_morph[of "Dec G u" "Dec G v"] unfolding concat_dec[OF \u \ \G\\] concat_dec[OF \v \ \G\\]. have eq2: "(Dec G u) \ (Dec G v) = [u \ v]" - using \u \ v \B G\ nonsimp[of "(Dec G u) \ (Dec G v)"] - unfolding eq1 append_in_lists_conv[of "(Dec G u)" "(Dec G v)" "G\<^sub>+"] - using decI'[OF \u \ \G\\] decI'[OF \v \ \G\\] - by (meson append_in_lists_conv) + using \u \ v \B G\ nonsimp[of "(Dec G u) \ (Dec G v)"] + unfolding eq1 append_in_lists_conv[of "(Dec G u)" "(Dec G v)" "G - {\}"] + using dec_in_lists'[OF \u \ \G\\] dec_in_lists'[OF \v \ \G\\] + by (meson append_in_lists_conv) have "Dec G u = \ \ Dec G v = \" - using butlast_append[of "Dec G u" "Dec G v"] unfolding eq2 butlast.simps(2)[of "u\v" \] - 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\v" \] + using Nil_is_append_conv[of "Dec G u" "butlast (Dec G v)"] by auto thus ?thesis using concat_dec[OF \u \ \G\\] concat_dec[OF \v \ \G\\] concat.simps(1) - by auto + by auto qed lemma simp_elI: assumes "b \ G" and "b \ \" and all: "\ u v. u \ \ \ u \ \G\ \ v \ \ \ v \ \G\ \ u \ v \ b" shows "b \B G" unfolding simple_element_def -proof(simp add: \b \ G\, standard, standard, elim conjE) - fix us assume "us \ lists G\<^sub>+" "concat us = b" - hence "us \ \" using \b \ \\ concat.simps(1) by blast - hence "hd us \ \G\" and "hd us \ \" - using \us \ lists G\<^sub>+\ lists_hd_in_set gen_in by auto - have "tl us = \" - proof(rule ccontr) - assume "tl us \ \" - from nemp_concat_hull[of "tl us", OF this tl_in_lists[OF \us \ lists G\<^sub>+\]] - show False - using all \hd us \ \\ \hd us \ \G\\ concat.simps(2)[of "hd us" "tl us", symmetric] - unfolding list.collapse[OF \us \ \\] \concat us = b\ - by blast +proof(rule conjI) + show "\us. us \ lists (G - {\}) \ concat us = b \ \<^bold>|us\<^bold>| = 1" + proof (rule allI, rule impI, elim conjE) + fix us assume "us \ lists (G - {\})" "concat us = b" + hence "us \ \" using \b \ \\ concat.simps(1) by blast + hence "hd us \ \G\" and "hd us \ \" + using \us \ lists (G - {\})\ lists_hd_in_set gen_in by auto + have "tl us = \" + proof(rule ccontr) + assume "tl us \ \" + from nemp_concat_hull[of "tl us", OF this tl_in_lists[OF \us \ lists (G - {\})\]] + show False + using all \hd us \ \\ \hd us \ \G\\ concat.simps(2)[of "hd us" "tl us", symmetric] + unfolding list.collapse[OF \us \ \\] \concat us = b\ + by blast + qed + thus "\<^bold>|us\<^bold>| = 1" + using long_list_tl[of us] Nitpick.size_list_simp(2)[of us] \us \ \\ by fastforce qed - hence "\<^bold>|us\<^bold>| = 1" - using \concat us = b\ assms(2) long_list_tl nonsing_concat_len by blast - thus "\<^bold>|us\<^bold>| = Suc 0" - by (simp add: \b \ G\) -qed - -lemma simp_el_indecomp: - assumes "b \B G" - shows "b \ G" and "b \ \" and "\ u v. u \ \ \ u \ \G\ \ v \ \ \ v \ \G\ \ u \ v \ b" - using assms basis_no_fact emp_nonsimp simple_element_def by blast+ +qed (simp add: \b \ G\) + +lemma simp_el_indecomp: + assumes "b \B G" "u \ \" "u \ \G\" "v \ \" "v \ \G\" + shows "u \ v \ b" + using basis_no_fact[OF \u \ \G\\ \v \ \G\\] \u \ \\ \v \ \\ \b \B G\ by blast text\We are ready to define the \emph{basis} as the set of all simple elements.\ definition basis :: "'a list set \ 'a list set" ("\ _" [51] ) where - "basis G = {x. x \B G}" + "basis G = {x. x \B G}" lemma basis_inI: "x \B G \ x \ \ G" unfolding basis_def by simp lemma basisD: "x \ \ G \ x \B G" - unfolding basis_def by simp + unfolding basis_def by simp lemma emp_not_basis: "x \ \ G \ x \ \" - using basisD emp_nonsimp by blast + using basisD emp_nonsimp by blast lemma basis_sub: "\ G \ G" - unfolding basis_def simple_element_def by simp - -lemma basis_drop_emp: "(\ G)\<^sub>+ = \ G" + unfolding basis_def simple_element_def by simp + +lemma basis_drop_emp: "(\ G) - {\} = \ G" using emp_not_basis by blast -lemma simp_el_hull': assumes "b \B \G\" shows "b \B G" +lemma simp_el_hull': assumes "b \B \G\" shows "b \B G" proof- - have all: "\us. us \ lists G\<^sub>+ \ concat us = b \ \<^bold>|us\<^bold>| = 1" + have all: "\us. us \ lists (G - {\}) \ concat us = b \ \<^bold>|us\<^bold>| = 1" using assms lists_gen_to_hull unfolding simple_element_def by metis have "b \ \G\" using assms simp_elD unfolding simple_element_def by blast - obtain bs where "bs \ lists G\<^sub>+" and "concat bs = b" + obtain bs where "bs \ lists (G - {\})" and "concat bs = b" using dec_ex[OF \b \ \G\\] by blast have "b \ G" - using lists_drop_emp[OF \bs \ lists G\<^sub>+\] - lists_gen_to_hull[OF \bs \ lists G\<^sub>+\, THEN nonsimp[of bs "\G\"], - unfolded \concat bs = b\, OF \b \B \G\\] by simp + using + lists_minus[OF \bs \ lists (G - {\})\] + lists_gen_to_hull[OF \bs \ lists (G - {\})\, THEN nonsimp[of bs "\G\"], + unfolded \concat bs = b\, OF \b \B \G\\] by force thus "b \B G" by (simp add: all simple_element_def) qed lemma simp_el_hull: assumes "b \B G" shows "b \B \G\" - using simp_elI[of b "\G\"] unfolding self_gen - using assms gen_in simp_el_indecomp[OF \b \B G\] by auto + using simp_elI[of b "\G\", OF _ emp_nonsimp[OF assms]] unfolding self_gen + using simp_el_indecomp[OF \b \B G\] gen_in[OF simp_el_el[OF assms]] by presburger lemma concat_tl_basis: "x # xs \ lists \ G \ concat xs \ \G\" unfolding hull_concat_lists basis_def simple_element_def by auto -text\The basis generates the hull\ - -lemma set_concat_len: assumes "us \ lists G\<^sub>+" "1 < \<^bold>|us\<^bold>|" "u \ set us" shows "\<^bold>|u\<^bold>| < \<^bold>|concat us\<^bold>|" +text\The basis generates the hull\ + +lemma set_concat_len: assumes "us \ lists (G - {\})" "1 < \<^bold>|us\<^bold>|" "u \ set us" shows "\<^bold>|u\<^bold>| < \<^bold>|concat us\<^bold>|" proof- obtain x y where "us = x \ [u] \ y" and "x \ y \ \" - using split_list_long[OF \1 < \<^bold>|us\<^bold>|\ \u \ set us\]. - hence "x \ y \ lists G\<^sub>+" - using \us \ lists G\<^sub>+\ by auto - hence "\<^bold>|concat (x \ y)\<^bold>| \ 0" - using \x \ y \ \\ in_lists_conv_set by force + using split_list_long[OF \1 < \<^bold>|us\<^bold>|\ \u \ set us\]. + hence "x \ y \ lists (G - {\})" + using \us \ lists (G - {\})\ by auto + hence "\<^bold>|concat (x \ y)\<^bold>| \ 0" + using \x \ y \ \\ in_lists_conv_set by force hence "\<^bold>|concat us\<^bold>| = \<^bold>|u\<^bold>| + \<^bold>|concat x\<^bold>| + \<^bold>|concat y\<^bold>|" using lenmorph \us = x \ [u] \ y\ by simp thus ?thesis using \\<^bold>|concat (x \ y)\<^bold>| \ 0\ by auto -qed +qed lemma non_simp_dec: assumes "w \ \ G" "w \ \" "w \ G" - obtains us where "us \ lists G\<^sub>+" "1 < \<^bold>|us\<^bold>|" "concat us = w" - using \w \ \\ \w \ G\ \w \ \ G\ nonsing_concat_len basis_inI[of w G, unfolded simple_element_def] - by blast + obtains us where "us \ lists (G - {\})" "1 < \<^bold>|us\<^bold>|" "concat us = w" + using \w \ \\ \w \ G\ \w \ \ G\ basis_inI[of w G, unfolded simple_element_def] + using concat.simps(1) nemp_le_len nless_le by metis + lemma basis_gen: "w \ G \ w \ \\ G\" proof (induct "length w" arbitrary: w rule: less_induct) case less show ?case proof (cases "w \ \ G \ w = \", blast) assume "\ (w \ \ G \ w = \)" - with \w \ G\ - obtain us where "us \ lists G\<^sub>+" "1 < \<^bold>|us\<^bold>|" "concat us = w" - using non_simp_dec by blast + with \w \ G\ + obtain us where "us \ lists (G - {\})" "1 < \<^bold>|us\<^bold>|" "concat us = w" + using non_simp_dec by blast have "u \ set us \ u \ \\ G\" for u - using lists_drop_emp[OF \us \ lists G\<^sub>+\] less(1)[OF set_concat_len[OF \us \ lists G\<^sub>+\ \1 < \<^bold>|us\<^bold>|\, unfolded \concat us = w\], of u] + using lists_minus[OF \us \ lists (G - {\})\] less(1)[OF set_concat_len[OF \us \ lists (G - {\})\ \1 < \<^bold>|us\<^bold>|\, unfolded \concat us = w\], of u] by blast thus "w \ \\ G\ " unfolding \concat us = w\[symmetric] - using hull_closed_lists[OF in_listsI] by blast + 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: "\\ G\ = \G\" proof show "\\ G\ \ \G\" unfolding hull_concat_lists basis_def simple_element_def by auto - show "\G\ \ \\ G\" - proof + show "\G\ \ \\ G\" + proof fix x show "x \ \G\ \ x \ \\ G\" proof (induct rule: hull.induct) show "\w1 w2. w1 \ G \ w2 \ \\ G\ \ w1 \ w2 \ \\ G\" - using hull_closed[of _ "\ G"] basis_gen[of _ G] by blast + using hull_closed[of _ "\ G"] basis_gen[of _ G] by blast qed auto qed qed lemma basis_gen_hull': "\\ \G\\ = \G\" using basis_gen_hull self_gen by blast theorem basis_of_hull: "\ \G\ = \ G" proof show "\ G \ \ \G\" using basisD basis_inI simp_el_hull by blast show "\ \G\ \ \ G" using basisD basis_inI simp_el_hull' by blast qed lemma basis_hull_sub: "\ \G\ \ G" - using basis_of_hull basis_sub by fast + using basis_of_hull basis_sub by blast text\The basis is the smallest generating set.\ theorem basis_sub_gen: "\S\ = \G\ \ \ G \ S" - using basis_of_hull basis_sub by metis + using basis_of_hull basis_sub by metis lemma basis_min_gen: "S \ \ G \ \S\ = G \ S = \ G" using basis_of_hull basis_sub by blast lemma basisI: "(\ B. \B\ = \C\ \ C \ B) \ \ \C\ = C" - using basis_gen_hull basis_min_gen basis_of_hull by metis + using basis_gen_hull basis_min_gen basis_of_hull by metis thm basis_inI text\An arbitrary set between basis and the hull is generating...\ lemma gen_sets: assumes "\ G \ S" and "S \ \G\" shows "\S\ = \G\" using image_mono[OF lists_mono[of S "\G\"], of concat, OF \S \ \G\\] image_mono[OF lists_mono[of "\ G" S], of concat, OF \\ G \ S\] - unfolding sym[OF hull_concat_lists] basis_gen_hull - using subset_antisym[of "\S\" "\G\"] self_gen by auto + unfolding sym[OF hull_concat_lists] basis_gen_hull + using subset_antisym[of "\S\" "\G\"] self_gen by metis text\... and has the same basis\ lemma basis_sets: "\ G \ S \ S \ \G\ \ \ G = \ S" by (metis basis_of_hull gen_sets) text\Any nonempty composed element has a decomposition into basis elements with many useful properties\ lemma non_simp_fac: assumes "w \ \" and "w \ \G\" and "w \ \ G" - obtains us where "1 < \<^bold>|us\<^bold>|" and "us \ \" and "us \ lists \ G" and - "hd us \ \" and "hd us \ \G\" and - "concat(tl us) \ \" and "concat(tl us) \ \G\" and + obtains us where "1 < \<^bold>|us\<^bold>|" and "us \ \" and "us \ lists \ G" and + "hd us \ \" and "hd us \ \G\" and + "concat(tl us) \ \" and "concat(tl us) \ \G\" and "w = hd us \ concat(tl us)" proof- obtain us where "us \ lists \ G" and "concat us = w" using \w \ \G\\ dec_in_lists[of w "\ G"] concat_dec[of w "\ G"] unfolding basis_gen_hull by blast hence "us \ \" using \w \ \\ concat.simps(1) by blast from lists_hd_in_set[OF this \us \ lists \ G\, THEN emp_not_basis] lists_hd_in_set[OF this \us \ lists \ G\, THEN gen_in[of "hd us" "\ G", unfolded basis_gen_hull]] have "hd us \ \" and "hd us \ \G\". have "1 < \<^bold>|us\<^bold>|" - using \w \ \ G\ lists_hd_in_set[OF \us \ \\ \us \ lists \ G\] \w \ \\ \w \ \G\\ - concat_len_one[of us, unfolded \concat us = w\] nonsing_concat_len[of us, unfolded \concat us = w\] by blast + using \w \ \ G\ lists_hd_in_set[OF \us \ \\ \us \ lists \ G\] \w \ \\ \w \ \G\\ + concat_len_one[of us, unfolded \concat us = w\] + \us \ \\ leI nemp_le_len order_antisym_conv by metis from nemp_concat_hull[OF long_list_tl[OF this], of "\ G", unfolded basis_drop_emp basis_gen_hull, OF tl_in_lists[OF \us \ lists \ G\]] have "concat (tl us) \ \G\" and "concat(tl us) \ \". have "w = hd us \ concat(tl us)" using \us \ \\ \us \ lists \ G\ \concat us = w\ concat.simps(2)[of "hd us" "tl us"] list.collapse[of us] by argo - from that[OF \1 < \<^bold>|us\<^bold>|\ \us \ \\ \us \ lists \ G\ \hd us \ \\ \hd us \ \G\\ \concat (tl us) \ \\ \concat (tl us) \ \G\\ this] + from that[OF \1 < \<^bold>|us\<^bold>|\ \us \ \\ \us \ lists \ G\ \hd us \ \\ \hd us \ \G\\ \concat (tl us) \ \\ \concat (tl us) \ \G\\ this] show thesis. qed -lemma basis_dec: "p \ \G\ \ s \ \G\ \ p \ s \ \ G \ p = \ \ s = \" - using basis_no_fact[of p G s] unfolding basis_def by simp - -lemma non_simp_fac': "w \ \ G \ w \ \ \ w \ \G\ \ \us. us \ lists G\<^sub>+ \ w = concat us \ \<^bold>|us\<^bold>| \ 1" - 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>+ = {} \ \G\ = {\}" +lemma basis_dec: "p \ \G\ \ s \ \G\ \ p \ s \ \ G \ p = \ \ s = \" + using basis_no_fact[of p G s] unfolding basis_def by simp + +lemma non_simp_fac': "w \ \ G \ w \ \ \ w \ \G\ \ \us. us \ lists (G - {\}) \ w = concat us \ \<^bold>|us\<^bold>| \ 1" + by (metis basis_inI concat_len_one dec_in_lists' dec_in_lists concat_dec dec_nemp lists_hd_in_set nemp_elem_setI simple_element_def) + +lemma emp_gen_iff: "(G - {\}) = {} \ \G\ = {\}" proof - assume "G\<^sub>+ = {}" show "\G\ = {\}" - using hull_drop_one[of G, unfolded \G\<^sub>+ = {}\ emp_gen_set]. + assume "G - {\} = {}" show "\G\ = {\}" + using hull_drop_one[of G, unfolded \G - {\} = {}\ emp_gen_set] by simp next - assume "\G\ = {\}" thus"G\<^sub>+ = {}" by blast + assume "\G\ = {\}" thus"G - {\} = {}" by blast qed -lemma emp_basis_iff: "\ G = {} \ G\<^sub>+ = {}" - using emp_gen_iff[of "\ G", unfolded basis_gen_hull basis_drop_emp, folded emp_gen_iff]. +lemma emp_basis_iff: "\ G = {} \ G - {\} = {}" + using emp_gen_iff[of "\ G", unfolded basis_gen_hull basis_drop_emp, folded emp_gen_iff]. section "Code" -locale nemp_words = +locale nemp_words = fixes G assumes emp_not_in: "\ \ G" begin -lemma drop_empD: "G\<^sub>+ = G" +lemma drop_empD: "G - {\} = 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 \ lists G" and "concat (take i ws) \p concat (take j ws)" +thm disjE[OF ruler[OF take_is_prefix take_is_prefix]] + +lemma concat_take_mono: assumes "ws \ lists G" and "concat (take i ws) \p concat (take j ws)" shows "take i ws \p take j ws" -proof (rule disjE[OF ruler[OF take_is_prefix[of i ws] take_is_prefix[of j ws]]], simp) +proof (rule disjE[OF ruler[OF take_is_prefix take_is_prefix]]) assume "take j ws \p take i ws" from prefixE[OF this] obtain us where "take i ws = take j ws \ us". hence "us \ lists G" using \ws \ lists G\ using append_in_lists_conv take_in_lists by metis have "concat (take j ws) = concat (take i ws)" using pref_concat_pref[OF \take j ws \p take i ws\] assms(2) by simp from arg_cong[OF \take i ws = take j ws \ us\, of concat, unfolded concat_morph, unfolded this] have "us = \" using \us \ lists G\ emp_concat_emp' by blast - thus "take i ws \p take j ws" + thus "take i ws \p take j ws" using \take i ws = take j ws \ us\ by force qed -lemma in_gen_nemp: "x \ G \ x \ \" +lemma nemp: "x \ G \ x \ \" using emp_not_in by blast lemma code_concat_eq_emp_iff [simp]: "us \ lists G \ concat us = \ \ us = \" unfolding in_lists_conv_set concat_eq_Nil_conv - by (simp add: in_gen_nemp) + by (simp add: nemp) lemma root_dec_inj_on: "inj_on (\ x. [\ x]\<^sup>@(e\<^sub>\ x)) G" - unfolding inj_on_def using in_gen_nemp[THEN primroot_exp_eq] + unfolding inj_on_def using primroot_exp_eq unfolding concat_sing_pow[of "\ _", symmetric] by metis -lemma concat_root_dec_eq_concat: - assumes "ws \ lists G" +lemma concat_root_dec_eq_concat: + assumes "ws \ lists G" shows "concat (concat (map (\ x. [\ x]\<^sup>@(e\<^sub>\ x)) ws)) = concat ws" - (is "concat(concat (map ?R 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) + by (induction ws, simp_all add: nemp) end -text\A basis freely generating its hull is called a \emph{code}. By definition, +text\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.\ locale code = fixes \ assumes is_code: "xs \ lists \ \ ys \ lists \ \ concat xs = concat ys \ xs = ys" begin lemma code_not_comm: "x \ \ \ y \ \ \ x \ y \ x \ y \ y \ x" using is_code[of "[x,y]" "[y,x]"] by auto -lemma emp_not_in_code: "\ \ \" +lemma emp_not_in: "\ \ \" proof assume "\ \ \" hence "[] \ lists \" and "[\] \ lists \" and "concat [] = concat [\]" and "[] \ [\]" by simp+ - thus False + thus False using is_code by blast qed +lemma nemp: "u \ \ \ u \ \" + using emp_not_in by force + + sublocale nemp_words \ - using emp_not_in_code by unfold_locales - -lemmas in_code_nemp = in_gen_nemp - -lemma code_simple: "c \ \ \ c \B \" - unfolding simple_element_def -proof - fix c assume "c \ \" + using emp_not_in by unfold_locales + +lemma code_simple: "c \ \ \ c \B \" + unfolding simple_element_def +proof + fix c assume "c \ \" hence "[c] \ lists \" by simp - show "\us. us \ lists \\<^sub>+ \ concat us = c \ \<^bold>|us\<^bold>| = 1" + show "\us. us \ lists (\ - {\}) \ concat us = c \ \<^bold>|us\<^bold>| = 1" proof fix us - {assume "us \ lists \\<^sub>+" "concat us = c" + {assume "us \ lists (\ - {\})" "concat us = c" hence "us \ lists \" by blast - hence "us = [c]" - using \concat us = c\ \c \ \\ is_code[of "[c]", OF \[c] \ lists \\ \us \ lists \\] emp_not_in_code by auto} - thus "us \ lists \\<^sub>+ \ concat us = c \ \<^bold>|us\<^bold>| = 1" - using sing_len[of c] by fastforce + hence "us = [c]" + using \concat us = c\ \c \ \\ is_code[of "[c]", OF \[c] \ lists \\ \us \ lists \\] emp_not_in by auto} + thus "us \ lists (\ - {\}) \ concat us = c \ \<^bold>|us\<^bold>| = 1" + using sing_len[of c] by fastforce qed qed lemma code_is_basis: "\ \ = \" using code_simple basis_def[of \] basis_sub by blast lemma code_unique_dec': "us \ lists \ \ Dec \ (concat us) = us" - using dec_in_lists[of "concat us" \, THEN is_code, of us] + using dec_in_lists[of "concat us" \, THEN is_code, of us] concat_dec[of "concat us" \] hull_concat_lists[of \] image_eqI[of "concat us" concat us "lists \"] by argo lemma code_unique_dec [intro!]: "us \ lists \ \ concat us = u \ Dec \ u = us" using code_unique_dec' by blast lemma triv_refine[intro!] : "us \ lists \ \ concat us = u \ Ref \ [u] = us" - using code_unique_dec' by (auto simp add: refine_def) + using code_unique_dec' by (auto simp add: refine_def) lemma code_unique_ref: "us \ lists \\\ \ refine \ us = decompose \ (concat us)" proof- assume "us \ lists \\\" hence "concat (refine \ us) = concat us" - using concat_ref by fastforce + using concat_ref by blast hence eq: "concat (refine \ us) = concat (decompose \ (concat us))" - using concat_dec[OF hull_closed_lists[OF \us \ lists \\\\]] by auto + using concat_dec[OF hull_closed_lists[OF \us \ lists \\\\]] by auto have dec: "Dec \ (concat us) \ lists \" using \us \ lists \\\\ dec_in_lists hull_closed_lists - by metis + by metis have "Ref \ us \ lists \" - using lists_drop_emp[OF ref_in[OF \us \ lists \\\\]]. + using lists_minus[OF ref_in[OF \us \ lists \\\\]]. from is_code[OF this dec eq] show ?thesis. qed lemma refI [intro]: "us \ lists \\\ \ vs \ lists \ \ concat vs = concat us \ Ref \ us = vs" unfolding code_unique_ref code_unique_dec.. -lemma code_dec_morph: assumes "x \ \\\" "y \ \\\" +lemma code_dec_morph: assumes "x \ \\\" "y \ \\\" shows "(Dec \ x) \ (Dec \ y) = Dec \ (x\y)" proof- have eq: "(Dec \ x) \ (Dec \ y) = Dec \ (concat ((Dec \ x) \ (Dec \ y)))" using dec_in_lists[OF \x \ \\\\] dec_in_lists[OF \y \ \\\\] code.code_unique_dec[OF code_axioms, of "(Dec \ x) \ (Dec \ y)", unfolded append_in_lists_conv, symmetric] - by presburger + by presburger moreover have "concat ((Dec \ x) \ (Dec \ y)) = (x \ y)" using concat_morph[of "Dec \ x" "Dec \ y"] unfolding concat_dec[OF \x \ \\\\] concat_dec[OF \y \ \\\\]. ultimately show "(Dec \ x) \ (Dec \ y) = Dec \ (x\y)" by argo qed lemma dec_pow: "rs \ \\\ \ Dec \ (rs\<^sup>@k) = (Dec \ 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 + using code_dec_morph pow_Suc power_in by metis qed - -lemma code_el_dec: "c \ \ \ decompose \ c = [c]" + +lemma code_el_dec: "c \ \ \ decompose \ c = [c]" by fastforce lemma code_ref_list: "us \ lists \ \ refine \ us = us" proof (induct us) case (Cons a us) then show ?case using code_el_dec unfolding refine_def by simp qed (simp add: refine_def) -lemma code_ref_gen: assumes "G \ \\\" "u \ \G\" +lemma code_ref_gen: assumes "G \ \\\" "u \ \G\" shows "Dec \ u \ \decompose \ ` G\" proof- have "refine \ (Dec G u) = Dec \ u" using dec_in_lists[OF \u \ \G\\] \G \ \\\\ code_unique_ref[of "Dec G u", unfolded concat_dec[OF \u \ \G\\]] by blast from ref_gen[of "Dec G u" G, OF dec_in_lists[OF \u \ \G\\], of \, unfolded this, OF \G \ \\\\] show ?thesis. qed +find_theorems "\ ?x \<^sup>@ ?k = ?x" "0 < ?k" + lemma code_rev_code: "code (rev ` \)" proof fix xs ys assume "xs \ lists (rev ` \)" "ys \ lists (rev ` \)" "concat xs = concat ys" - hence "map rev (rev xs) \ lists \" and "map rev (rev ys) \ lists \" - using rev_in_lists[OF \xs \ lists (rev ` \)\] rev_in_lists[OF \ys \ lists (rev ` \)\] map_rev_lists_rev by blast+ + have "map rev (rev xs) \ lists \" and "map rev (rev ys) \ lists \" + using rev_in_lists[OF \xs \ lists (rev ` \)\] rev_in_lists[OF \ys \ lists (rev ` \)\] map_rev_lists_rev + by (metis imageI)+ moreover have "concat (map rev (rev xs)) = concat (map rev (rev ys))" unfolding rev_concat[symmetric] using \concat xs = concat ys\ by blast ultimately have "map rev (rev xs) = map rev (rev ys)" using is_code by blast - thus "xs = ys" by simp + thus "xs = ys" + using \concat xs = concat ys\ by simp qed -lemma dec_rev [simp]: - "u \ \\\ \ Dec rev ` \ (rev u) = rev (map rev (Dec \ u))" +lemma dec_rev [simp, reversal_rule]: + "u \ \\\ \ Dec rev ` \ (rev u) = rev (map rev (Dec \ 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 \ lists \" and "ws \ \" and "u \ \" and "concat ws \ u = u \ concat ws" - shows "set ws = {u}" + intro!: code_rev_code code.code_unique_dec imageI del: in_listsI) + +lemma elem_comm_sing_set: assumes "ws \ lists \" and "ws \ \" and "u \ \" and "concat ws \ u = u \ concat ws" + shows "set ws = {u}" using assms -proof (cases "ws = \", simp) - assume "ws \ \" +proof- have "concat (ws \ [u]) = concat ([u] \ ws)" using assms by simp - have "ws \ [u] = [u] \ ws" + have "ws \ [u] = [u] \ ws" using \u \ \\ \ws \ lists \\ is_code[OF _ _ \concat (ws \ [u]) = concat ([u] \ ws)\] by simp - from this[unfolded comm] - obtain k where "ws = [u]\<^sup>@k" by force - from nemp_pow_SucE[OF \ws \ \\ this, of \set ws = {u}\] + from comm_nemp_pows_posE[OF this \ws \ \\ not_Cons_self2[of u \]] + obtain t k m where "ws = t\<^sup>@k" "[u] = t\<^sup>@m" "0 < k" "0 < m" "primitive t". + hence "t = [u]" + by force show "set ws = {u}" - using sing_pow_set_Suc by metis + using sing_pow_set[OF \0 < k\] unfolding \ws = t\<^sup>@k\ \t = [u]\. qed -lemma pure_code_pres_prim: assumes pure: "\u \ \\\. \ u \ \\\" and +lemma pure_code_pres_prim: assumes pure: "\u \ \\\. \ u \ \\\" and "w \ \\\" and "primitive (Dec \ w)" - shows "primitive w" +shows "primitive w" proof- obtain k where "(\ w)\<^sup>@k = w" - using primroot_expE' by blast + using primroot_expE by blast have "\ w \ \\\" using assms(2) pure by auto have "(Dec \ (\ w))\<^sup>@k \ lists \" by (metis \\ w \ \\\\ concat_sing_pow dec_in_lists flatten_lists order_refl sing_pow_lists) have "(Dec \ (\ w))\<^sup>@k = Dec \ w" using \(Dec \ (\ w)) \<^sup>@ k \ lists \\ code.code_unique_dec code_axioms concat_morph_power \(\ w) \<^sup>@ k = w\ concat_dec[OF \\ w \ \\\\] by metis hence "k = 1" using \primitive (Dec \ w)\ unfolding primitive_def by blast thus "primitive w" - by (metis CoWBasic.power_one_right \\ w \<^sup>@ k = w\ assms(3) dec_emp prim_nemp primroot_prim) + by (metis pow_1 \\ w \<^sup>@ k = w\ assms(3) dec_emp prim_nemp primroot_prim) qed lemma inj_on_dec: "inj_on (decompose \) \\\" by (rule inj_onI) (use concat_dec in force) end \ \end context code\ lemma emp_is_code: "code {}" using code.intro empty_iff insert_iff lists_empty by metis lemma code_induct_hd: assumes "\ \ C" and - "\ xs ys. xs \ lists C \ ys \ lists C \ concat xs = concat ys \ hd xs = hd ys" - shows "code C" + "\ xs ys. xs \ lists C \ ys \ lists C \ concat xs = concat ys \ hd xs = hd ys" +shows "code C" proof show "xs \ lists C \ ys \ lists C \ concat xs = concat ys \ xs = ys" for xs ys - proof (induct xs ys rule: list_induct2', simp, use \\ \ C\ in force, use \\ \ C\ in force) + proof (induct xs ys rule: list_induct2') case (4 x xs y ys) from assms(2)[OF "4.prems"] - have "x = y" by force + have "x = y" by force from "4.prems"[unfolded this] - have "xs \ lists C" and "ys \ lists C" and "concat xs = concat ys" + have "xs \ lists C" and "ys \ lists C" and "concat xs = concat ys" by simp_all - from "4.hyps"[OF this] \x = y\ + from "4.hyps"[OF this] \x = y\ show ?case by simp - qed -qed - -lemma ref_set_primroot: assumes "ws \ lists G\<^sub>+" and "code (\`G)" + qed (auto simp add: \\ \ C\) +qed + +lemma ref_set_primroot: assumes "ws \ lists (G - {\})" and "code (\`G)" shows "set (Ref \`G ws) = \`(set ws)" proof- have "G \ \\`G\" proof fix x assume "x \ G" show "x \ \\ ` G\" - by (metis \x \ G\ genset_sub image_subset_iff power_in primroot_expE') + by (metis \x \ G\ genset_sub image_subset_iff power_in primroot_expE) qed hence "ws \ lists \\`G\" using assms by blast have "set (decompose (\`G) a) = {\ a}" if "a \ set ws" for a proof- have "\ a \ \`G" - using \a \ set ws\ \ws \ lists G\<^sub>+\ by blast + using \a \ set ws\ \ws \ lists (G - {\})\ by blast have "(Dec (\`G) a) \ [\ a]*" using code.code_unique_dec[OF \code (\ ` G)\ sing_pow_lists concat_sing_pow, OF \\ a \ \ ` G\] - primroot_expE' rootI by metis + primroot_expE rootI by metis from sing_pow_set'[OF this dec_nemp'] show "set (decompose (\`G) a) = {\ a}" - using \a \ set ws\ \ws \ lists \\ ` G\\ \ws \ lists G\<^sub>+\ by blast + using \a \ set ws\ \ws \ lists \\ ` G\\ \ws \ lists (G - {\})\ by blast qed have "(set`(decompose (\`G))`set ws) = {{\ a} |a. a \ set ws}" (is "?L = ?R") proof show "?L \ ?R" using \\a. a \ set ws \ set (Dec \ ` G a) = {\ a}\ by blast show "?R \ ?L" using \\a. a \ set ws \ set (Dec \ ` G a) = {\ a}\ by blast qed show ?thesis using ref_set[OF \ws \ lists \\`G\\] Setcompr_eq_image \set ` decompose (\ ` G) ` set ws = {{\ a} |a. a \ set ws}\ by (auto simp add: refine_def) qed section \Prefix code\ -locale pref_code = +locale pref_code = fixes \ - assumes - nemp: "u \ \ \ u \ \" and + assumes + emp_not_in: "\ \ \" and pref_free: "u \ \ \ v \ \ \ u \p v \ u = v" begin +lemma nemp: "u \ \ \ u \ \" + using emp_not_in by force + +lemma concat_pref_concat: + assumes "us \ lists \" "vs \ lists \" "concat us \p concat vs" + shows "us \p vs" +using assms proof (induction us vs rule: list_induct2') + case (4 x xs y ys) + from "4.prems" + have "x = y" + by (auto elim!: ruler_prefE intro: pref_free sym del: in_listsD) + with "4" show "x # xs \p y # ys" + by simp +qed (simp_all add: nemp) + +lemma concat_pref_concat_conv: + assumes "us \ lists \" "vs \ lists \" + shows "concat us \p concat vs \ us \p vs" +using concat_pref_concat[OF assms] pref_concat_pref.. + sublocale code -proof - fix xs ys - show "xs \ lists \ \ ys \ lists \ \ concat xs = concat ys \ xs = ys" - proof (induction xs ys rule: list_induct2') - case (4 x xs y ys) - hence "x \ \" and "y \ \" and "xs \ lists \" and "ys \ lists \" - by simp_all - have "x \ y" - using \concat (x # xs) = concat (y # ys)\ - by (simp add: ruler_eq) - hence "x = y" - using pref_free \x \ \\ \y \ \\ by auto - show ?case - using "4.IH"[OF \xs \ lists \\ \ys \ lists \\] \concat (x # xs) = concat (y # ys)\ - unfolding \x = y\ by force - qed (simp_all add: nemp) -qed + by standard (simp_all add: pref_antisym concat_pref_concat) lemmas is_code = is_code and - code = code_axioms + code = code_axioms lemma dec_pref_unique: - assumes "w \ \\\" and "p \ \\\" and "p \p w" - shows "Dec \ p \p Dec \ w" - using assms -proof (induction "Dec \ p" "Dec \ 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 \ \" - using \x # xs = Dec \ p\ \p \ \\\\ Cons_in_lists_iff dec_in_lists by metis - moreover have "y \ \" - using \y # ys = Dec \ w\ \w \ \\\\ Cons_in_lists_iff dec_in_lists by metis - moreover have "x \ y" - using \p \p w\ concat_dec[OF \p \ \\\\, folded \x # xs = Dec \ p\] concat_dec[OF \w \ \\\\, folded \y # ys = Dec \ w\] - concat.simps(2) pref_compI1 pref_compI2 ruler_prefE by metis - ultimately have "x = y" - using pref_free by blast - have xs: "xs = Dec \ (concat xs)" - by (metis "4.hyps"(2) "4.prems"(2) Cons_in_lists_iff code_unique_dec' dec_in_lists) - have ys: "ys = Dec \ (concat ys)" - by (metis "4.hyps"(3) "4.prems"(1) Cons_in_lists_iff code_unique_dec' dec_in_lists) - have "Dec \ (concat xs) \p Dec \ (concat ys)" - proof (rule "4.hyps"(1)[OF xs ys]) - show "concat ys \ \\\" - by (metis "4.hyps"(3) "4.prems"(1) concat_in_hull' dec_in_lists listsE) - show "concat xs \ \\\" - by (metis "4.hyps"(2) "4.prems"(2) concat_in_hull' dec_in_lists listsE) - note concat_dec[OF \w \ \\\\, folded \y # ys = Dec \ w\, unfolded hd_word[of y ys]] - concat_dec[OF \p \ \\\\, folded \x # xs = Dec \ p\, unfolded hd_word[of x xs], unfolded \x = y\] - show "concat xs \p concat ys" - using \p \p w\[folded \concat ([y] \ ys) = w\ \concat ([y] \ xs) = p\, unfolded concat_morph pref_cancel_conv]. - qed - from this xs ys - show "Dec \ p \p Dec \ w" - unfolding \x # xs = Dec \ p\[symmetric] \y # ys = Dec \ w\[symmetric] \x = y\ by force - qed -qed force + "w \ \\\ \ p \ \\\ \ p \p w \ Dec \ p \p Dec \ w" + using concat_pref_concat_conv[of "Dec \ p" "Dec \ w", THEN iffD1] + by simp + +end + +subsection \Suffix code\ + +locale suf_code = pref_code "(rev ` \)" for \ +begin + +thm dec_rev + code + +sublocale code + using code_rev_code unfolding rev_rev_image_eq. + +lemmas concat_suf_concat = concat_pref_concat[reversed] and + concat_suf_concat_conv = concat_pref_concat_conv[reversed] and + nemp = nemp[reversed] and + suf_free = pref_free[reversed] and + dec_suf_unique = dec_pref_unique[reversed] + +thm is_code + code_axioms + code end section \Marked code\ -locale marked_code = +locale marked_code = fixes \ assumes - nemp: "u \ \ \ u \ \" and - marked: "u \ \ \ v \ \ \ hd u = hd v \ u = v" - -begin + emp_not_in: "\ \ \" and + marked: "u \ \ \ v \ \ \ hd u = hd v \ u = v" + +begin + +lemma nemp: "u \ \ \ u \ \" + using emp_not_in by blast sublocale pref_code -proof (unfold_locales, simp add: nemp) - show "\u v. u \ \ \ v \ \ \ u \p v \ u = v" - by (simp add: marked nemp pref_hd_eq) -qed + by (unfold_locales) (simp_all add: emp_not_in marked nemp pref_hd_eq) + lemma marked_concat_lcp: "us \ lists \ \ vs \ lists \ \ concat (us \\<^sub>p vs) = (concat us) \\<^sub>p (concat vs)" proof (induct us vs rule: list_induct2') case (4 x xs y ys) hence "x \ \" and "y \ \" and "xs \ lists \" and "ys \ lists \" by simp_all show ?case - proof (cases) - assume "x = y" + proof (cases) + assume "x = y" thus "concat (x # xs \\<^sub>p y # ys) = concat (x # xs) \\<^sub>p concat (y # ys)" - using "4.hyps"[OF \xs \ lists \\ \ys \ lists \\] by (simp add: lcp_ext_left) + using "4.hyps"[OF \xs \ lists \\ \ys \ lists \\] by (simp add: lcp_ext_left) next assume "x \ y" with marked[OF \x \ \\ \y \ \\] have "hd x \ hd y" by blast hence "concat (x # xs) \\<^sub>p concat (y # ys) = \" - by (simp add: \x \ \\ \y \ \\ nemp lcp_distinct_hd) + by (simp add: \x \ \\ \y \ \\ nemp lcp_distinct_hd) moreover have "concat (x # xs \\<^sub>p y # ys) = \" using \x \ y\ by simp ultimately show ?thesis by presburger qed qed simp_all -lemma hd_concat_hd: assumes "xs \ lists \" and "ys \ lists \" and "xs \ \" and "ys \ \" and - "hd (concat xs) = hd (concat ys)" - shows "hd xs = hd ys" +lemma hd_concat_hd: assumes "xs \ lists \" and "ys \ lists \" and "xs \ \" and "ys \ \" 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 \xs \ \\ lists_hd_in_set[THEN nemp]] hd_concat[OF \ys \ \\ 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" + + 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 = +section "Non-overlapping code" + +locale non_overlapping = fixes \ assumes - card_set: "c \ \ \ card (set c) = 1" and - set_neq: "c \ \ \ d \ \ \ c \ d \ set c \ set d" + emp_not_in: "\ \ \" and + no_overlap: "u \ \ \ v \ \ \ z \p u \ z \s v \ z \ \ \ u = v" and + no_fac: "u \ \ \ v \ \ \ u \f v \ u = v" begin -lemma nemp: assumes "u \ \ " shows "u \ \" - using card_set[OF \u \ \\] by (intro notI) simp - -lemma set_is_sing_hd: assumes "u \ \" shows "set u = {hd u}" - using hd_in_set[OF nemp[OF \u \ \\]] card_set[OF \u \ \\] - by (elim card_1_singletonE) simp - -sublocale marked_code +lemma nemp: "u \ \ \ u \ \" + using emp_not_in by force + +sublocale pref_code + using nemp non_overlapping.no_fac non_overlapping_axioms pref_code.intro by fastforce + +lemma rev_non_overlapping: "non_overlapping (rev ` \)" proof - show "\u. u \ \ \ u \ \" - using card_set by fastforce - show "\u v. u \ \ \ v \ \ \ hd u = hd v \ u = v" - using set_is_sing_hd set_neq by auto + show "\ \ rev ` \" + using nemp by force + show "u \ rev ` \ \ v \ rev ` \ \ z \p u \ z \s v \ z \ \ \ u = v" for u v z + using no_overlap[reversed] unfolding rev_in_conv.. + show "u \ rev ` \ \ v \ rev ` \ \ u \f v \ u = v" for u v + using no_fac[reversed] unfolding rev_in_conv by presburger qed -lemma sing_pow: - assumes "u \ \" - shows "[hd u]\<^sup>@\<^bold>|u\<^bold>| = u" - using unique_letter_word[of u "hd u", symmetric] unfolding set_is_sing_hd[OF \u \ \\] by blast - -lemma palindrome: assumes "u \ \" shows "rev u = u" - using sing_pow_palindrom[OF sing_pow[OF \u \ \\, symmetric]]. - -lemma rev_in_conv [reversal_rule]: "rev u \ \ \ u \ \" - using palindrome by fastforce - -lemma map_rev_in_lists_conv [reversal_rule]: "map rev us \ lists \ \ us \ lists \" - using palindrome by fastforce - -thm marked -lemmas marked_last = marked[reversed] - -lemma common_letter_imp_same: - assumes "u \ \" "v \ \" - and "i < \<^bold>|u\<^bold>|" "j < \<^bold>|v\<^bold>|" - shows "u ! i = v ! j \ u = v" - using nth_mem[OF \i < \<^bold>|u\<^bold>|\] nth_mem[OF \j < \<^bold>|v\<^bold>|\] - unfolding set_is_sing_hd[OF \u \ \\] set_is_sing_hd[OF \v \ \\] - by (intro marked[OF \u \ \\ \v \ \\]) simp - -lemma pref_overlap_imp_same: - assumes "u \ \" "v \ \" - and "p \ u \p q \ 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>| \ \<^bold>|p\<^bold>| + \<^bold>|u\<^bold>| - 1" - unfolding diff_add_assoc[OF nemp_le_len[OF nemp[OF \u \ \\]]] using le_add1. - have **: "\<^bold>|q\<^bold>| \ \<^bold>|p\<^bold>| + \<^bold>|u\<^bold>| - 1" - using \\<^bold>|q\<^bold>| < \<^bold>|p\<^bold>| + \<^bold>|u\<^bold>|\ unfolding discrete by (intro add_le_imp_le_diff) - have "\<^bold>|p\<^bold>| + \<^bold>|u\<^bold>| - 1 < \<^bold>|p \ u\<^bold>|" - unfolding One_nat_def lenmorph using nemp[OF \u \ \\] by (intro diff_Suc_less) blast - from pref_index[OF \p \ u \p q \ v\ this] less_le_trans[OF this pref_len[OF \p \ u \p q \ v\]] - 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 \u \ \\]) - -lemma overlap_imp_same: - assumes "u \ \" "v \ \" - and "p \ u \ q \ 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 \ lists \" "vs \ lists \" - shows "concat us \p concat vs \ us \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: +sublocale suf: suf_code \ +proof- + interpret i: non_overlapping "rev ` \" + using rev_non_overlapping. + from i.pref_code_axioms + show "suf_code \" + by unfold_locales +qed + +lemma overlap_concat_last: assumes "u \ \" and "vs \ lists \" and "vs \ \" and + "r \ \" and "r \p u" and "r \s p \ concat vs" + shows "u = last vs" +proof- + from suffix_same_cases[OF suf_ext[OF concat_last_suf[OF \vs \ \\]] \r \s p \ concat vs\] + show "u = last vs" + proof (rule disjE) + assume "r \s last vs" + from no_overlap[OF \u \ \\ _ \r \p u\ this \r \ \\] + show "u = last vs" + using \vs \ lists \\ \vs \ \\ by force + next + assume "last vs \s r" + from no_fac[OF _ \u \ \\ pref_suf_fac, OF _ \r \p u\ this] + show "u = last vs" + using \vs \ lists \\ \vs \ \\ by force + qed +qed + +lemma overlap_concat_hd: assumes "u \ \" and "vs \ lists \" and "vs \ \" and "r \ \" and "r \s u" and "r \p concat vs \ s" + shows "u = hd vs" +proof- + interpret c: non_overlapping "rev ` \" by (simp add: rev_non_overlapping) + from c.overlap_concat_last[reversed, OF assms] + show ?thesis. +qed + +lemma fac_concat_fac: assumes "us \ lists \" "vs \ lists \" - and "z

\" - and "z \ concat us \p concat vs" - shows "set us \ {hd vs}" -using assms(1-3, 5) proof (induction us vs rule: list_induct2') - case (4 u us v vs) - note pref = \z \ concat (u # us) \p concat (v # vs)\ - \ \stating simple consequences of the hypotheses\ - have "u \ \" "v \ \" "us \ lists \" "vs \ lists \" - using \u # us \ lists \\ \v # vs \ lists \\ by simp_all - \ \first step is to show the equality of u and v\ - have "z \ u \ \ \ v" - using pref by (intro ruler'[OF append_prefixD triv_pref]) simp - moreover have "\<^bold>|z\<^bold>| < \<^bold>|\\<^bold>| + \<^bold>|v\<^bold>|" and "\<^bold>|\\<^bold>| < \<^bold>|z\<^bold>| + \<^bold>|u\<^bold>|" - using \z

\z \ \\ by (simp_all add: prefix_length_less) - ultimately have "u = v" - by (rule overlap_imp_same[OF \u \ \\ \v \ \\]) - \ \empty vs leads to contradiction, so we can express vs as @{term "v' # vs'"}\ - have False if "vs = \" - using \z \ \\ pref unfolding \vs = \\ \u = v\ - 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' \ \" "vs' \ lists \" - using \vs \ lists \\ unfolding \vs = v' # vs'\ by simp_all - \ \now we show the equality of v' and v similarly as above\ - have "z \ v \ v \ v'" - using pref unfolding \u = v\ \vs = v' # vs'\ - 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 \z

\z \ \\ by (simp_all add: prefix_length_less trans_less_add1) - ultimately have "v' = v" - by (elim overlap_imp_same[OF \v \ \\ \v' \ \\, symmetric]) - \ \ since @{term "z \ v"} is prefix of @{term "v \ v"}, the words z and v commute\ - have "z \ v \p v \ v" - using comp_shorter[OF \z \ v \ v \ v'\] \\<^bold>|z\<^bold>| < \<^bold>|\\<^bold>| + \<^bold>|v\<^bold>|\ unfolding \v' = v\ lenmorph - by fastforce - with this[folded same_prefix_prefix[of v "z \ v" "v \ v"]] - have "z \ v = v \ z" - using pref_prod_pref pref_prolong pref_comm_eq' triv_pref by metis - \ \finally we check premises of the induction hypothesis and conclude the proof\ - note \us \ lists \\ \vs \ lists \\ - moreover have "z

z

unfolding \vs = v' # vs'\ \v' = v\ list.sel(1). - moreover have "z \ concat us \p concat vs" - using pref \z \ v = v \ z\ unfolding \u = v\ - by (intro pref_cancel[of _ "z \ _"]) (simp flip: rassoc) - ultimately have "set us \ {hd vs}" by (fact "4.IH") - then show "set (u # us) \ {hd (v # vs)}" - unfolding \vs = v' # vs'\ \v' = v\ \u = v\ by simp -qed (simp_all add: \z \ \\) - -lemma unique_interpretation: - assumes "us \ lists \" "vs \ lists \" - and "1 < card (set us)" - and "z \ concat us \p concat vs" - obtains ws where "ws \p vs" and "concat ws = z" and "ws \ us \p vs" -using assms proof (induction "\<^bold>|z\<^bold>|" arbitrary: z us vs thesis rule: less_induct) - case less - \ \ stating simple facts \ - have "us \ \" using \1 < card (set us)\ by fastforce - then have "hd us \ \" using \us \ lists \\ by (intro nemp lists_hd_in_set) - then have "vs \ \" using \z \ concat us \p concat vs\ - unfolding hd_concat_tl[OF \us \ \\, symmetric] by (intro notI) simp - then have "hd vs \ \" using \vs \ lists \\ by (intro nemp lists_hd_in_set) - have "z \ hd vs" - using \z \ concat us \p concat vs\ concat_hd_pref[OF \vs \ \\] - by (intro ruler'[OF pref_trans[OF triv_pref]]) - \ \ splitting into three cases\ - then consider "z = \" | "z

\" | "hd vs \p z" - by (blast dest: pref_comp_not_spref) - then show thesis - proof (cases) - assume "z = \" - \ \ first case follows from the fact @{thm "concat_pref_concat_conv"}\ - have "\ \p vs" "concat \ = z" "\ \ us \p vs" - using emp_pref concat.simps(1) \z \ concat us \p concat vs\ - unfolding \z = \\ append_Nil concat_pref_concat_conv[OF \us \ lists \\ \vs \ lists \\]. - then show thesis by fact - next - assume "z

\" - \ \second case leads to contradiction\ - with \us \ lists \\ \vs \ lists \\ have "set us \ {hd vs}" - using \z \ concat us \p concat vs\ by (rule two_interpretations) - then show R for R using \1 < card (set us)\ - by (simp add: \us \ \\ subset_singleton_iff) - next - assume "hd vs \p z" - \ \the last case follows using induction hypotheses for z'\ - then obtain z' where "z = hd vs \ z'".. - note \us \ lists \\ tl_in_lists[OF \vs \ lists \\] \1 < card (set us)\ - moreover have "z' \ concat us \p concat (tl vs)" - using \z \ concat us \p concat vs\ - unfolding \z = hd vs \ z'\ hd_concat_tl[OF \vs \ \\, symmetric] by simp - moreover have "\<^bold>|z'\<^bold>| < \<^bold>|z\<^bold>|" using \z = hd vs \ z'\ \hd vs \ \\ by simp - ultimately obtain ws' - where "hd vs # ws' \p hd vs # tl vs" - and "concat (hd vs # ws') = hd vs \ z'" - and "hd vs # (ws' \ us) \p hd vs # tl vs" - unfolding pref_cancel_hd_conv concat.simps(2) cancel - by (rule less.hyps[rotated 2]) - then show thesis - unfolding \z = hd vs \ z'\[symmetric] hd_Cons_tl[OF \vs \ \\] append_Cons[symmetric] - by fact - qed + and "1 < card (set us)" + and "concat vs = p \ concat us \ s" + obtains ps ss where "concat ps = p" and "concat ss = s" and "ps \ us \ ss = vs" +proof- + define us1 where "us1 = takeWhile (\ a. a = hd us) us" + define us2 where "us2 = dropWhile (\ a. a = hd us) us" + from card_set_decompose[OF \1 < card (set us)\] + have "us = us1 \ us2" "us1 \ \" "us2 \ \" "set us1 = {hd us}" "last us1 \ hd us2" + unfolding us1_def us2_def by simp_all + have "us2 \ lists \" "us1 \ lists \" + using \us = us1 \ us2\ \us \ lists \\ by simp_all + hence "concat us2 \ \" + using \us2 \ \\ nemp by force + hence "p \ concat us1

us = us1 \ us2\ unfolding \concat vs = p \ concat us \ s\ by simp + from pref_mod_list[OF this] + obtain j r where "j < \<^bold>|vs\<^bold>|" "r

r = p \ concat us1". + have "r = \" + proof (rule ccontr) + assume "r \ \" + from spref_exE[OF \r

] + obtain z where "r \ z = vs ! j" "z \ \". + from overlap_concat_last[OF _ \us1 \ lists \\ \us1 \ \\ \r \ \\ sprefD1[OF \r

] sufI[OF \concat (take j vs) \ r = p \ concat us1\]] + have "vs ! j = last us1" + using nth_in_lists[OF \j < \<^bold>|vs\<^bold>|\ \vs \ lists \\]. + + have concat_vs: "concat vs = concat (take j vs) \ vs!j \ concat (drop (Suc j) vs)" + unfolding lassoc concat_take_Suc[OF \j < \<^bold>|vs\<^bold>|\] concat_morph[symmetric] by force + from this[folded \r \ z = vs ! j\] + have "z \ concat (drop (Suc j) vs) = concat us2 \ s" + unfolding \concat vs = p \ concat us \ s\ lassoc \concat (take j vs) \ r = p \ concat us1\ \us = us1 \ us2\ concat_morph + unfolding rassoc cancel by simp + from overlap_concat_hd[OF _ \us2 \ lists \\ \us2 \ \\ \z \ \\ sufI[OF \r \ z = vs ! j\] prefI[OF this]] + have "vs ! j = hd us2" + using nth_in_lists[OF \j < \<^bold>|vs\<^bold>|\ \vs \ lists \\]. + + thus False + unfolding \vs ! j = last us1\ using \last us1 \ hd us2\ by contradiction + qed + + have "drop j vs \ lists \" and "take j vs \ lists \" + using \vs \ lists \\ by inlists + have "concat us2 \ s = concat (drop j vs)" + using arg_cong[OF takedrop[of j vs], of concat] \concat (take j vs) \ r = p \ concat us1\ + unfolding \concat vs = p \ concat us \ s\ concat_morph \r = \\ emp_simps \us = us1 \ us2\ by auto + from prefI[OF this] + have "us2 \p drop j vs" + using concat_pref_concat_conv[OF \us2 \ lists \\ \drop j vs \ lists \\] by blast + hence s: "concat (us2\\<^sup>>drop j vs) = s" + using \concat us2 \ s = concat (drop j vs)\ concat_morph_lq lqI by blast + + from \concat (take j vs) \ r = p \ concat us1\[unfolded \r = \\ emp_simps] + have "concat us1 \s concat (take j vs)" + by fastforce + hence "us1 \s take j vs" + using suf.concat_pref_concat_conv[reversed, OF \us1 \ lists \\ \take j vs \ lists \\] by blast + from arg_cong[OF rq_suf[OF this], of concat, unfolded concat_morph] + have p: "concat (take j vs\<^sup><\us1 ) = p" + using rqI[OF \concat (take j vs) = p \ concat us1\[symmetric]] + rq_triv by metis + + have "take j vs\<^sup><\us1 \ us \ us2\\<^sup>>drop j vs = vs" + unfolding \us = us1 \ us2\ rassoc lq_pref[OF \us2 \p drop j vs\] + unfolding lassoc rq_suf[OF \us1 \s take j vs\] by simp + + from that[OF p s this] + show thesis. qed -theorem sings_prim_morph: +theorem prim_morph: assumes "ws \ lists \" - and "\<^bold>|ws\<^bold>| \ 1" - and "primitive ws" + and "\<^bold>|ws\<^bold>| \ 1" + and "primitive ws" shows "primitive (concat ws)" proof (rule ccontr) have "ws \ lists \" and "ws \ ws \ lists \" using \ws \ lists \\ by simp_all - moreover have "1 < card (set ws)" using \primitive ws\ \\<^bold>|ws\<^bold>| \ 1\ by (rule prim_card_set) + moreover have "1 < card (set ws)" using \primitive ws\ \\<^bold>|ws\<^bold>| \ 1\ + by (rule prim_card_set) moreover assume "\ primitive (concat ws)" - then obtain k z where "2 \ k" and "z \<^sup>@ k = concat ws" by (elim not_prim_pow) - have "z \ concat ws \p concat (ws \ ws)" - using \2 \ k\ unfolding \z \<^sup>@ k = concat ws\[symmetric] concat_append - by (simp add: le_exps_pref flip: power_Suc power_add) - ultimately obtain vs where "vs \p ws \ ws" and "concat vs = z" and "vs \ ws \p ws \ ws" - by (rule unique_interpretation) - have "vs \<^sup>@ k \ lists \" - using \vs \p ws \ ws\ \ws \ ws \ lists \\ by (intro pow_in_lists) (rule pref_in_lists) - moreover have "concat (vs \<^sup>@ k) = concat ws" - unfolding concat_pow \concat vs = z\ \z \<^sup>@ k = concat ws\.. - ultimately have "vs \<^sup>@ k = ws" using \ws \ lists \\ by (intro is_code) + then obtain k z where "2 \ k" and "z \<^sup>@ k = concat ws" by (elim not_prim_primroot_expE) + have "concat (ws \ ws) = z \ concat ws \ z\<^sup>@(k-1)" + unfolding concat_morph \z \<^sup>@ k = concat ws\[symmetric] add_exps[symmetric] pow_Suc[symmetric] + using \2 \ k\ by simp + ultimately obtain ps ss where "concat ps = z" and "concat ss = z\<^sup>@(k-1)" and "ps \ ws \ ss = ws \ ws" + by (rule fac_concat_fac) + have "ps \<^sup>@ k \ lists \" + using \ps \ ws \ ss = ws \ ws\ \ws \ ws \ lists \\ by inlists + moreover have "concat (ps \<^sup>@ k) = concat ws" + unfolding concat_pow \concat ps = z\ \z \<^sup>@ k = concat ws\.. + ultimately have "ps \<^sup>@ k = ws" using \ws \ lists \\ by (intro is_code) show False - using prim_exp_one[OF \primitive ws\ \vs \<^sup>@ k = ws\] \2 \ k\ by presburger + using prim_exp_one[OF \primitive ws\ \ps \<^sup>@ k = ws\] \2 \ k\ by presburger qed -lemma sings_prim_concat_conv: +lemma prim_concat_conv: assumes "ws \ lists \" - and "\<^bold>|ws\<^bold>| \ 1" + and "\<^bold>|ws\<^bold>| \ 1" shows "primitive (concat ws) \ primitive ws" - using prim_concat_prim sings_prim_morph[OF assms].. + using prim_concat_prim prim_morph[OF assms].. end -\ \Exporting out of context\ -lemmas sings_prim_morph = sings_code.sings_prim_morph[OF sings_code.intro] - -lemma (in code) code_roots_sings_code: "sings_code ((\ x. [\ x]\<^sup>@(e\<^sub>\ x)) ` \)" +lemma (in code) code_roots_non_overlapping: "non_overlapping ((\ x. [\ x]\<^sup>@(e\<^sub>\ x)) ` \)" proof - fix c assume "c \ (\x. [\ x] \<^sup>@ e\<^sub>\ x) ` \" - then obtain u where "u \ \" and "c = [\ u] \<^sup>@ e\<^sub>\ u" by blast - have "u \ \" using \u \ \\ emp_not_in by auto - from sing_pow_set[OF primroot_exp_nemp[OF \u \ \\], of "\ u", folded \c = [\ u] \<^sup>@ e\<^sub>\ u\] - show "card (set c) = 1" - by simp - - fix d assume "d \ (\x. [\ x] \<^sup>@ e\<^sub>\ x) ` \" and "c \ d" - then obtain v where "v \ \" and "d = [\ v] \<^sup>@ e\<^sub>\ v" by blast - have "v \ \" using \v \ \\ emp_not_in by auto - have "u \ v" - using \c = [\ u] \<^sup>@ e\<^sub>\ u\ \c \ d\ \d = [\ v] \<^sup>@ e\<^sub>\ v\ by blast - hence "\ u \ \ v" - using code_not_comm[OF \u \ \\ \v \ \\] - unfolding comm_primroots[OF \u \ \\ \v \ \\] by blast - with \set c = {\ u}\ - sing_pow_set[OF primroot_exp_nemp[OF \v \ \\], of "\ v", folded \d = [\ v] \<^sup>@ e\<^sub>\ v\] - show "set c \ set d" - by simp + show "\ \ (\x. [\ x] \<^sup>@ e\<^sub>\ x) ` \" + proof + assume "\ \ (\x. [\ x] \<^sup>@ e\<^sub>\ x) ` \ " + from this[unfolded image_iff] + obtain u where "u \ \" and "\ = [\ u] \<^sup>@ e\<^sub>\ u" + by blast + from arg_cong[OF this(2), of concat] + show False + unfolding concat.simps(1) concat_sing_pow primroot_exp_eq + using emp_not_in \u \ \\ by blast + qed + fix us vs + assume us': "us \ (\x. [\ x] \<^sup>@ e\<^sub>\ x) ` \" and vs': "vs \ (\x. [\ x] \<^sup>@ e\<^sub>\ x) ` \" + from us'[unfolded image_iff] + obtain u where "u \ \" and us: "us = [\ u] \<^sup>@ e\<^sub>\ u" + by blast + from vs'[unfolded image_iff] + obtain v where "v \ \" and vs: "vs = [\ v] \<^sup>@ e\<^sub>\ v" + by blast + note sing_set = sing_pow_set[OF primroot_exp_nemp[OF nemp]] + show "us = vs" if "zs \p us" and "zs \s vs" and "zs \ \" for zs + proof- + from set_mono_prefix[OF \zs \p us\] \zs \ \\[folded set_empty2] + have "set zs = {\ u}" + using subset_singletonD unfolding \us = [\ u] \<^sup>@ e\<^sub>\ u\ sing_set[OF \u \ \\] + by metis + from set_mono_suffix[OF \zs \s vs\] \zs \ \\[folded set_empty2] + have "set zs = {\ v}" + using subset_singletonD unfolding \vs = [\ v] \<^sup>@ e\<^sub>\ v\ sing_set[OF \v \ \\] + by metis + hence "\ u = \ v" + unfolding \set zs = {\ u}\ by simp + from same_primroots_comm[OF this] + have "u = v" + using code_not_comm [OF \u \ \\ \v \ \\] by blast + thus "us = vs" + unfolding \us = [\ u] \<^sup>@ e\<^sub>\ u\ \vs = [\ v] \<^sup>@ e\<^sub>\ v\ by blast + qed + show "us = vs" if "us \f vs" + proof- + from sing_set[OF \u \ \\, of "\ u"] sing_set[OF \v \ \\, of "\ v"] + have "\ u = \ v" + unfolding us[symmetric] vs[symmetric] using set_mono_sublist[OF \us \f vs\] + by force + from same_primroots_comm[OF this] + have "u = v" + using code_not_comm [OF \u \ \\ \v \ \\] by blast + thus "us = vs" + unfolding \us = [\ u] \<^sup>@ e\<^sub>\ u\ \vs = [\ v] \<^sup>@ e\<^sub>\ v\ by blast + qed qed -theorem (in code) roots_prim_morph: +theorem (in code) roots_prim_morph: assumes "ws \ lists \" - and "\<^bold>|ws\<^bold>| \ 1" - and "primitive ws" - shows "primitive (concat (map (\ x. [\ x]\<^sup>@(e\<^sub>\ x)) ws))" - (is "primitive (concat (map ?R ws))") + and "\<^bold>|ws\<^bold>| \ 1" + and "primitive ws" + shows "primitive (concat (map (\ x. [\ x]\<^sup>@(e\<^sub>\ x)) ws))" + (is "primitive (concat (map ?R ws))") proof- - interpret rc: sings_code "?R ` \" - using code_roots_sings_code. - - show ?thesis - proof (rule rc.sings_prim_morph) + interpret rc: non_overlapping "?R ` \" + using code_roots_non_overlapping. + + show ?thesis + proof (rule rc.prim_morph) show "primitive (map ?R ws)" - using inj_map_prim[OF root_dec_inj_on - \ws \ lists \\ \primitive ws\]. + using inj_map_prim[OF root_dec_inj_on + \ws \ lists \\ \primitive ws\]. show "map ?R ws \ lists (?R ` \)" using \ws \ lists \\ lists_image[of ?R \] by force - show "\<^bold>|map (\x. [\ x] \<^sup>@ e\<^sub>\ x) ws\<^bold>| \ 1" - using \\<^bold>|ws\<^bold>| \ 1\ by simp + show "\<^bold>|map (\x. [\ x] \<^sup>@ e\<^sub>\ x) ws\<^bold>| \ 1" + using \\<^bold>|ws\<^bold>| \ 1\ by simp qed qed section \Binary code\ -text\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\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. \ -definition bin_lcp where "bin_lcp x y = x\y \\<^sub>p y\x" -definition bin_lcs where "bin_lcs x y = x\y \\<^sub>s y\x" +definition bin_lcp where "bin_lcp x y = x\y \\<^sub>p y\x" +definition bin_lcs where "bin_lcs x y = x\y \\<^sub>s y\x" definition bin_mismatch where "bin_mismatch x y = (x\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\y)!(\<^bold>|x \ 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) \ (x \ y = y \ x)" unfolding bin_mismatch_def bin_lcp_def lcp_sym[of "y \ x"] using lcp_mismatch'[of "x \ y" "y \ x", unfolded comm_comp_eq_conv[of x y]] by fastforce lemma bin_lcp_pref_fst_snd: "bin_lcp x y \p x \ y" unfolding bin_lcp_def using lcp_pref. lemma bin_lcp_pref_snd_fst: "bin_lcp x y \p y \ 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 \ y"].. + lcs_sym[of "x \ y"].. lemmas bin_lcs_sym = bin_lcp_sym[reversed] -lemma bin_lcp_len: "x \ y \ y \ x \ \<^bold>|bin_lcp x y\<^bold>| < \<^bold>|x \ y\<^bold>|" +lemma bin_lcp_len: "x \ y \ y \ x \ \<^bold>|bin_lcp x y\<^bold>| < \<^bold>|x \ y\<^bold>|" unfolding bin_lcp_def - using lcp_len' pref_comm_eq by blast + 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" +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 = +subsection \Binary code locale\ + +locale binary_code = fixes u\<^sub>0 u\<^sub>1 - assumes non_comm: "u\<^sub>0 \ u\<^sub>1 \ u\<^sub>1 \ u\<^sub>0" + assumes non_comm: "u\<^sub>0 \ u\<^sub>1 \ u\<^sub>1 \ u\<^sub>0" begin text\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. \ +definition uu where "uu a = (if a then u\<^sub>0 else u\<^sub>1)" + +lemma bin_code_set_bool: "{uu a,uu (\ a)} = {u\<^sub>0,u\<^sub>1}" + by (induct a, unfold uu_def, simp_all add: insert_commute) + +lemma bin_code_set_bool': "{uu a,uu (\ a)} = {u\<^sub>1,u\<^sub>0}" + by (induct a, unfold uu_def, simp_all add: insert_commute) + lemma bin_code_swap: "binary_code u\<^sub>1 u\<^sub>0" using binary_code.intro[OF non_comm[symmetric]]. +lemma bin_code_bool: "binary_code (uu a) (uu (\ a))" + unfolding uu_def by (induct a, simp_all add: bin_code_swap binary_code_axioms) + lemma bin_code_neq: "u\<^sub>0 \ u\<^sub>1" using non_comm by auto -lemma bin_fst_nemp: "u\<^sub>0 \ \" and bin_snd_nemp: "u\<^sub>1 \ \" - using non_comm by auto +lemma bin_code_neq_bool: "uu a \ uu (\ a)" + unfolding uu_def by (induct a) (use bin_code_neq in fastforce)+ + +lemma bin_fst_nemp: "u\<^sub>0 \ \" and bin_snd_nemp: "u\<^sub>1 \ \" and bin_nemp_bool: "uu a \ \" + using non_comm uu_def by auto lemma bin_not_comp: "\ u\<^sub>0 \ u\<^sub>1 \ u\<^sub>1 \ u\<^sub>0" - using comm_comp_eq_conv non_comm by blast - -lemma bin_not_comp_suf: "\ u\<^sub>0 \ u\<^sub>1 \\<^sub>s u\<^sub>1 \ u\<^sub>0" - using comm_comp_eq_conv_suf non_comm[reversed] by blast + using comm_comp_eq_conv non_comm by blast + +lemma bin_not_comp_bool: "\ (uu a \ uu (\ a) \ uu (\ a) \ uu a)" + unfolding uu_def by (induct a, use bin_not_comp pref_comp_sym in auto) + +lemma bin_not_comp_suf: "\ u\<^sub>0 \ u\<^sub>1 \\<^sub>s u\<^sub>1 \ u\<^sub>0" + using comm_comp_eq_conv_suf non_comm[reversed] by blast + +lemma bin_not_comp_suf_bool: "\ (uu a \ uu (\ a) \\<^sub>s uu (\ a) \ uu a)" + unfolding uu_def by (induct a, use bin_not_comp_suf suf_comp_sym in auto) lemma bin_mismatch_neq: "bin_mismatch u\<^sub>0 u\<^sub>1 \ bin_mismatch u\<^sub>1 u\<^sub>0" using non_comm[folded bin_mismatch_comm]. abbreviation bin_code_lcp ("\") where "bin_code_lcp \ bin_lcp u\<^sub>0 u\<^sub>1" abbreviation bin_code_lcs where "bin_code_lcs \ bin_lcs u\<^sub>0 u\<^sub>1" abbreviation bin_code_mismatch_fst ("c\<^sub>0") where "bin_code_mismatch_fst \ bin_mismatch u\<^sub>0 u\<^sub>1" abbreviation bin_code_mismatch_snd ("c\<^sub>1") where "bin_code_mismatch_snd \ bin_mismatch u\<^sub>1 u\<^sub>0" -(* abbreviation "bin_code_lcp' \ bin_lcp u\<^sub>1 u\<^sub>0" *) -(* abbreviation "bin_code_lcs' \ bin_lcs u\<^sub>1 u\<^sub>0" *) -(* abbreviation "bin_code_mismatch_suf_fst \ bin_mismatch_suf u\<^sub>0 u\<^sub>1" *) -(* abbreviation "bin_code_mismatch_suf_snd \ 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>|\\<^bold>| < \<^bold>|u\<^sub>0\<^bold>| + \<^bold>|u\<^sub>1\<^bold>|" + +definition cc where "cc a = (if a then c\<^sub>0 else c\<^sub>1)" + + +lemmas bin_lcp_swap = bin_lcp_sym[of u\<^sub>0 u\<^sub>1, symmetric] and + bin_lcp_pref = bin_lcp_pref_fst_snd[of u\<^sub>0 u\<^sub>1] and + bin_lcp_pref' = bin_lcp_pref_snd_fst[of u\<^sub>0 u\<^sub>1] and + bin_lcp_short = bin_lcp_len[OF non_comm, unfolded lenmorph] + +lemmas bin_code_simps = cc_def uu_def if_True if_False bool_simps + +lemma bin_lcp_bool: "bin_lcp (uu a) (uu (\ a)) = bin_code_lcp" + unfolding uu_def by (induct a, simp_all add: bin_lcp_swap) + +lemma bin_lcp_spref: "\

0 \ u\<^sub>1" + using bin_lcp_pref bin_lcp_pref' bin_not_comp by fastforce + +lemma bin_lcp_spref': "\

1 \ u\<^sub>0" + using bin_lcp_pref bin_lcp_pref' bin_not_comp by fastforce + +lemma bin_lcp_spref_bool: "\

uu (\ a)" + unfolding uu_def by (induct a, use bin_lcp_spref bin_lcp_spref' in auto) + +lemma bin_mismatch_bool': "\ \ [cc a] \p uu a \ uu (\ a)" + using add_nth_pref[OF bin_lcp_spref_bool, of a] + unfolding uu_def cc_def bin_mismatch_def bin_lcp_bool bin_lcp_swap + by (induct a) simp_all + +lemma bin_mismatch_bool: "\ \ [cc a] \p uu a \ \" proof- - have "\ u\<^sub>0\u\<^sub>1 \p u\<^sub>1\u\<^sub>0" - using comm_ruler non_comm by blast - from lcp_len'[OF this, folded bin_lcp_def, unfolded lenmorph] - show "\<^bold>|\\<^bold>| < \<^bold>|u\<^sub>0\<^bold>| + \<^bold>|u\<^sub>1\<^bold>|". + from bin_mismatch_bool' + have "\ \ [cc a] \p uu a \ (uu (\ a) \ uu a)" + using pref_prolong by blast + from pref_prod_pref_short[OF this bin_lcp_pref_snd_fst, unfolded bin_lcp_bool lenmorph sing_len] + show ?thesis + using nemp_len[OF bin_nemp_bool, of a] by linarith qed -lemma bin_fst_mismatch': "\ \ [c\<^sub>0] \p u\<^sub>0 \ u\<^sub>1" - by (simp add: append_one_prefix bin_lcp_pref_fst_snd bin_lcp_short bin_mismatch_def) - -lemma bin_fst_mismatch: "\ \ [c\<^sub>0] \p u\<^sub>0 \ \" -proof- - from bin_fst_mismatch' - have "\ \ [c\<^sub>0] \p u\<^sub>0 \ (u\<^sub>1 \ u\<^sub>0)" - using pref_prolong by blast - from pref_prod_pref_short[OF this bin_lcp_pref_snd_fst, unfolded lenmorph sing_len] - show "\ \ [c\<^sub>0] \p u\<^sub>0 \ \" - using nemp_len[OF bin_fst_nemp] by linarith -qed - -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] +lemmas bin_fst_mismatch = bin_mismatch_bool[of True, unfolded bin_code_simps] and + bin_fst_mismatch' = bin_mismatch_bool'[of True, unfolded bin_code_simps] and + bin_snd_mismatch = bin_mismatch_bool[of False, unfolded bin_code_simps] and + bin_snd_mismatch' = bin_mismatch_bool'[of False, unfolded bin_code_simps] lemma bin_lcp_pref_all: "xs \ lists {u\<^sub>0,u\<^sub>1} \ \ \p concat xs \ \" -proof (induct xs, simp) +proof (induct xs) case (Cons a xs) have "a \ {u\<^sub>0,u\<^sub>1}" and "xs \ lists {u\<^sub>0, u\<^sub>1}" - using \a # xs \ lists {u\<^sub>0, u\<^sub>1}\ by simp_all + using \a # xs \ lists {u\<^sub>0, u\<^sub>1}\ by simp_all show ?case proof (rule two_elemP[OF \a \ {u\<^sub>0,u\<^sub>1}\], simp_all) show "\ \p u\<^sub>0 \ concat xs \ \" - using pref_extD[OF bin_fst_mismatch] Cons.hyps[OF \xs \ lists {u\<^sub>0, u\<^sub>1}\] pref_prolong by blast - next + using pref_extD[OF bin_fst_mismatch] Cons.hyps[OF \xs \ lists {u\<^sub>0, u\<^sub>1}\] pref_prolong by blast + next show "\ \p u\<^sub>1 \ concat xs \ \" - using pref_extD[OF bin_snd_mismatch] Cons.hyps[OF \xs \ lists {u\<^sub>0, u\<^sub>1}\] pref_prolong by blast + using pref_extD[OF bin_snd_mismatch] Cons.hyps[OF \xs \ lists {u\<^sub>0, u\<^sub>1}\] pref_prolong by blast qed -qed - -lemma bin_lcp_pref_all_hull: "w \ \{u\<^sub>0,u\<^sub>1}\ \ \ \p w \ \" +qed simp + +lemma bin_lcp_pref_all_hull: "w \ \{u\<^sub>0,u\<^sub>1}\ \ \ \p w \ \" using bin_lcp_pref_all using hull_concat_listsE by metis -lemma bin_fst_mismatch_all: "xs \ lists {u\<^sub>0,u\<^sub>1} \ \ \ [c\<^sub>0] \p u\<^sub>0 \ concat xs \ \" -using pref_prolong[OF bin_fst_mismatch bin_lcp_pref_all]. - -lemma bin_fst_mismatch_all_hull: assumes "w \ \{u\<^sub>0,u\<^sub>1}\" shows "\ \ [c\<^sub>0] \p u\<^sub>0 \ w \ \" - using bin_fst_mismatch_all hull_concat_listsE[OF assms] by metis - -lemma bin_snd_mismatch_all: assumes "xs \ lists {u\<^sub>0,u\<^sub>1}" - shows "\ \ [c\<^sub>1] \p u\<^sub>1 \ concat xs \ \" - using pref_prolong[OF bin_snd_mismatch bin_lcp_pref_all[OF assms]]. - -lemma bin_snd_mismatch_all_hull: assumes "w \ \{u\<^sub>0,u\<^sub>1}\" - shows "\ \ [c\<^sub>1] \p u\<^sub>1 \ w \ \" - using bin_snd_mismatch_all hull_concat_listsE[OF assms] by metis +lemma bin_lcp_mismatch_pref_all_bool: assumes "q \p w" and "w \ \{uu b,uu (\ b)}\" and "\<^bold>|\\<^bold>| < \<^bold>|uu a \ q\<^bold>|" + shows "\ \ [cc a] \p uu a \ q" +proof- + have aux: "uu a \ w \ \ = (uu a \ q) \ (q\\<^sup>>w \ \)" "{uu b,uu (\ b)} = {u\<^sub>0,u\<^sub>1}" + using lq_pref[OF \q \p w\] bin_code_set_bool by force+ + have "\<^bold>|\ \ [cc a]\<^bold>| \ \<^bold>|uu a \ q\<^bold>|" + using \\<^bold>|\\<^bold>| < \<^bold>|uu a \ q\<^bold>|\ by auto + thus ?thesis + using pref_prolong[OF bin_mismatch_bool bin_lcp_pref_all_hull[OF \w \ \{uu b,uu (\ b)}\\[unfolded aux]], of a] + unfolding aux by blast +qed + +lemmas bin_lcp_mismatch_pref_all_fst = bin_lcp_mismatch_pref_all_bool[of _ _ True True, unfolded bin_code_simps] and + bin_lcp_mismatch_pref_all_snd = bin_lcp_mismatch_pref_all_bool[of _ _ True False, unfolded bin_code_simps] + +lemma bin_lcp_pref_all_len: assumes "q \p w" and "w \ \{u\<^sub>0,u\<^sub>1}\" and "\<^bold>|\\<^bold>| \ \<^bold>|q\<^bold>|" + shows "\ \p q" + using bin_lcp_pref_all_hull[OF \w \ \{u\<^sub>0,u\<^sub>1}\\] pref_ext[OF \q \p w\] prefix_length_prefix[OF _ _ \\<^bold>|bin_code_lcp\<^bold>| \ \<^bold>|q\<^bold>|\] by blast + +lemma bin_mismatch_all_bool: assumes "xs \ lists {uu b, uu (\ b)}" shows "\ \ [cc a] \p (uu a) \ concat xs \ \" + using pref_prolong[OF bin_mismatch_bool bin_lcp_pref_all, of xs a] assms unfolding bin_code_set_bool[of b]. + +lemmas bin_fst_mismatch_all = bin_mismatch_all_bool[of _ True True, unfolded bin_code_simps] and + bin_snd_mismatch_all = bin_mismatch_all_bool[of _ True False, unfolded bin_code_simps] + +lemma bin_mismatch_all_hull_bool: assumes "w \ \{uu b,uu (\ b)}\" shows "\ \ [cc a] \p uu a \ w \ \" + using bin_mismatch_all_bool hull_concat_listsE[OF assms] by metis + +lemmas bin_fst_mismatch_all_hull = bin_mismatch_all_hull_bool[of _ True True, unfolded bin_code_simps] and + bin_snd_mismatch_all_hull = bin_mismatch_all_hull_bool[of _ True False, unfolded bin_code_simps] + +lemma bin_mismatch_all_len_bool: assumes "q \p uu a \ w" and "w \ \{uu b,uu (\ b)}\" and "\<^bold>|\\<^bold>| < \<^bold>|q\<^bold>|" + shows "\ \ [cc a] \p q" +proof- + have "\<^bold>|\ \ [cc a]\<^bold>| \ \<^bold>|uu a \ w\<^bold>|" "\<^bold>|\ \ [cc a]\<^bold>| \ \<^bold>|q\<^bold>|" + using less_le_trans[OF \\<^bold>|\\<^bold>| < \<^bold>|q\<^bold>|\ pref_len[OF \q \p uu a \ w\]] \\<^bold>|\\<^bold>| < \<^bold>|q\<^bold>|\ by force+ + from pref_prod_le[OF bin_mismatch_all_hull_bool[OF assms(2), unfolded lassoc], OF this(1)] + show ?thesis + by (rule prefix_length_prefix) fact+ +qed + +lemmas bin_fst_mismatch_all_len = bin_mismatch_all_len_bool[of _ True _ True, unfolded bin_code_simps] and + bin_snd_mismatch_all_len = bin_mismatch_all_len_bool[of _ False _ True, unfolded bin_code_simps] + +lemma bin_code_delay: assumes "\<^bold>|\\<^bold>| \ \<^bold>|q\<^sub>0\<^bold>|" and "\<^bold>|\\<^bold>| \ \<^bold>|q\<^sub>1\<^bold>|" and + "q\<^sub>0 \p u\<^sub>0 \ w\<^sub>0" and "q\<^sub>1 \p u\<^sub>1 \ w\<^sub>1" and + "w\<^sub>0 \ \{u\<^sub>0, u\<^sub>1}\" and "w\<^sub>1 \ \{u\<^sub>0, u\<^sub>1}\" + shows "q\<^sub>0 \\<^sub>p q\<^sub>1 = \" +proof- + have p1: "\ \ [c\<^sub>0] \p u\<^sub>0 \ w\<^sub>0 \ \" + using assms(5) using bin_fst_mismatch_all_hull by auto + have p2: "\ \ [c\<^sub>1] \p u\<^sub>1 \ w\<^sub>1 \ \" + using assms(6) using bin_snd_mismatch_all_hull by auto + have lcp: "u\<^sub>0 \ w\<^sub>0 \ \ \\<^sub>p u\<^sub>1 \ w\<^sub>1 \ \ = \" + using lcp_first_mismatch_pref[OF p1 p2 bin_mismatch_neq]. + from lcp_extend_eq[of "q\<^sub>0" "u\<^sub>0 \ w\<^sub>0 \ \" "q\<^sub>1" "u\<^sub>1 \ w\<^sub>1 \ \", + unfolded this,OF _ _ assms(1-2)] + show ?thesis + using pref_ext[OF \q\<^sub>0 \p u\<^sub>0 \ w\<^sub>0\] pref_ext[OF \q\<^sub>1 \p u\<^sub>1 \ w\<^sub>1\] by force +qed lemma hd_lq_mismatch_fst: "hd (\\\<^sup>>(u\<^sub>0 \ \)) = c\<^sub>0" using hd_lq_conv_nth[OF prefix_snocD[OF bin_fst_mismatch]] bin_fst_mismatch - by (auto simp add: prefix_def) + by (auto simp add: prefix_def) lemma hd_lq_mismatch_snd: "hd (\\\<^sup>>(u\<^sub>1 \ \)) = c\<^sub>1" using hd_lq_conv_nth[OF prefix_snocD[OF bin_snd_mismatch]] bin_snd_mismatch - by (auto simp add: prefix_def) + by (auto simp add: prefix_def) lemma hds_bin_mismatch_neq: "hd (\\\<^sup>>(u\<^sub>0 \ \)) \ hd (\\\<^sup>>(u\<^sub>1 \ \))" unfolding hd_lq_mismatch_fst hd_lq_mismatch_snd - using bin_mismatch_neq. - -lemma bin_lcp_fst_pow_pref: "\ \ [c\<^sub>0] \p u\<^sub>0\<^sup>@Suc k \ u\<^sub>1 \ z" -proof (induct k) -case 0 -then show ?case - using pref_ext[OF bin_fst_mismatch'] by auto + using bin_mismatch_neq. + +lemma bin_lcp_fst_pow_pref: assumes "0 < k" shows "\ \ [c\<^sub>0] \p u\<^sub>0\<^sup>@k \ u\<^sub>1 \ z" + using assms +proof (induct k rule: nat_induct_non_zero) + case 1 + then show ?case + unfolding pow_1 using pref_prolong[OF bin_fst_mismatch' triv_pref]. next -case (Suc k) - from pref_prolong[OF bin_fst_mismatch, OF pref_extD[OF this]] + case (Suc n) show ?case - unfolding pow_Suc rassoc. + unfolding pow_Suc rassoc + by (rule pref_prolong[OF bin_fst_mismatch]) + (use append_prefixD[OF Suc.hyps(2)] in blast) 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: "\ \p u\<^sub>0 \ \" and bin_lcp_snd_lcp: "\ \p u\<^sub>1 \ \" using pref_extD[OF bin_fst_mismatch] pref_extD[OF bin_snd_mismatch]. lemma bin_lcp_pref_all_set: assumes "set ws = {u\<^sub>0,u\<^sub>1}" - shows "\ \p concat ws" + shows "\ \p concat ws" proof- - have "ws \ lists {u\<^sub>0, u\<^sub>1}" + have "ws \ lists {u\<^sub>0, u\<^sub>1}" using assms by blast have "\<^bold>|u\<^sub>0\<^bold>| + \<^bold>|u\<^sub>1\<^bold>| \ \<^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 \ws \ lists {u\<^sub>0, u\<^sub>1}\]] bin_lcp_short - show ?thesis + with pref_prod_le[OF bin_lcp_pref_all[OF \ws \ lists {u\<^sub>0, u\<^sub>1}\]] bin_lcp_short + show ?thesis by simp qed -lemma bin_lcp_conjug_morph: +lemma bin_lcp_conjug_morph: assumes "u \ \{u\<^sub>0,u\<^sub>1}\" and "v \ \{u\<^sub>0,u\<^sub>1}\" shows "\\\<^sup>>(u \ \) \ \\\<^sup>>(v \ \) = \\\<^sup>>((u \ v) \ \)" unfolding lq_reassoc[OF bin_lcp_pref_all_hull[OF \u \ \{u\<^sub>0,u\<^sub>1}\\]] rassoc - lq_pref[OF bin_lcp_pref_all_hull[OF \v \ \{u\<^sub>0,u\<^sub>1}\\]].. + lq_pref[OF bin_lcp_pref_all_hull[OF \v \ \{u\<^sub>0,u\<^sub>1}\\]].. lemma lcp_bin_conjug_prim_iff: "set ws = {u\<^sub>0,u\<^sub>1} \ primitive (\\\<^sup>>(concat ws) \ \) \ 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 (\u. \\\<^sup>>(u \ \)) \{u\<^sub>0,u\<^sub>1}\" unfolding inj_on_def using bin_lcp_pref_all_hull cancel_right lq_pref by metis -lemma bin_code_lcp_marked: assumes "us \ lists {u\<^sub>0,u\<^sub>1}" and "vs \ lists {u\<^sub>0,u\<^sub>1}" and "hd us \ hd vs" +lemma bin_code_lcp_marked: assumes "us \ lists {u\<^sub>0,u\<^sub>1}" and "vs \ lists {u\<^sub>0,u\<^sub>1}" and "hd us \ hd vs" shows "concat us \ \ \\<^sub>p concat vs \ \ = \" proof (cases "us = \ \ vs = \") assume "us = \ \ vs = \" thus ?thesis - using append_self_conv2 assms(1) assms(2) bin_lcp_pref_all concat.simps(1) lcp_pref_conv lcp_sym by metis + using append_self_conv2 assms(1) assms(2) bin_lcp_pref_all concat.simps(1) lcp_pref_conv lcp_sym by metis next assume "\ (us = \ \ vs = \)" hence "us \ \" and "vs \ \" by blast+ have spec_case: "concat us \ \ \\<^sub>p concat vs \ \ = \" if "us \ lists {u\<^sub>0,u\<^sub>1}" and "vs \ lists {u\<^sub>0,u\<^sub>1}" and "hd us = u\<^sub>0" and "hd vs = u\<^sub>1" and "us \ \" and "vs \ \" for us vs proof- have "concat us = u\<^sub>0 \ concat (tl us)" unfolding hd_concat_tl[OF \us \ \\, symmetric] \hd us = u\<^sub>0\.. from bin_fst_mismatch_all[OF tl_in_lists[OF \us \ lists {u\<^sub>0,u\<^sub>1}\], folded rassoc this] have pref1: "\ \ [c\<^sub>0] \p concat us \ \". have "concat vs = u\<^sub>1 \ concat (tl vs)" unfolding hd_concat_tl[OF \vs \ \\, symmetric] \hd vs = u\<^sub>1\.. from bin_snd_mismatch_all[OF tl_in_lists[OF \vs \ lists {u\<^sub>0,u\<^sub>1}\], folded rassoc this] have pref2: "\ \ [c\<^sub>1] \p concat vs \ \". show ?thesis using lcp_first_mismatch_pref[OF pref1 pref2 bin_mismatch_neq]. qed have "hd us \ {u\<^sub>0,u\<^sub>1}" and "hd vs \ {u\<^sub>0,u\<^sub>1}" using - lists_hd_in_set[OF \us \ \\ \us \ lists {u\<^sub>0, u\<^sub>1}\] lists_hd_in_set[OF \vs \ \\ \vs \ lists {u\<^sub>0, u\<^sub>1}\]. + lists_hd_in_set[OF \us \ \\ \us \ lists {u\<^sub>0, u\<^sub>1}\] lists_hd_in_set[OF \vs \ \\ \vs \ lists {u\<^sub>0, u\<^sub>1}\]. then consider "hd us = u\<^sub>0 \ hd vs = u\<^sub>1" | "hd us = u\<^sub>1 \ hd vs = u\<^sub>0" - using \hd us \ hd vs\ by fastforce + using \hd us \ hd vs\ by fastforce then show ?thesis using spec_case[rule_format] \us \ \\ \vs \ \\ assms lcp_sym by metis qed -\ \ALT PROOF\ -lemma assumes "us \ lists {u\<^sub>0,u\<^sub>1}" and "vs \ lists {u\<^sub>0,u\<^sub>1}" and "hd us \ hd vs" +\ \ALT PROOF\ +lemma assumes "us \ lists {u\<^sub>0,u\<^sub>1}" and "vs \ lists {u\<^sub>0,u\<^sub>1}" and "hd us \ hd vs" shows "concat us \ \ \\<^sub>p concat vs \ \ = \" using assms -proof (induct us vs rule: list_induct2', simp) +proof (induct us vs rule: list_induct2') case (2 x xs) show ?case using bin_lcp_pref_all[OF \x # xs \ lists {u\<^sub>0, u\<^sub>1}\, folded lcp_pref_conv, unfolded lcp_sym[of \]] by simp next case (3 y ys) show ?case using bin_lcp_pref_all[OF \y # ys \ lists {u\<^sub>0, u\<^sub>1}\, 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 "i.bin_code_lcp = \" + have "i.bin_code_lcp = \" using i.bin_lcp_swap[symmetric] by blast have c0: "i.bin_code_lcp \ [i.bin_code_mismatch_fst] \p x \ concat xs \ i.bin_code_lcp" - using i.bin_lcp_pref_all[of xs] \x # xs \ lists {u\<^sub>0, u\<^sub>1}\[unfolded Cons_in_lists_iff alph] + using i.bin_lcp_pref_all[of xs] \x # xs \ lists {u\<^sub>0, u\<^sub>1}\[unfolded Cons_in_lists_iff alph] pref_prolong[OF i.bin_fst_mismatch] by blast have c1: "i.bin_code_lcp \ [i.bin_code_mismatch_snd] \p y \ concat ys \ i.bin_code_lcp" using pref_prolong[OF conjunct2[OF \y # ys \ lists {u\<^sub>0, u\<^sub>1}\[unfolded Cons_in_lists_iff alph], - THEN i.bin_snd_mismatch_all[of ys]], OF self_pref]. + THEN i.bin_snd_mismatch_all[of ys]], OF self_pref]. have "i.bin_code_lcp\[i.bin_code_mismatch_fst] \\<^sub>p i.bin_code_lcp\[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 bin_lcp_swap] - show ?case + show ?case unfolding concat.simps(2) rassoc using i.bin_mismatch_neq - \i.bin_code_lcp = \\ by force - -qed - -lemma bin_code_lcp_concat: assumes "us \ lists {u\<^sub>0,u\<^sub>1}" and "vs \ lists {u\<^sub>0,u\<^sub>1}" and "\ us \ vs" + \i.bin_code_lcp = \\ by force +qed simp + +lemma bin_code_lcp_concat: assumes "us \ lists {u\<^sub>0,u\<^sub>1}" and "vs \ lists {u\<^sub>0,u\<^sub>1}" and "\ us \ vs" shows "concat us \ \ \\<^sub>p concat vs \ \ = concat (us \\<^sub>p vs) \ \" proof- obtain us' vs' where us: "(us \\<^sub>p vs) \ us' = us" and vs: "(us \\<^sub>p vs) \ vs' = vs" and "us' \ \" and "vs' \ \" and "hd us' \ hd vs'" using lcp_mismatchE[OF \\ us \ vs\]. have cu: "concat us \ \ = concat (us \\<^sub>p vs) \ concat us' \ \" unfolding lassoc concat_morph[symmetric] us.. have cv: "concat vs \ \ = concat (us \\<^sub>p vs) \ concat vs' \ \" unfolding lassoc concat_morph[symmetric] vs.. have "us' \ lists {u\<^sub>0,u\<^sub>1}" using \us \ lists {u\<^sub>0,u\<^sub>1}\ us by inlists have "vs' \ lists {u\<^sub>0,u\<^sub>1}" using \vs \ lists {u\<^sub>0,u\<^sub>1}\ vs by inlists show "concat us \ \ \\<^sub>p concat vs \ \ = concat (us \\<^sub>p vs) \ \" - unfolding cu cv + unfolding cu cv using bin_code_lcp_marked[OF \us' \ lists {u\<^sub>0,u\<^sub>1}\ \vs' \ lists {u\<^sub>0,u\<^sub>1}\ \hd us' \ hd vs'\] unfolding lcp_ext_left by fast qed -lemma bin_code_lcp_concat': assumes "us \ lists {u\<^sub>0,u\<^sub>1}" and "vs \ lists {u\<^sub>0,u\<^sub>1}" and "\ concat us \ concat vs" +lemma bin_code_lcp_concat': assumes "us \ lists {u\<^sub>0,u\<^sub>1}" and "vs \ lists {u\<^sub>0,u\<^sub>1}" and "\ concat us \ concat vs" shows "concat us \\<^sub>p concat vs = concat (us \\<^sub>p vs) \ \" 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 \ u\<^sub>1 \ z \\<^sub>p u\<^sub>1\<^sup>@Suc l \ u\<^sub>0 \ z' = \" +lemma bin_lcp_pows: "0 < k \ 0 < l \ u\<^sub>0\<^sup>@k \ u\<^sub>1 \ z \\<^sub>p u\<^sub>1\<^sup>@l \ u\<^sub>0 \ z' = \" using lcp_first_mismatch_pref[OF bin_lcp_fst_pow_pref bin_lcp_snd_pow_pref bin_mismatch_neq]. theorem bin_code: assumes "us \ lists {u\<^sub>0,u\<^sub>1}" and "vs \ 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 -next - case (3 y ys) - then show ?case - using bin_fst_nemp bin_snd_nemp by auto -next +proof (induct us vs rule: list_induct2') case (4 x xs y ys) - then show ?case - proof(cases "x = y") - assume "x = y" thus "x # xs = y # ys" - using "4.hyps" \concat (x # xs) = concat (y # ys)\[unfolded concat.simps(2) \x = y\, unfolded cancel] - \y # ys \ lists {u\<^sub>0, u\<^sub>1}\[unfolded Cons_in_lists_iff] \x # xs \ lists {u\<^sub>0, u\<^sub>1}\[unfolded Cons_in_lists_iff] - by simp - next - assume "x \ y" - have "concat(y # ys) = \" - using bin_code_lcp_marked[OF \x # xs \ lists {u\<^sub>0, u\<^sub>1}\ \y # ys \ lists {u\<^sub>0, u\<^sub>1}\, unfolded list.sel(1) \concat (x # xs) = concat (y # ys)\, OF \x \ y\] + then show ?case + proof- + have "x =y" + using bin_code_lcp_marked[OF \x # xs \ lists {u\<^sub>0, u\<^sub>1}\ \y # ys \ lists {u\<^sub>0, u\<^sub>1}\] \y # ys \ lists {u\<^sub>0, u\<^sub>1}\ non_comm + unfolding \concat (x # xs) = concat (y # ys)\ unfolding concat.simps(2) lcp_self list.sel(1) + by auto + thus "x # xs = y # ys" + using "4.hyps" \concat (x # xs) = concat (y # ys)\[unfolded concat.simps(2) \x = y\, unfolded cancel] + \y # ys \ lists {u\<^sub>0, u\<^sub>1}\[unfolded Cons_in_lists_iff] \x # xs \ lists {u\<^sub>0, u\<^sub>1}\[unfolded Cons_in_lists_iff] by simp - hence "x = \" and "y = \" - using \ concat (x # xs) = concat (y # ys)\ unfolding concat.simps(2) pref_nemp by force+ - with \x \ y\ - show "x # xs = y # ys" by blast qed -qed - -lemma code_bin_roots: "binary_code (\ u\<^sub>0) (\ u\<^sub>1)" - using non_comm comp_primroot_conv' by unfold_locales blast +qed (auto simp: bin_fst_nemp bin_snd_nemp) + +lemma code_bin_roots: "binary_code (\ u\<^sub>0) (\ 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 \ \{u\<^sub>0,u\<^sub>1}\" and "p \p w0" "w1 \ \{u\<^sub>0,u\<^sub>1}\" and "\<^bold>|u\<^sub>1\<^bold>| \ \<^bold>|p\<^bold>|" - shows " \ u\<^sub>0 \ p \p u\<^sub>1 \ w1" +lemma primroot_dec: "(Dec {\ u\<^sub>0, \ u\<^sub>1} u\<^sub>0) = [\ u\<^sub>0]\<^sup>@e\<^sub>\ u\<^sub>0" "(Dec {\ u\<^sub>0, \ u\<^sub>1} u\<^sub>1) = [\ u\<^sub>1]\<^sup>@e\<^sub>\ u\<^sub>1" +proof- + interpret rs: binary_code "\ u\<^sub>0" "\ u\<^sub>1" + by (simp add: code_bin_roots) + from primroot_exp_eq + have "concat ([\ u\<^sub>0]\<^sup>@e\<^sub>\ u\<^sub>0) = u\<^sub>0" "concat ([\ u\<^sub>1]\<^sup>@e\<^sub>\ u\<^sub>1) = u\<^sub>1" + by force+ + from rs.code_unique_dec[OF _ this(1)] rs.code_unique_dec[OF _ this(2)] + show "(Dec {\ u\<^sub>0, \ u\<^sub>1} u\<^sub>0) = [\ u\<^sub>0]\<^sup>@e\<^sub>\ u\<^sub>0" "(Dec {\ u\<^sub>0, \ u\<^sub>1} u\<^sub>1) = [\ u\<^sub>1]\<^sup>@e\<^sub>\ u\<^sub>1" + by (simp_all add: sing_pow_lists) +qed + +lemma bin_code_prefs: assumes "w \ \{u\<^sub>0,u\<^sub>1}\" and "p \p w" "w' \ \{u\<^sub>0,u\<^sub>1}\" and "\<^bold>|u\<^sub>1\<^bold>| \ \<^bold>|p\<^bold>|" + shows " \ u\<^sub>0 \ p \p u\<^sub>1 \ w'" proof - assume contr: "u\<^sub>0 \ p \p u\<^sub>1 \ w1" + assume contr: "u\<^sub>0 \ p \p u\<^sub>1 \ w'" have "\<^bold>|\\<^bold>| < \<^bold>|u\<^sub>0 \ p\<^bold>|" using \\<^bold>|u\<^sub>1\<^bold>| \ \<^bold>|p\<^bold>|\ bin_lcp_short by auto - obtain ws0 where "ws0 \ lists {u\<^sub>0,u\<^sub>1}" and "concat ws0 = w0" - using \w0 \ \{u\<^sub>0,u\<^sub>1}\\ hull_concat_lists0 by blast - obtain ws1 where "ws1 \ lists {u\<^sub>0,u\<^sub>1}" and "concat ws1 = w1" - using \w1 \ \{u\<^sub>0,u\<^sub>1}\\ hull_concat_lists0 by blast - from bin_code_lcp_marked[of "[u\<^sub>0] \ ws0" "[u\<^sub>1] \ ws1"] - have "u\<^sub>0 \ w0 \ \ \\<^sub>p u\<^sub>1 \ w1 \ \ = \" - using \ws0 \ lists {u\<^sub>0,u\<^sub>1}\ \ws1 \ lists {u\<^sub>0,u\<^sub>1}\ \concat ws0 = w0\ \concat ws1 = w1\ - bin_code_neq by auto - with lcp_pref_ext[OF contr] - have "u\<^sub>0 \ p \p \" - using append_assoc lq_pref[OF \p \p w0\] by metis - thus False - using \\<^bold>|\\<^bold>| < \<^bold>|u\<^sub>0 \ p\<^bold>|\ unfolding prefix_def by fastforce + hence "\ \ [c\<^sub>0] \p u\<^sub>0 \ p" + using \p \p w\ \w \ \{u\<^sub>0,u\<^sub>1}\\ bin_lcp_mismatch_pref_all_fst by auto + from pref_ext[OF pref_trans[OF this contr], unfolded rassoc] + have "\ \ [c\<^sub>0] \p u\<^sub>1 \ w' \ \". + from bin_mismatch_neq same_sing_pref[OF bin_snd_mismatch_all_hull[OF \w' \ \{u\<^sub>0,u\<^sub>1}\\] this] + show False + by simp qed -lemma bin_code_rev: "binary_code (rev u\<^sub>0) (rev u\<^sub>1)" +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: "\ u\<^sub>0\<^sup>@Suc k \ u\<^sub>1 \ z = u\<^sub>1\<^sup>@Suc l \ u\<^sub>0 \ z'" proof (rule notI) assume eq: "u\<^sub>0 \<^sup>@ Suc k \ u\<^sub>1 \ z = u\<^sub>1 \<^sup>@ Suc l \ u\<^sub>0 \ z'" have pref1: "\ \ [c\<^sub>0] \p u\<^sub>0\<^sup>@Suc k \ u\<^sub>1" and pref2: "\ \ [c\<^sub>1] \p u\<^sub>1\<^sup>@Suc l \ u\<^sub>0" - using bin_lcp_fst_pow_pref[of k \, unfolded clean_emp] bin_lcp_snd_pow_pref[of l \, 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 + using bin_lcp_fst_pow_pref[of "Suc k" \, unfolded emp_simps] bin_lcp_snd_pow_pref[of "Suc l" \, unfolded emp_simps] by blast+ + 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 \ u\<^sub>1\<^sup>@Suc l \\<^sub>p u\<^sub>1\<^sup>@Suc l \ u\<^sub>0\<^sup>@Suc k = u\<^sub>0 \ u\<^sub>1 \\<^sub>p u\<^sub>1 \ u\<^sub>0" - using bin_lcp_def bin_lcp_pows by auto - -lemma bin_mismatch: "u\<^sub>0 \ \ \\<^sub>p u\<^sub>1 \ \ = \" - using lcp_first_mismatch_pref[OF bin_fst_mismatch bin_snd_mismatch bin_mismatch_neq]. +lemma bin_lcp_pows_lcp: "0 < k \ 0 < l \ u\<^sub>0\<^sup>@k \ u\<^sub>1\<^sup>@l \\<^sub>p u\<^sub>1\<^sup>@l \ u\<^sub>0\<^sup>@k = u\<^sub>0 \ u\<^sub>1 \\<^sub>p u\<^sub>1 \ u\<^sub>0" + using bin_lcp_pows unfolding bin_lcp_def using pow_pos by metis + +lemma bin_mismatch: "u\<^sub>0 \ \ \\<^sub>p u\<^sub>1 \ \ = \" + using lcp_first_mismatch_pref[OF bin_fst_mismatch bin_snd_mismatch bin_mismatch_neq]. lemma not_comp_bin_fst_snd: "\ u\<^sub>0 \ \ \ u\<^sub>1 \ \" - using prefs_comp_comp[OF bin_fst_mismatch bin_snd_mismatch] bin_mismatch_neq + using ruler_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 \p u\<^sub>0 \ w\<^sub>0" and "z \p u\<^sub>1 \ w\<^sub>1" - and "w\<^sub>0 \ \{u\<^sub>0,u\<^sub>1}\" and "w\<^sub>1 \ \{u\<^sub>0,u\<^sub>1}\" - shows "\<^bold>|z\<^bold>| \ \<^bold>|\\<^bold>|" +theorem bin_bounded_delay: assumes "z \p u\<^sub>0 \ w\<^sub>0" and "z \p u\<^sub>1 \ w\<^sub>1" + and "w\<^sub>0 \ \{u\<^sub>0,u\<^sub>1}\" and "w\<^sub>1 \ \{u\<^sub>0,u\<^sub>1}\" +shows "\<^bold>|z\<^bold>| \ \<^bold>|\\<^bold>|" proof (rule leI, rule notI) assume "\<^bold>|\\<^bold>| < \<^bold>|z\<^bold>|" - hence "\<^bold>|\ \ [a]\<^bold>| \ \<^bold>|z\<^bold>|" for a + hence "\<^bold>|\ \ [a]\<^bold>| \ \<^bold>|z\<^bold>|" for a unfolding lenmorph sing_len by simp have "z \p u\<^sub>0 \ w\<^sub>0 \ \" and "z \p u\<^sub>1 \ w\<^sub>1 \ \" using pref_prolong[OF \z \p u\<^sub>0 \ w\<^sub>0\ triv_pref] pref_prolong[OF \z \p u\<^sub>1 \ w\<^sub>1\ triv_pref]. have "\ \ [c\<^sub>0] \p u\<^sub>0 \ w\<^sub>0 \ \" and "\ \ [c\<^sub>1] \p u\<^sub>1 \ w\<^sub>1 \ \" - using bin_fst_mismatch_all_hull[OF \w\<^sub>0 \ \{u\<^sub>0,u\<^sub>1}\\] bin_snd_mismatch_all_hull[OF \w\<^sub>1 \ \{u\<^sub>0,u\<^sub>1}\\]. - from \z \p u\<^sub>0 \ w\<^sub>0 \ \\ \\ \ [c\<^sub>0] \p u\<^sub>0 \ w\<^sub>0 \ \\ \\<^bold>|\ \ [c\<^sub>0]\<^bold>| \ \<^bold>|z\<^bold>|\ - have "\ \ [c\<^sub>0] \p z" - using prefix_length_prefix by blast - from \z \p u\<^sub>1 \ w\<^sub>1 \ \\ \\ \ [c\<^sub>1] \p u\<^sub>1 \ w\<^sub>1 \ \\ \\<^bold>|\ \ [c\<^sub>1]\<^bold>| \ \<^bold>|z\<^bold>|\ - have "\ \ [c\<^sub>1] \p z" - using prefix_length_prefix by blast - from \\ \ [c\<^sub>1] \p z\ \\ \ [c\<^sub>0] \p z\ bin_mismatch_neq - show False - unfolding prefix_def by force -qed - -no_notation bin_code_lcp ("\") and - (* bin_code_lcs ("\") and *) - (* bin_code_lcp' ("\\<^sub>s") and *) - (* bin_code_lcs' ("\") 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*) - + using bin_fst_mismatch_all_hull[OF \w\<^sub>0 \ \{u\<^sub>0,u\<^sub>1}\\] bin_snd_mismatch_all_hull[OF \w\<^sub>1 \ \{u\<^sub>0,u\<^sub>1}\\]. + from \z \p u\<^sub>0 \ w\<^sub>0 \ \\ \\ \ [c\<^sub>0] \p u\<^sub>0 \ w\<^sub>0 \ \\ \\<^bold>|\ \ [c\<^sub>0]\<^bold>| \ \<^bold>|z\<^bold>|\ + have "\ \ [c\<^sub>0] \p z" + using prefix_length_prefix by blast + from \z \p u\<^sub>1 \ w\<^sub>1 \ \\ \\ \ [c\<^sub>1] \p u\<^sub>1 \ w\<^sub>1 \ \\ \\<^bold>|\ \ [c\<^sub>1]\<^bold>| \ \<^bold>|z\<^bold>|\ + have "\ \ [c\<^sub>1] \p z" + using prefix_length_prefix by blast + from \\ \ [c\<^sub>1] \p z\ \\ \ [c\<^sub>0] \p z\ bin_mismatch_neq + show False + unfolding prefix_def by force +qed + +thm binary_code.bin_lcp_pows_lcp + +lemma prim_roots_lcp: "\ u\<^sub>0 \ \ u\<^sub>1 \\<^sub>p \ u\<^sub>1 \ \ u\<^sub>0 = \" +proof- + obtain k where "\ u\<^sub>0\<^sup>@k = u\<^sub>0" "0 < k" + using primroot_expE. + obtain m where "\ u\<^sub>1\<^sup>@m = u\<^sub>1" "0 < m" + using primroot_expE. + have "\ u\<^sub>0 \ \ u\<^sub>1 \ \ u\<^sub>1 \ \ u\<^sub>0" + using non_comm[unfolded comp_primroot_conv'[of u\<^sub>0]]. + then interpret r: binary_code "\ u\<^sub>0" "\ u\<^sub>1" by unfold_locales + from r.bin_lcp_pows_lcp[OF \0 < k\ \0 < m\, unfolded \\ u\<^sub>1\<^sup>@m = u\<^sub>1\ \\ u\<^sub>0\<^sup>@k = u\<^sub>0\, symmetric] + show ?thesis + unfolding bin_lcp_def. +qed + +subsubsection \Maximal r-prefixes\ + +lemma bin_lcp_per_root_max_pref_short: assumes "\

0 \ u\<^sub>1 \\<^sub>p r \ u\<^sub>0 \ u\<^sub>1" and "r \ \" and "q \p w" and "w \ \{u\<^sub>0, u\<^sub>1}\" + shows "u\<^sub>1 \ q \\<^sub>p r \ u\<^sub>1 \ q = take \<^bold>|u\<^sub>1 \ q\<^bold>| \" +proof- + have "q \ \" + using bin_lcp_pref_all_hull[OF \w \ \{u\<^sub>0, u\<^sub>1}\\] ruler_comp[OF \q \p w\, of \ "w \ \"] by blast + hence comp1: "u\<^sub>1 \ q \ \ \ [c\<^sub>1]" + using ruler_comp[OF self_pref bin_snd_mismatch, of "u\<^sub>1 \ q"] unfolding comp_cancel by blast + + from add_nth_pref[OF assms(1), THEN pref_lcp_pref] bin_fst_mismatch' + have "(u\<^sub>0 \ u\<^sub>1 \\<^sub>p r \ u\<^sub>0 \ u\<^sub>1) ! \<^bold>|\\<^bold>| = c\<^sub>0" + using same_sing_pref by fast + + from add_nth_pref[OF assms(1), unfolded this] + have "\ \ [c\<^sub>0] \p r \ u\<^sub>0 \ u\<^sub>1" + by force + + have len: "\<^bold>|\ \ [c\<^sub>0]\<^bold>| \ \<^bold>|r \ \\<^bold>|" + using nemp_pos_len[OF \r \ \\] unfolding lenmorph sing_len by linarith + + have comp2: "r \ u\<^sub>1 \ q \ \ \ [c\<^sub>0]" + proof(rule ruler_comp[OF _ _ comp_refl]) + show "r \ u\<^sub>1 \ q \p r \ u\<^sub>1 \ w \ \" + using \q \p w\ by fastforce + show "\ \ [c\<^sub>0] \p r \ u\<^sub>1 \ w \ \" + proof(rule pref_prolong) + show "\ \ [c\<^sub>0] \p r \ \" + using \\ \ [c\<^sub>0] \p r \ u\<^sub>0 \ u\<^sub>1\ bin_lcp_pref len pref_prod_pref_short by blast + show "\ \p u\<^sub>1 \ w \ \" + using \w \ \{u\<^sub>0, u\<^sub>1}\\ bin_lcp_pref_all_hull[of "u\<^sub>1 \ w"] by auto + qed + qed + + have min: "(min \<^bold>|u\<^sub>1 \ q\<^bold>| \<^bold>|r \ u\<^sub>1 \ q\<^bold>|) = \<^bold>|u\<^sub>1 \ q\<^bold>|" + unfolding lenmorph by simp + + show ?thesis + using bin_mismatch_neq double_ruler[OF comp1 comp2,unfolded min] + by (simp add: lcp_mismatch_eq_len mismatch_incopm) +qed + +lemma bin_per_root_max_pref_short: assumes "(u\<^sub>0 \ u\<^sub>1)

u\<^sub>0 \ u\<^sub>1" and "q \p w" and "w \ \{u\<^sub>0, u\<^sub>1}\" + shows "u\<^sub>1 \ q \\<^sub>p r \ u\<^sub>1 \ q = take \<^bold>|u\<^sub>1 \ q\<^bold>| \" +proof (rule bin_lcp_per_root_max_pref_short[OF _ _ assms(2-3)]) + show "\

0 \ u\<^sub>1 \\<^sub>p r \ u\<^sub>0 \ u\<^sub>1" + unfolding lcp.absorb3[OF assms(1)] using bin_fst_mismatch'[THEN prefix_snocD]. +qed (use assms(1) in blast) + +lemma bin_root_max_pref_long: assumes "r \ u\<^sub>0 \ u\<^sub>1 = u\<^sub>0 \ u\<^sub>1 \ r" and "q \p w" and "w \ \{u\<^sub>0, u\<^sub>1}\" and "\<^bold>|\\<^bold>| \ \<^bold>|q\<^bold>|" + shows "u\<^sub>0 \ \ \p u\<^sub>0 \ q \\<^sub>p r \ u\<^sub>0 \ q" +proof (rule pref_pref_lcp) + have len: " \<^bold>|u\<^sub>0 \ \\<^bold>| \ \<^bold>|r \ u\<^sub>0 \ \\<^bold>|" + by simp + from bin_lcp_pref_all_len[OF assms(2-4)] + show "u\<^sub>0 \ \ \p u\<^sub>0 \ q" + unfolding pref_cancel_conv. + have "u\<^sub>0 \ \ \p r \ u\<^sub>0 \ \" + proof(rule ruler_le[OF _ _ len]) + show "u\<^sub>0 \ \ \p (r \ u\<^sub>0 \ u\<^sub>1) \ u\<^sub>0 \ u\<^sub>1" + unfolding assms(1) unfolding rassoc pref_cancel_conv assms(1) + using pref_ext[OF pref_ext[OF bin_lcp_pref'], unfolded rassoc]. + show "r \ u\<^sub>0 \ \ \p (r \ u\<^sub>0 \ u\<^sub>1) \ u\<^sub>0 \ u\<^sub>1" + unfolding rassoc pref_cancel_conv using pref_ext[OF bin_lcp_pref', unfolded rassoc]. + qed + from pref_prolong[OF this[unfolded lassoc], OF \\ \p q\, unfolded rassoc] + show "u\<^sub>0 \ \ \p r \ u\<^sub>0 \ q". +qed + +lemma per_root_lcp_per_root: "u\<^sub>0 \ u\<^sub>1

u\<^sub>0 \ u\<^sub>1 \ \ \ [c\<^sub>0] \p r \ \" + using per_root_pref_sing[OF _ bin_fst_mismatch']. + +lemma per_root_bin_fst_snd_lcp: assumes "u\<^sub>0 \ u\<^sub>1

u\<^sub>0 \ u\<^sub>1" and + "q \p w" and "w \ \{u\<^sub>0,u\<^sub>1}\" and "\<^bold>|\\<^bold>| < \<^bold>|u\<^sub>1 \ q\<^bold>|" + "q' \p w'" and "w' \ \{u\<^sub>0,u\<^sub>1}\" and "\<^bold>|\\<^bold>| \ \<^bold>|q'\<^bold>|" + shows "u\<^sub>1 \ q \\<^sub>p r \ q' = \" +proof- + have pref1: "\ \ [c\<^sub>1] \p u\<^sub>1 \ q" + using \\<^bold>|\\<^bold>| < \<^bold>|u\<^sub>1 \ q\<^bold>|\ \q \p w\ bin_snd_mismatch_all_len[of "u\<^sub>1 \ q", OF _ \w \ \{u\<^sub>0,u\<^sub>1}\\] + unfolding pref_cancel_conv by blast + + have "\ \p q'" + using \\<^bold>|\\<^bold>| \ \<^bold>|q'\<^bold>|\ \q' \p w'\ \w' \ \{u\<^sub>0,u\<^sub>1}\\ bin_lcp_pref_all_len by blast + have pref2: "\ \ [c\<^sub>0] \p r \ \" + using assms(1) per_root_lcp_per_root by auto + hence pref2: "\ \ [c\<^sub>0] \p r \ q'" + using \\ \p q'\ pref_prolong by blast + + show ?thesis + using lcp_first_mismatch_pref[OF pref1 pref2 bin_mismatch_neq[symmetric]]. + +qed + + + +end lemmas no_comm_bin_code = binary_code.bin_code[unfolded binary_code_def] theorem bin_code_code: assumes "u \ v \ v \ u" shows "code {u, v}" - unfolding code_def using no_comm_bin_code[OF assms] by blast - -lemma code_bin_code: "u \ v \ code {u,v} \ u \ v \ v \ u" + unfolding code_def using no_comm_bin_code[OF assms] by blast + +lemma code_bin_code: "u \ v \ code {u,v} \ u \ v \ v \ u" by (elim code.code_not_comm) simp_all -lemma lcp_roots_lcp: assumes "x \ y \ y \ x" shows "x \ y \\<^sub>p y \ x = \ x \ \ y \\<^sub>p \ y \ \ x" -proof- - obtain k where "\ x\<^sup>@Suc k = x" - using assms primroot_expE by auto - obtain m where "\ y\<^sup>@Suc m = y" - using assms primroot_expE by auto - have "\ x \ \ y \ \ y \ \ x" - using assms comp_primroot_conv' by blast - then interpret binary_code "\ x" "\ y" by unfold_locales - from bin_lcp_pows_lcp[of k m, unfolded \\ y\<^sup>@Suc m = y\ \\ x\<^sup>@Suc k = x\] - show ?thesis. -qed +lemma lcp_roots_lcp: "x \ y \ y \ x \ x \ y \\<^sub>p y \ x = \ x \ \ y \\<^sub>p \ y \ \ x" + using binary_code.prim_roots_lcp[unfolded binary_code_def bin_lcp_def, symmetric]. subsection \Binary Mismatch tools\ thm binary_code.bin_mismatch_pows[unfolded binary_code_def] lemma bin_mismatch: "u\<^sup>@Suc k \ v \ z = v\<^sup>@Suc l \ u \ z' \ u \ v = v \ u" using binary_code.bin_mismatch_pows[unfolded binary_code_def] by blast definition bin_mismatch_pref :: "'a list \ 'a list \ 'a list \ bool" where "bin_mismatch_pref x y w \ \ k. x\<^sup>@k \ y \p w" \ \Binary mismatch elims\ -lemma bm_pref_letter: assumes "x \ y \ y \ x" and "bin_mismatch_pref x y (w1 \ y)" +lemma bm_pref_letter: assumes "x \ y \ y \ x" and "bin_mismatch_pref x y (w1 \ y)" shows "bin_lcp x y \ [bin_mismatch x y] \p x \ w1 \ 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 \ y = x\<^sup>@k1 \ y \ z1" by blast have "bin_lcp x y \ [bin_mismatch x y] \p x \ w1 \ y \ bin_lcp x y" - unfolding lassoc \w1 \ y = x\<^sup>@k1 \ y \ z1\ pow_Suc[symmetric] unfolding rassoc using bin_lcp_fst_pow_pref. + unfolding lassoc \w1 \ y = x\<^sup>@k1 \ y \ z1\ pow_Suc[symmetric] unfolding rassoc using bin_lcp_fst_pow_pref by blast have "\<^bold>|bin_lcp x y \ [bin_mismatch x y]\<^bold>| \ \<^bold>|(x \ w1) \ bin_lcp x y\<^bold>|" unfolding lenmorph sing_len using nemp_len[OF bin_fst_nemp] by linarith from ruler_le[OF \bin_lcp x y \ [bin_mismatch x y] \p x \ w1 \ y \ bin_lcp x y\ _ this] show "bin_code_lcp \ [bin_mismatch x y] \p x \ w1 \ bin_code_lcp" unfolding shifts using bin_lcp_snd_lcp. qed lemma bm_eq_hard: assumes "x \ w1 = y \ w2" and "bin_mismatch_pref x y (w1 \ y)" and "bin_mismatch_pref y x (w2 \ x)" shows "x \ y = y \ x" proof(rule classical) assume "x \ y \ y \ 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 \x\w1 = y\w2\ bin_lcp_sym[of y]]] have "bin_mismatch x y = bin_mismatch y x" unfolding lenmorph sing_len cancel by blast thus "x \ y = y \ x" - unfolding bin_mismatch_comm. -qed + unfolding bin_mismatch_comm. +qed + + + +lemma bm_hard_lcp: assumes "x \ y \ y \ x" and "bin_mismatch_pref x y w1" and "bin_mismatch_pref y x w2" + shows "x \ w1 \\<^sub>p y \ w2 = x \ y \\<^sub>p y \ x" +proof- + interpret binary_code x y + using \x \ y \ y \ x\ by unfold_locales + write bin_code_lcp ("\") + from assms[unfolded bin_mismatch_pref_def] + obtain k m where "x\<^sup>@k \ y \p w1" "y\<^sup>@m \ x \p w2" + by blast + hence prefs: "x \ x\<^sup>@k \ y \p x \ w1" "y \ y\<^sup>@m \ x \p y \ w2" + unfolding pref_cancel_conv. + have l_less: "\<^bold>|\\<^bold>| < \<^bold>|x \ x\<^sup>@k \ y\<^bold>|" "\<^bold>|\\<^bold>| < \<^bold>|y \ y\<^sup>@m \ x\<^bold>|" + using bin_lcp_short unfolding lenmorph by simp_all + from bin_code_delay[OF less_imp_le less_imp_le, OF this self_pref self_pref] + have aux: "x \ x\<^sup>@k \ y \\<^sub>p y \ y\<^sup>@ m \ x = \" + by blast+ + have "\ x \ x \<^sup>@ k \ y \ y \ y \<^sup>@ m \ x" + unfolding prefix_comparable_def lcp_pref_conv'[symmetric] aux aux[unfolded lcp_sym[of "x \ _"]] + using l_less by fastforce + thus ?thesis + using lcp_rulers[OF prefs] unfolding bin_lcp_def aux by blast +qed lemma bm_pref_hard: assumes "x \ w1 \p y \ w2" and "bin_mismatch_pref x y w1" and "bin_mismatch_pref y x (w2 \ x)" shows "x \ y = y \ x" proof(rule classical) assume "x \ y \ y \ 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 \ y \ z1" by blast have "bin_lcp x y \ [bin_mismatch x y] \p x \ w1" - unfolding lassoc \w1 = x\<^sup>@k1 \ y \ z1\ 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 \x \ y \ y \ x\[symmetric] assms(3), unfolded bin_lcp_sym[of y]] + unfolding lassoc \w1 = x\<^sup>@k1 \ y \ z1\ pow_Suc[symmetric] unfolding rassoc using bin_lcp_fst_pow_pref by blast + note pref_ext[OF pref_trans[OF this assms(1)], unfolded rassoc] bm_pref_letter[OF \x \ y \ y \ x\[symmetric] assms(3), unfolded bin_lcp_sym[of y]] from ruler_eq_len[OF this] - have "bin_mismatch x y = bin_mismatch y x" + have "bin_mismatch x y = bin_mismatch y x" unfolding lenmorph sing_len cancel by blast thus "x \ y = y \ 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] + unfolding bin_mismatch_comm. +qed + + + + + +named_theorems bm_elims +lemmas [bm_elims] = bm_eq_hard bm_eq_hard[symmetric] bm_pref_hard bm_pref_hard[symmetric] + bm_hard_lcp bm_hard_lcp[symmetric] + arg_cong2[of _ _ _ _ "\ x y. x \\<^sub>p y"] + +named_theorems bm_elims_rev +lemmas [bm_elims_rev] = bm_elims[reversed] \ \Binary mismatch predicate evaluation\ named_theorems bm_simps lemma [bm_simps]: " bin_mismatch_pref x y (y \ v)" - unfolding bin_mismatch_pref_def using append_Nil pow_zero[of x] by fast + unfolding bin_mismatch_pref_def using append_Nil pow_zero[of x] by blast 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 \ \{x,y}\ \ bin_mismatch_pref x y w \ bin_mismatch_pref x y (w1 \ w)" + "w1 \ \{x,y}\ \ bin_mismatch_pref x y w \ bin_mismatch_pref x y (w1 \ w)" unfolding bin_mismatch_pref_def -proof (induct w1 arbitrary: w rule: hull.induct[of _ "{x,y}"], simp) +proof (induct w1 arbitrary: w rule: hull.induct) case (prod_cl w1 w2) - from prod_cl.hyps(3)[OF prod_cl.prems] + from prod_cl.hyps(3)[OF prod_cl.prems] obtain k s where "w2 \ w = x \<^sup>@ k \ y \ s" by (auto simp add: prefix_def) consider "w1 = x" | "w1 = y" using \w1 \ {x,y}\ by blast - then show ?case + then show ?case proof (cases) assume "w1 = x" show ?thesis unfolding rassoc \w2 \ w = x \<^sup>@ k \ y \ s\ \w1 = x\ unfolding lassoc pow_Suc[symmetric] unfolding rassoc using same_prefix_prefix by blast next assume "w1 = y" have "x\<^sup>@0 \ y \p y \ w2 \ w" by auto thus ?thesis - unfolding rassoc \w1 = y\ by blast + unfolding rassoc \w1 = y\ by blast qed -qed - -lemmas bm_simps_rev = bm_simps[reversed] +qed simp + +lemmas [bm_simps] = lcp_ext_left + +named_theorems bm_simps_rev +lemmas [bm_simps_rev] = bm_simps[reversed] \ \Binary hull membership evaluation\ -named_theorems bin_hull_in +named_theorems bin_hull_in lemma[bin_hull_in]: "x \ \{x,y}\" by blast lemma[bin_hull_in]: "y \ \{x,y}\" by blast lemma[bin_hull_in]: "w \ \{x,y}\ \ w \ \{y,x}\" - by (simp add: insert_commute) + by (simp add: insert_commute) lemmas[bin_hull_in] = hull_closed power_in rassoc -lemmas bin_hull_in_rev = bin_hull_in[reversed] +named_theorems bin_hull_in_rev +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)) + ((simp only: shifts bm_simps)?, + (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 - \(mismatch0; fail)| mismatch_rev\) + ((simp only: shifts_rev bm_simps_rev)?, + (elim bm_elims_rev)?; + (simp_all only: bm_simps_rev bin_hull_in_rev)) + +method mismatch = + (insert method_facts, use nothing in + \(mismatch0;fail)|(mismatch_rev)\ + ) + + +thm bm_elims subsubsection "Mismatch method demonstrations" lemma "y \ x \p x\<^sup>@k \ x \ y \ w \ x \ y = y \ x" by mismatch -(* test hull *) lemma "w1 \ \{x,y}\ \ w2 \ \{x,y}\ \ x \ w2 \ y \ z = y \ w1 \ x \ v \ x \ y = y \ x" - by mismatch - -thm bm_elims[elim_format] - -(* test simple eq *) + by mismatch + lemma "w1 \ \{x,y}\ \ y \ x \ w2 \ z = x \ w1 \ x \ y = y \ x" - (* apply (elim bm_elims) *) - by mismatch - -(* test hull' *) + by mismatch + lemma "w1 \ \{x,y}\ \ w2 \ \{x,y}\ \ x \ y \ w2 \ x \s x \ w1 \ y \ x \ y = y \ x" by mismatch -(* test eq *) lemma assumes "x \ y \ z = y \ y \ x \ v" shows "x \ y = y \ x" using assms by mismatch -(* test eq_cancel *) lemma assumes "y \ x \ x \ y \ z = y \ x \ y \ y \ x \ v" shows "x \ y = y \ x" using assms by mismatch -(* test eq_swap *) lemma "y \ y \ x \ v = x \ x \ y \ z \ x \ y = y \ x" by mismatch -(* test eq' *) lemma "x \ x \ y \ z = y \ y \ x \ z' \ x \ y = y \ x" by mismatch -(* test eq_suf *) lemma "z \ x \ y \ x \ x = v \ x \ y \ y \ y \ x = x \ y" by mismatch -(* test pref *) lemma "x \ y \p y \ y \ x \ x \ y = y \ x" by mismatch -(* test pref_cancel *) lemma "y \ x \ x \ x \ y \p y \ x \ x \ y \ y \ x \ x \ y = y \ x" by mismatch -(* test pref_swap *) lemma "x \ y \p y \ y \ x \ z \ y \ x = x \ y" by mismatch -(* test suf *) lemma "x \ x \ y \ y \ y \s z\ y \ y \ x \ x \ x \ y = y \ x" by mismatch lemma assumes "x \ x \ y \ y \ y \ y \s z\ y \ y \ x \ x" shows "x \ y = y \ x" - using assms by mismatch - -(* test power *) + using assms by mismatch + lemma "k \ 0 \ j \ 0 \ (x \<^sup>@ j \ y \<^sup>@ ka) \ y = y\<^sup>@k \ x \<^sup>@ j \ y \<^sup>@ (k - 1) \ x \ y = y \ x" by mismatch lemma "dif \ 0 \ j \ 0 \ (x \<^sup>@ j \ y \<^sup>@ ka) \ y \<^sup>@ dif = y \<^sup>@ dif \ x \<^sup>@ j \ y \<^sup>@ ka \ x \ y = y \ x" by mismatch +lemma assumes "x \ y \ y \ x" + shows "x \ x \ y \\<^sub>p y \ y \ x = (x \ y \\<^sub>p y \ x)" + using assms by mismatch + +lemma assumes "x \ y \ y \ x" + shows "w \ z \ x \ x \ y \\<^sub>p w \ z \ y \ y \ x = (w \ z) \ (x \ y \\<^sub>p y \ x)" + using assms by mismatch + subsection \Applied mismatch\ -lemma pows_eq_comm: "u\<^sup>@Suc k \ v\<^sup>@Suc m = u\<^sup>@Suc l \ v\<^sup>@Suc n \ k \ l \ u \ v = v \ u" - by (induct k l rule: diff_induct, mismatch+) +lemma pows_comm_comm: assumes "u\<^sup>@k \ v\<^sup>@m = u\<^sup>@l \ v\<^sup>@n" "k \ l" shows "u \ v = v \ u" +proof- + have aux: "u\<^sup>@k \ v\<^sup>@m \ v \ u = u\<^sup>@l \ v\<^sup>@n \ v \ u \ k \ l \ u \ v = v \ u" + by (induct k l rule: diff_induct) mismatch+ + from this[unfolded lassoc cancel_right, OF assms] + show "u \ v = v \ u". +qed section \Two words hull (not necessarily a code)\ lemma bin_lists_len_count: assumes "x \ y" and "ws \ 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 \ {x,y}" using \ws \ lists{x,y}\ by blast show ?thesis using sum_count_set[OF \set ws \ {x,y}\ \finite {x,y}\] \x \ y\ by simp qed lemma two_elem_first_block: assumes "w \ \{u,v}\" - obtains m where "u\<^sup>@m \ v \ w" + obtains m where "u\<^sup>@m \ v \ w" using assms proof- obtain ws where "concat ws = w" and "ws \ lists {u,v}" using concat_dec[OF \w \ \{u,v}\\] dec_in_lists[OF \w \ \{u,v}\\] by simp consider (only_u) "takeWhile (\ x. x = u) ws = ws" | (some_v) "takeWhile (\ x. x = u) ws \ ws \ hd (dropWhile (\ x. x = u) ws) \ u" using hd_dropWhile[of "(\ 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 \concat ws = w\ 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] + note some_v = conjunct1[OF this] conjunct2[OF this] hence "dropWhile (\ x. x = u) ws \ \" by force from lists_hd_in_set[OF this] have "hd (dropWhile (\x. x = u) ws) \ {u,v}" - using \ws \ lists {u,v}\ append_in_lists_conv takeWhile_dropWhile_id by metis + using \ws \ lists {u,v}\ append_in_lists_conv takeWhile_dropWhile_id by metis hence "hd (dropWhile (\x. x = u) ws) = v" using some_v(2) by simp from dropWhile_distinct[of ws u, unfolded this] some_v(1) have "(takeWhile (\x. x = u) ws)\[v] \p ws" unfolding takeWhile_letter_pref_exp by simp - from pref_concat_pref[OF this, unfolded concat_morph, unfolded \concat ws = w\ concat_takeWhile_sing[unfolded this]] - have "u\<^sup>@\<^bold>|takeWhile (\x. x = u) ws\<^bold>|\ v \p w" + from pref_concat_pref[OF this, unfolded concat_morph, unfolded \concat ws = w\ concat_takeWhile_sing[unfolded this]] + have "u\<^sup>@\<^bold>|takeWhile (\x. x = u) ws\<^bold>|\ v \p w" by simp with that - show thesis + show thesis by blast qed qed lemmas two_elem_last_block = two_elem_first_block[reversed] lemma two_elem_pref: assumes "v \p u \ p" and "p \ \{u,v}\" shows "v \p u \ v" proof- obtain m where "u\<^sup>@m \ v \ p" - using two_elem_first_block[OF \p \ \{u,v}\\]. + using two_elem_first_block[OF \p \ \{u,v}\\]. have "v \p u\<^sup>@(Suc m) \ v" using pref_prolong_comp[OF \v \p u \ p\ \u\<^sup>@m \ v \ p\, unfolded lassoc, folded pow_Suc]. thus "v \p u \ v" using per_drop_exp' by blast qed lemmas two_elem_suf = two_elem_pref[reversed] -lemma gen_drop_exp: assumes "p \ \{u,v\<^sup>@(Suc k)}\" shows "p \ \{u,v}\" +lemma gen_drop_exp: assumes "p \ \{u,v\<^sup>@(Suc k)}\" shows "p \ \{u,v}\" by (rule hull.induct[OF assms], simp, blast) -lemma gen_prim: "v \ \ \ p \ \{u,v}\ \ p \ \{u,\ v}\" - using gen_drop_exp primroot_expE by metis - -lemma roots_hull: assumes "w \ \{u\<^sup>@k,v\<^sup>@m}\" shows "w \ \{u,v}\" +lemma gen_drop_exp_pos: assumes "p \ \{u,v\<^sup>@k}\" "0 < k" shows "p \ \{u,v}\" + using gen_drop_exp[of _ _ _ "k-1", unfolded Suc_minus_pos[OF \0 < k\], OF \p \ \{u,v\<^sup>@k}\\]. + +lemma gen_prim: "p \ \{u,v}\ \ p \ \{u,\ v}\" + using gen_drop_exp_pos primroot_expE by metis + +lemma roots_hull: assumes "w \ \{u\<^sup>@k,v\<^sup>@m}\" shows "w \ \{u,v}\" proof- have "u\<^sup>@k \ \{u,v}\" and "v\<^sup>@m \ \{u,v}\" - by (simp_all add: gen_in power_in) + by (simp_all add: gen_in power_in) hence "{u\<^sup>@k,v\<^sup>@m} \ \{u,v}\" by blast - from hull_mono'[OF this] + from hull_mono'[OF this] show "w \ \{u,v}\" - using \w \ \{u\<^sup>@k,v\<^sup>@m}\\ by blast + using \w \ \{u\<^sup>@k,v\<^sup>@m}\\ by blast qed lemma roots_hull_sub: "\{u\<^sup>@k,v\<^sup>@m}\ \ \{u,v}\" - using roots_hull by blast - -lemma primroot_gen[intro]: "v \ \{u, \ v}\" + using roots_hull by blast + +lemma primroot_gen[intro]: "v \ \{u, \ v}\" using power_in[of "\ v" "{u,\ v}"] - by (cases "v = \", simp) (metis primroot_expE gen_in insert_iff) - -lemma primroot_gen'[intro]: "u \ \{\ u, v}\" + by (cases "v = \", simp) (metis primroot_expE gen_in insert_iff) + +lemma primroot_gen'[intro]: "u \ \{\ u, v}\" using primroot_gen insert_commute by metis lemma set_lists_primroot: "set ws \ {x,y} \ ws \ lists \{\ x, \ y}\" by blast section \Free hull\ -text\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$. +text\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}. \ inductive_set free_hull :: "'a list set \ 'a list set" ("\_\\<^sub>F") for G where "\ \ \G\\<^sub>F" | free_gen_in: "w \ G \ w \ \G\\<^sub>F" | "w1 \ \G\\<^sub>F \ w2 \ \G\\<^sub>F \ w1 \ w2 \ \G\\<^sub>F" | "p \ \G\\<^sub>F \ q \ \G\\<^sub>F \ p \ w \ \G\\<^sub>F \ w \ q \ \G\\<^sub>F \ w \ \G\\<^sub>F" \ \the stability condition\ lemmas [intro] = free_hull.intros text\The defined set indeed is a hull.\ lemma free_hull_hull[simp]: "\\G\\<^sub>F\ = \G\\<^sub>F" - by (intro antisym subsetI) (rule hull.induct, blast+) + by (intro antisym subsetI, rule hull.induct) blast+ text\The free hull is always (non-strictly) larger than the hull.\ lemma hull_sub_free_hull: "\G\ \ \G\\<^sub>F" proof fix x assume "x \ \G\" - then show "x \ \G\\<^sub>F" - using free_hull.intros(3) + then show "x \ \G\\<^sub>F" + using free_hull.intros(3) hull_induct[of x G "\ x. x \ \G\\<^sub>F", OF \x \ \G\\ free_hull.intros(1)[of G] free_hull.intros(2)] by auto qed text\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.\ definition free_basis :: "'a list set \ 'a list set" ("\\<^sub>F _" [54] 55) where "free_basis G \ \ \G\\<^sub>F" lemma basis_gen_hull_free: "\\\<^sub>F G\ = \G\\<^sub>F" unfolding free_basis_def using basis_gen_hull free_hull_hull by blast lemma genset_sub_free: "G \ \G\\<^sub>F" by (simp add: free_hull.free_gen_in subsetI) text -\We have developed two points of view on freeness: + \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.\ - + text\We now show their equivalence\ text\First, basis of a free hull is a code.\ lemma free_basis_code[simp]: "code (\\<^sub>F G)" proof - fix xs ys + fix xs ys show "xs \ lists (\\<^sub>F G) \ ys \ lists (\\<^sub>F G) \ concat xs = concat ys \ xs = ys" - proof(induction xs ys rule: list_induct2', simp) + proof(induction xs ys rule: list_induct2') case (2 x xs) - show ?case - using listsE[OF \x # xs \ lists (\\<^sub>F G)\, of "x \ \\<^sub>F G", unfolded free_basis_def, THEN emp_not_basis] - concat.simps(2)[of x xs, unfolded \concat (x # xs) = concat \\[unfolded concat.simps(1)], symmetric, unfolded append_is_Nil_conv[of x "concat xs"]] + show ?case + using listsE[OF \x # xs \ lists (\\<^sub>F G)\, of "x \ \\<^sub>F G", unfolded free_basis_def, THEN emp_not_basis] + concat.simps(2)[of x xs, unfolded \concat (x # xs) = concat \\[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 \y # ys \ lists (\\<^sub>F G)\, of "y \ \\<^sub>F G", unfolded free_basis_def, THEN emp_not_basis] - concat.simps(2)[of y ys, unfolded \concat \ = concat (y # ys)\[unfolded concat.simps(1),symmetric],symmetric, unfolded append_is_Nil_conv[of y "concat ys"]] - by blast + show ?case + using listsE[OF \y # ys \ lists (\\<^sub>F G)\, of "y \ \\<^sub>F G", unfolded free_basis_def, THEN emp_not_basis] + concat.simps(2)[of y ys, unfolded \concat \ = concat (y # ys)\[unfolded concat.simps(1),symmetric],symmetric, unfolded append_is_Nil_conv[of y "concat ys"]] + by blast next case (4 x xs y ys) have "\<^bold>|x\<^bold>| = \<^bold>|y\<^bold>|" proof(rule ccontr) assume "\<^bold>|x\<^bold>| \ \<^bold>|y\<^bold>|" - have "x \ concat xs = y \ concat ys" + have "x \ concat xs = y \ concat ys" using \concat (x # xs) = concat (y # ys)\ by simp then obtain t where or: "x = y \ t \ t \ concat xs = concat ys \ x \ t = y \ concat xs = t \ concat ys" using append_eq_append_conv2[of x "concat xs" y "concat ys"] by blast hence "t \ \" using \\<^bold>|x\<^bold>| \ \<^bold>|y\<^bold>|\ by auto have "x \ \\<^sub>F G" and "y \ \\<^sub>F G" using listsE[OF \x # xs \ lists (\\<^sub>F G)\, of "x \ \\<^sub>F G" ] listsE[OF \y # ys \ lists (\\<^sub>F G)\, of "y \ \\<^sub>F G" ] by blast+ hence "x \ \" and "y \ \" unfolding free_basis_def using emp_not_basis by blast+ have "x \ \G\\<^sub>F" and "y \ \G\\<^sub>F" - using basis_sub[of "\G\\<^sub>F", unfolded free_basis_def[symmetric] ] \x # xs \ lists (\\<^sub>F G)\ + using basis_sub[of "\G\\<^sub>F", unfolded free_basis_def[symmetric] ] \x # xs \ lists (\\<^sub>F G)\ \y # ys \ lists (\\<^sub>F G)\ by auto have "concat xs \ \G\\<^sub>F" and "concat ys \ \G\\<^sub>F" - using concat_tl_basis[OF \x # xs \ lists (\\<^sub>F G)\[unfolded free_basis_def]] - concat_tl_basis[OF \y # ys \ lists (\\<^sub>F G)\[unfolded free_basis_def]] unfolding free_hull_hull. - have "t \ \G\\<^sub>F" + using concat_tl_basis[OF \x # xs \ lists (\\<^sub>F G)\[unfolded free_basis_def]] + concat_tl_basis[OF \y # ys \ lists (\\<^sub>F G)\[unfolded free_basis_def]] unfolding free_hull_hull. + have "t \ \G\\<^sub>F" using or free_hull.intros(4) \x \ \G\\<^sub>F\ \y \ \G\\<^sub>F\ \concat xs \ \G\\<^sub>F\ \concat ys \ \G\\<^sub>F\ by metis thus False - using or basis_dec[of x "\G\\<^sub>F" t, unfolded free_hull_hull, OF \x \ \G\\<^sub>F\ \t \ \G\\<^sub>F\] - basis_dec[of y "\G\\<^sub>F" t, unfolded free_hull_hull, OF \y \ \G\\<^sub>F\ \t \ \G\\<^sub>F\] + using or basis_dec[of x "\G\\<^sub>F" t, unfolded free_hull_hull, OF \x \ \G\\<^sub>F\ \t \ \G\\<^sub>F\] + basis_dec[of y "\G\\<^sub>F" t, unfolded free_hull_hull, OF \y \ \G\\<^sub>F\ \t \ \G\\<^sub>F\] using \t \ \\ \x \ \\ \y \ \\ \x \ \\<^sub>F G\ \y \ \\<^sub>F G\ unfolding free_basis_def by auto qed thus "x # xs = y # ys" using "4.IH" \x # xs \ lists (\\<^sub>F G)\ \y # ys \ lists (\\<^sub>F G)\ \concat (x # xs) = concat (y # ys)\ by auto next - qed + qed simp qed lemma gen_in_free_hull: "x \ G \ x \ \\\<^sub>F G\" using free_hull.free_gen_in[folded basis_gen_hull_free]. text\Second, a code generates its free hull.\ lemma (in code) code_gen_free_hull: "\\\\<^sub>F = \\\" proof show "\\\ \ \\\\<^sub>F" - using hull_mono[of \ "\\\\<^sub>F"] - free_gen_in[of _ \] subsetI[of \ "\\\\<^sub>F"] + using hull_mono[of \ "\\\\<^sub>F"] + free_gen_in[of _ \] subsetI[of \ "\\\\<^sub>F"] unfolding free_hull_hull by auto show "\\\\<^sub>F \ \\\" proof - fix x assume "x \ \\\\<^sub>F" + fix x assume "x \ \\\\<^sub>F" have "\ \ \\\" by simp show "x \ \\\" - proof(rule free_hull.induct[of x \],simp add: \x \ \\\\<^sub>F\, (simp add: hull_closed)+, - simp add: gen_in, simp add: hull_closed) + proof(rule free_hull.induct[of x \]) fix p q w assume "p \ \\\" "q \ \\\" "p \ w \ \\\" "w \ q \ \\\" - have eq: "(Dec \ p) \ (Dec \ w \ q) = (Dec \ p \ w) \ (Dec \ q)" - using code_dec_morph[OF \p \ \\\\ \w \ q \ \\\\, unfolded lassoc] - unfolding code_dec_morph[OF \p \ w \ \\\\ \q \ \\\\, symmetric]. + have eq: "(Dec \ p) \ (Dec \ w \ q) = (Dec \ p \ w) \ (Dec \ q)" + using code_dec_morph[OF \p \ \\\\ \w \ q \ \\\\, unfolded lassoc] + unfolding code_dec_morph[OF \p \ w \ \\\\ \q \ \\\\, symmetric]. have "Dec \ p \ Dec \ p \ w" - using eqd_comp[OF eq]. - hence "Dec \ p \p Dec \ p \ w" + using eqd_comp[OF eq]. + hence "Dec \ p \p Dec \ p \ w" using \p \ w \ \\\\ \p \ \\\\ concat_morph concat_dec prefD pref_antisym triv_pref unfolding prefix_comparable_def by metis then obtain ts where "(Dec \ p) \ ts = Dec \ p \ w" using lq_pref by blast hence "ts \ lists \" using \p \ w \ \\\\ by inlists hence "concat ts = w" - using concat_morph[of "Dec \ p" ts] + using concat_morph[of "Dec \ p" ts] unfolding \(Dec \ p) \ ts = Dec \ p \ w\ concat_dec[OF \p \ w \ \\\\] concat_dec[OF \p \ \\\\] by auto thus "w \ \\\" using \ts \ lists \\ by auto - qed + qed (simp_all add: \x \ \\\\<^sub>F\ hull_closed gen_in) qed qed text\That is, a code is its own free basis\ lemma (in code) code_free_basis: "\ = \\<^sub>F \" - using basis_of_hull[of \, unfolded code_gen_free_hull[symmetric] + using basis_of_hull[of \, unfolded code_gen_free_hull[symmetric] code_is_basis, symmetric] unfolding free_basis_def. text\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\ lemma (in code) stability: "p \ \\\ \ q \ \\\ \ p \ w \ \\\ \ w \ q \ \\\ \ w \ \\\" - unfolding code_gen_free_hull[symmetric] using free_hull.intros(4) by auto - -text\Moreover, the free hull of G is the smallest code-generated hull containing G. + unfolding code_gen_free_hull[symmetric] using free_hull.intros(4) by auto + +text\Moreover, the free hull of G is the smallest code-generated hull containing G. In other words, the term free hull is appropriate.\ text\First, several intuitive monotonicity and closure results.\ lemma free_hull_mono: "G \ H \ \G\\<^sub>F \ \H\\<^sub>F" proof assume "G \ H" fix x assume "x \ \G\\<^sub>F" have el: "\ w. w \ G \ w \ \H\\<^sub>F" using \G \ H\ free_hull.free_gen_in by auto show "x \ \H\\<^sub>F" - proof (rule free_hull.induct[of x G], simp add: \x \ \G\\<^sub>F\, simp add: free_hull.intros(1), - simp add: el, simp add: free_hull.intros(3)) - show "\p q w. p \ \H\\<^sub>F \ q \ \H\\<^sub>F \ p \ w \ \H\\<^sub>F \ w \ q \ \H\\<^sub>F \ w \ \H\\<^sub>F" - using free_hull.intros(4) by auto - qed + by (rule free_hull.induct[of x G]) (auto simp add: \x \ \G\\<^sub>F\ el) qed lemma free_hull_idem: "\\G\\<^sub>F\\<^sub>F = \G\\<^sub>F" proof - show "\\G\\<^sub>F\\<^sub>F \ \G\\<^sub>F" - proof + show "\\G\\<^sub>F\\<^sub>F \ \G\\<^sub>F" + proof fix x assume "x \ \\G\\<^sub>F\\<^sub>F" show "x \ \G\\<^sub>F" - proof (rule free_hull.induct[of x "\G\\<^sub>F"], simp add: \x \ \\G\\<^sub>F\\<^sub>F\, - simp add: free_hull.intros(1), simp add: free_hull.intros(2), simp add: free_hull.intros(3)) + proof (rule free_hull.induct[of x "\G\\<^sub>F"]) show "\p q w. p \ \G\\<^sub>F \ q \ \G\\<^sub>F \ p \ w \ \G\\<^sub>F \ w \ q \ \G\\<^sub>F \ w \ \G\\<^sub>F" - using free_hull.intros(4) by auto - qed + using free_hull.intros(4) by auto + qed (simp_all add: \x \ \\G\\<^sub>F\\<^sub>F\ free_hull.intros(1), simp add: free_hull.intros(2), simp add: free_hull.intros(3)) qed next show "\G\\<^sub>F \ \\G\\<^sub>F\\<^sub>F" - using free_hull_hull hull_sub_free_hull by auto + using free_hull_hull hull_sub_free_hull by auto qed lemma hull_gen_free_hull: "\\G\\\<^sub>F = \G\\<^sub>F" proof show " \\G\\\<^sub>F \ \G\\<^sub>F" using free_hull_idem free_hull_mono hull_sub_free_hull by metis next show "\G\\<^sub>F \ \\G\\\<^sub>F" - by (simp add: free_hull_mono) + by (simp add: free_hull_mono) qed text \Code is also the free basis of its hull.\ lemma (in code) code_free_basis_hull: "\ = \\<^sub>F \\\" unfolding free_basis_def using code_free_basis[unfolded free_basis_def] - unfolding hull_gen_free_hull. + unfolding hull_gen_free_hull. text\The minimality of the free hull easily follows.\ theorem (in code) free_hull_min: assumes "G \ \\\" shows "\G\\<^sub>F \ \\\" - using free_hull_mono[OF \G \ \\\\] unfolding hull_gen_free_hull - unfolding code_gen_free_hull. + using free_hull_mono[OF \G \ \\\\] unfolding hull_gen_free_hull + unfolding code_gen_free_hull. theorem free_hull_inter: "\G\\<^sub>F = \ {M. G \ M \ M = \M\\<^sub>F}" proof have "X \ {M. G \ M \ M = \M\\<^sub>F} \ \G\\<^sub>F \ X" for X unfolding mem_Collect_eq[of _ "\ M. G \ M \ M = \M\\<^sub>F"] - using free_hull_mono[of G X] by simp - from Inter_greatest[of "{M. G \ M \ M = \M\\<^sub>F}", OF this] - show "\G\\<^sub>F \ \ {M. G \ M \ M = \M\\<^sub>F}" + using free_hull_mono[of G X] by simp + from Inter_greatest[of "{M. G \ M \ M = \M\\<^sub>F}", OF this] + show "\G\\<^sub>F \ \ {M. G \ M \ M = \M\\<^sub>F}" by blast next show " \ {M. G \ M \ M = \M\\<^sub>F} \ \G\\<^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\Decomposition into the free basis is a morphism.\ -lemma free_basis_dec_morph: "u \ \G\\<^sub>F \ v \ \G\\<^sub>F \ +lemma free_basis_dec_morph: "u \ \G\\<^sub>F \ v \ \G\\<^sub>F \ Dec (\\<^sub>F G) (u \ v) = (Dec (\\<^sub>F G) u) \ (Dec (\\<^sub>F G) v)" - using code.code_dec_morph[OF free_basis_code, of u G v, symmetric, - unfolded basis_gen_hull_free[of G]]. + using code.code_dec_morph[OF free_basis_code, of u G v, symmetric, + unfolded basis_gen_hull_free[of G]]. section \Reversing hulls and decompositions\ lemma basis_rev_commute[reversal_rule]: "\ (rev ` G) = rev ` (\ G)" proof have "\rev ` \ G\ = \rev ` G\" and *: "\rev ` \ (rev ` G)\ = \rev ` rev `G\" unfolding rev_hull[symmetric] basis_gen_hull by blast+ - from basis_sub_gen[OF this(1)] + from basis_sub_gen[OF this(1)] show "\ (rev ` G) \ rev ` \ G". from image_mono[OF basis_sub_gen[OF *], of rev] show "rev ` (\ G) \ \ (rev ` G)" - unfolding rev_rev_image_eq. + unfolding rev_rev_image_eq. qed lemma rev_free_hull_comm: "\rev ` X\\<^sub>F = rev ` \X\\<^sub>F" proof- have "rev ` \X\\<^sub>F \ \rev ` X\\<^sub>F" for X :: "'a list set" proof fix x assume "x \ rev ` \X\\<^sub>F" hence "rev x \ \X\\<^sub>F" - by (simp add: rev_in_conv) - have "rev x \ rev ` \rev ` X\\<^sub>F" - by (induct rule: free_hull.induct[OF \rev x \ \X\\<^sub>F\], blast, unfold rev_in_conv[symmetric] rev_append, auto+) + by (simp add: rev_in_conv) + have "rev x \ rev ` \rev ` X\\<^sub>F" + by (induct rule: free_hull.induct[OF \rev x \ \X\\<^sub>F\]) + (auto simp add: rev_in_conv[symmetric]) then show "x \ \rev ` X\\<^sub>F" - by blast + 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 "\rev ` X\\<^sub>F = rev ` \X\\<^sub>F" + show "\rev ` X\\<^sub>F = rev ` \X\\<^sub>F" by blast qed lemma free_basis_rev_commute [reversal_rule]: "\\<^sub>F rev ` X = rev ` (\\<^sub>F X)" unfolding free_basis_def basis_rev_commute free_basis_def rev_free_hull_comm.. lemma rev_dec[reversal_rule]: assumes "x \ \X\\<^sub>F" shows "Dec rev ` (\\<^sub>F X) (rev x) = map rev (rev (Dec (\\<^sub>F X) x))" proof- have "x \ \\\<^sub>F X\" using \x \ \X\\<^sub>F\ by (simp add: basis_gen_hull_free) from concat_dec[OF this] have "concat (map rev (rev (Dec \\<^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 \x \ \\\<^sub>F X\\]], of _ "map rev"] have "map rev (rev (Dec \\<^sub>F X x)) \ lists (rev ` (\\<^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 \concat (map rev (rev (Dec \\<^sub>F X x))) = rev x\. qed lemma rev_hd_dec_last_eq[reversal_rule]: assumes "x \ X" and "x \ \" shows - "rev (hd (Dec (rev ` (\\<^sub>F X)) (rev x))) = last (Dec \\<^sub>F X x)" + "rev (hd (Dec (rev ` (\\<^sub>F X)) (rev x))) = last (Dec \\<^sub>F X x)" proof- have "rev (Dec \\<^sub>F X x) \ \" using \x \ X\ basis_gen_hull_free dec_nemp'[OF \x \ \\] by blast show ?thesis unfolding hd_rev rev_dec[OF free_gen_in[OF \x \ X\]] hd_map[OF \rev (Dec \\<^sub>F X x) \ \\] - by simp + by simp qed -lemma rev_hd_dec_last_eq'[reversal_rule]: assumes "x \ X" and "x \ \" shows +lemma rev_hd_dec_last_eq'[reversal_rule]: assumes "x \ X" and "x \ \" shows "(hd (Dec (rev ` (\\<^sub>F X)) (rev x))) = rev (last (Dec \\<^sub>F X x))" - using assms(1) assms(2) rev_hd_dec_last_eq rev_swap by blast + using assms(1) assms(2) rev_hd_dec_last_eq rev_swap by blast section \Lists as the free hull of singletons\ -text\A crucial property of free monoids of words is that they can be seen as lists over the free basis, +text\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.\ abbreviation sings where "sings B \ {[b] | b. b \ B}" -lemma sings_image: "sings B = (\ x. [x]) ` B" +term "Set.filter P A" + +lemma sings_image: "sings B = (\ x. [x]) ` B" using Setcompr_eq_image. -lemma lists_sing_map_concat_ident: "xs \ lists (sings B) \ xs = map (\ x. [x]) (concat xs)" +lemma lists_sing_map_concat_ident: "xs \ lists (sings B) \ xs = map (\ x. [x]) (concat xs)" by (induct xs, simp, auto) lemma code_sings: "code (sings B)" proof - fix xs ys assume xs: "xs \ lists (sings B)" and ys: "ys \ lists (sings B)" - and eq: "concat xs = concat ys" + fix xs ys assume xs: "xs \ lists (sings B)" and ys: "ys \ 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: "\sings B\ = lists B" unfolding hull_concat_lists proof(intro equalityI subsetI, standard) fix xs show "xs \ concat ` lists (sings B) \ \x\set xs. x \ B" - by force + by force assume "xs \ lists B" hence "map (\x. x # \) xs \ lists (sings B)" by force - from imageI[OF this, of concat] + from imageI[OF this, of concat] show "xs \ concat ` lists (sings B)" - unfolding concat_map_sing_ident[of xs]. -qed - -lemma sing_gen_lists: "lists {x} = \{[x]}\" + unfolding concat_map_sing_ident[of xs]. +qed + +lemma sing_gen_lists: "lists {x} = \{[x]}\" using sings_gen_lists[of "{x}"] by simp -lemma bin_gen_lists: "lists {x, y} = \{[x],[y]}\" +lemma bin_gen_lists: "lists {x, y} = \{[x],[y]}\" using sings_gen_lists[of "{x,y}"] unfolding Setcompr_eq_image by simp lemma "sings B = \\<^sub>F (lists B)" using code.code_free_basis_hull[OF code_sings, of B, unfolded sings_gen_lists]. lemma map_sings: "xs \ lists B \ map (\x. x # \) xs \ lists (sings B)" by (induct xs) auto lemma dec_sings: "xs \ lists B \ Dec (sings B) xs = map (\ x. [x]) xs" using code.code_unique_dec'[OF code_sings, of "map (\ x. [x]) xs" B, OF map_sings] unfolding concat_map_sing_ident. lemma sing_lists_exp: assumes "ws \ lists {x}" obtains k where "ws = [x]\<^sup>@k" - using unique_letter_wordE''[OF assms[folded in_lists_conv_set_subset]]. + using unique_letter_wordE''[OF assms[folded in_lists_conv_set_subset]]. lemma sing_lists_exp_len: "ws \ lists {x} \ [x]\<^sup>@\<^bold>|ws\<^bold>| = ws" by (induct ws, auto) lemma sing_lists_exp_count: "ws \ lists {x} \ [x]\<^sup>@(count_list ws x) = ws" by (induct ws, auto) lemma sing_set_pow_count_list: "set ws \ {a} \ [a]\<^sup>@(count_list ws a) = ws" unfolding in_lists_conv_set_subset using sing_lists_exp_count. lemma sing_set_pow: "set ws \ {a} \ [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 \ b \ count_list ([a]\<^sup>@k) b = 0" - by (induct k, simp, auto simp add: count_list_append) + by auto + +lemma count_sing_exp[simp]: "count_list ([a]\<^sup>@k) a = k" + by (induct k, simp_all) + +lemma count_sing_exp'[simp]: "count_list ([a]) a = 1" + by simp + +lemma count_sing_distinct[simp]: "a \ b \ count_list ([a]\<^sup>@k) b = 0" + by (induct k, simp, auto) + +lemma count_sing_distinct'[simp]: "a \ b \ count_list ([a]) b = 0" + by simp + +lemma sing_letter_imp_prim: assumes "count_list w a = 1" shows "primitive w" +proof + fix r k + assume "r \<^sup>@ k = w" + have "count_list w a = k * count_list r a" + by (simp only: count_list_pow flip: \r \<^sup>@ k = w\) + then show "k = 1" + unfolding \count_list w a = 1\ by simp +qed + +lemma prim_abk: "a \ b \ primitive ([a] \ [b] \<^sup>@ k)" + by (intro sing_letter_imp_prim[of _ a]) simp lemma sing_code: "x \ \ \ code {x}" proof (rule code.intro) fix xs ys assume "x \ \" "xs \ lists {x}" "ys \ lists {x}" "concat xs = concat ys" show "xs = ys" using \concat xs = concat ys\ [unfolded concat_sing_list_pow'[OF \xs \ lists {x}\] concat_sing_list_pow'[OF \ys \ lists {x}\] - eq_pow_exp[OF \x \ \\]] + eq_pow_exp[OF \x \ \\]] sing_lists_exp_len[OF \xs \ lists {x}\] sing_lists_exp_len[OF \ys \ lists {x}\] by argo qed +lemma sings_card: "card A = card (sings A)" + by(rule bij_betw_same_card, rule bij_betwI'[of _ "\x. [x]"], auto) + +lemma sings_finite: "finite A = finite (sings A)" + by(rule bij_betw_finite, rule bij_betwI'[of _ "\x. [x]"], auto) + +lemma sings_conv: "A = B \ sings A = sings B" +proof(standard, simp) + have "\x A B. sings A = sings B \ x \ A \ x \ B" + proof- + fix x :: "'b" and A B + assume "sings A = sings B" "x \ A" + hence "[x] \ sings B" + using \sings A = sings B\ by blast + thus "x \ B" + by blast + qed + from this[of A B] this[of B A, OF sym] + show "sings A = sings B \ A = B" + by blast +qed + section \Various additional lemmas\ subsection \Roots of binary set\ -(* TODO Generalized?*) lemma two_roots_code: assumes "x \ \" and "y \ \" shows "code {\ x, \ y}" using assms proof (cases "\ x = \ y") assume "\ x = \ y" thus "code {\ x, \ y}" using sing_code[OF primroot_nemp[OF \x \ \\]] by simp next assume "\ x \ \ y" - hence "\ x \ \ y \ \ y \ \ x" + hence "\ x \ \ y \ \ y \ \ x" using comm_prim[OF primroot_prim[OF \x \ \\] primroot_prim[OF \y \ \\]] by blast thus "code {\ x, \ y}" by (simp add: bin_code_code) qed lemma primroot_in_set_dec: assumes "x \ \" and "y \ \" shows "\ x \ set (Dec {\ x, \ y} x)" proof- - obtain k where "concat ([\ x]\<^sup>@Suc k) = x" - using primroot_expE[OF \x \ \\] + obtain k where "concat ([\ x]\<^sup>@k) = x" "0 < k" + using primroot_expE concat_sing_pow[symmetric, of "\ x"] by metis - from code.code_unique_dec'[OF two_roots_code[OF assms], of "[\ x]\<^sup>@Suc k", unfolded \concat ([\ x]\<^sup>@Suc k) = x\] - have "Dec {\ x, \ y} x = [\ x]\<^sup>@Suc k" + from code.code_unique_dec'[OF two_roots_code[OF assms], of "[\ x]\<^sup>@k", unfolded \concat ([\ x]\<^sup>@k) = x\] + have "Dec {\ x, \ y} x = [\ x]\<^sup>@k" using insertI1 sing_pow_lists by metis show ?thesis - unfolding \Dec {\ x, \ y} x = [\ x]\<^sup>@Suc k\ by simp -qed - -lemma primroot_dec: assumes "x \ y \ y \ x" - obtains k where "(Dec {\ x, \ y} x) = [\ x]\<^sup>@Suc k" -proof- - have "x \ \" and "y \ \" using \x \ y \ y \ x\ by blast+ - note rcode = \x \ y \ y \ x\[unfolded comp_primroot_conv'[OF this]] - interpret binary_code "\ x" "\ y" - using rcode by unfold_locales - have "x \ \{\ x, \ y}\" - by blast - obtain k where "concat ([\ x]\<^sup>@Suc k) = x" - using primroot_expE[OF \x \ \\] - concat_sing_pow[symmetric, of "\ x"] by metis - from code_unique_dec[OF _ this] - show thesis - by (simp add: sing_pow_lists that) + unfolding \Dec {\ x, \ y} x = [\ x]\<^sup>@k\ using \0 < k\ by simp qed -lemma primroot_dec': assumes "x \ y \ y \ x" - obtains k where "(Dec {\ x, \ y} y) = [\ y]\<^sup>@Suc k" - using primroot_dec[OF assms[symmetric], unfolded insert_commute]. - -lemma (in binary_code) bin_roots_sings_code: "sings_code {Dec {\ u\<^sub>0, \ u\<^sub>1} u\<^sub>0, Dec {\ u\<^sub>0, \ u\<^sub>1} u\<^sub>1}" -proof - interpret rcode: binary_code "\ u\<^sub>0" "\ 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 {\ u\<^sub>0,\ u\<^sub>1} u\<^sub>0) = [\ u\<^sub>0]\<^sup>@Suc k\<^sub>0" - using primroot_dec[OF non_comm]. - obtain k\<^sub>1 where dec1: "(Dec {\ u\<^sub>0,\ u\<^sub>1} u\<^sub>1) = [\ u\<^sub>1]\<^sup>@Suc k\<^sub>1" - using primroot_dec'[OF non_comm]. - show "c \ {Dec {\ u\<^sub>0, \ u\<^sub>1} u\<^sub>0, Dec {\ u\<^sub>0, \ u\<^sub>1} u\<^sub>1} \ card (set c) = 1" for c - unfolding dec0 dec1 using sing_pow_card_set by (elim two_elem_cases) fast+ - show "set c \ set d" if "c \ {Dec {\ u\<^sub>0, \ u\<^sub>1} u\<^sub>0, Dec {\ u\<^sub>0, \ u\<^sub>1} u\<^sub>1}" and - "d \ {Dec {\ u\<^sub>0, \ u\<^sub>1} u\<^sub>0, Dec {\ u\<^sub>0, \ u\<^sub>1} u\<^sub>1}" and "c \ d" for c d - using that unfolding dec0 dec1 - proof (elim two_elem_cases) - assume c: "c = [\ u\<^sub>0] \<^sup>@ Suc k\<^sub>0" and d: "d = [\ u\<^sub>1] \<^sup>@ Suc k\<^sub>1" - show "set c \ set d" - unfolding c d sing_pow_set_Suc using rcode.bin_code_neq by blast - next - assume c: "c = [\ u\<^sub>1] \<^sup>@ Suc k\<^sub>1" and d: "d = [\ u\<^sub>0] \<^sup>@ Suc k\<^sub>0" - show "set c \ set d" - unfolding c d sing_pow_set_Suc using rcode.bin_code_neq[symmetric] by blast - qed simp_all -qed +lemma primroot_dec: assumes "x \ y \ y \ x" + shows "(Dec {\ x, \ y} x) = [\ x]\<^sup>@e\<^sub>\ x" "(Dec {\ x, \ y} y) = [\ y]\<^sup>@e\<^sub>\ y" + by (simp_all add: binary_code.intro[OF assms] binary_code.primroot_dec) + +lemma (in binary_code) bin_roots_sings_code: "non_overlapping {Dec {\ u\<^sub>0, \ u\<^sub>1} u\<^sub>0, Dec {\ u\<^sub>0, \ u\<^sub>1} u\<^sub>1}" + using code_roots_non_overlapping unfolding primroot_dec by force subsection Other lemma bin_count_one_decompose: assumes "ws \ lists {x,y}" and "x \ y" and "count_list ws y = 1" obtains k m where "[x]\<^sup>@k \ [y] \ [x]\<^sup>@m = ws" proof- - have "ws \ [x]*" + have "ws \ [x]*" using count_sing_distinct[OF \x \ y\] \count_list ws y = 1\ unfolding root_def by force from distinct_letter_in[OF this] obtain ws' k b where "[x]\<^sup>@k \ [b] \ ws' = ws" and "b \ x" by blast - hence "b = y" + hence "b = y" using \ws \ lists {x,y}\ by force have "ws' \ lists {x,y}" - using \ws \ lists {x,y}\[folded \[x]\<^sup>@k \ [b] \ ws' = ws\] by simp + using \ws \ lists {x,y}\[folded \[x]\<^sup>@k \ [b] \ ws' = ws\] by simp have "count_list ws' y = 0" using arg_cong[OF \[x]\<^sup>@k \ [b] \ ws' = ws\, of "\ x. count_list x y"] - unfolding count_list_append \count_list ws y = 1\ \b = y\ by force - from sing_lists_exp[OF bin_lists_count_zero'[OF \ws' \ lists {x,y}\ this]] + unfolding count_list_append \count_list ws y = 1\ \b = y\ by force + from sing_lists_exp[OF bin_lists_count_zero'[OF \ws' \ lists {x,y}\ this]] obtain m where "ws' = [x]\<^sup>@m". - from that[OF \[x]\<^sup>@k \ [b] \ ws' = ws\[unfolded this \b = y\]] + from that[OF \[x]\<^sup>@k \ [b] \ ws' = ws\[unfolded this \b = y\]] show thesis. qed lemma bin_count_one_conjug: assumes "ws \ lists {x,y}" and "x \ y" and "count_list ws y = 1" - shows "ws \ [x]\<^sup>@(count_list ws x) \ [y]" + shows "ws \ [x]\<^sup>@(count_list ws x) \ [y]" proof- - obtain e1 e2 where "[x]\<^sup>@e1 \ [y] \ [x]\<^sup>@e2 = ws" + obtain e1 e2 where "[x]\<^sup>@e1 \ [y] \ [x]\<^sup>@e2 = ws" using bin_count_one_decompose[OF assms]. from conjugI'[of "[x] \<^sup>@ e1 \ [y]" "[x]\<^sup>@e2", unfolded rassoc this] have "ws \ [x]\<^sup>@(e2 + e1) \ [y]" unfolding add_exps rassoc. moreover have "count_list ([x]\<^sup>@(e2 + e1) \ [y]) x = e2 + e1" - using \x \ y\ by (simp add: count_list_append count_sing_exp) + using \x \ y\ by simp ultimately show ?thesis - by (simp add: count_list_conjug) + by (simp add: count_list_conjug) qed lemma bin_prim_long_set: assumes "ws \ lists {x,y}" and "primitive ws" and "2 \ \<^bold>|ws\<^bold>|" - shows "set ws = {x,y}" + shows "set ws = {x,y}" proof- have "\ set ws \ {c}" for c using \primitive ws\ pow_nemp_imprim \2 \ \<^bold>|ws\<^bold>|\ - sing_lists_exp_len[folded in_lists_conv_set_subset] by metis + sing_lists_exp_len[folded in_lists_conv_set_subset] by metis then show "set ws = {x,y}" - unfolding subset_singleton_iff using \ws \ lists {x,y}\[folded in_lists_conv_set_subset] doubleton_subset_cases by metis + unfolding subset_singleton_iff using \ws \ lists {x,y}\[folded in_lists_conv_set_subset] doubleton_subset_cases by metis qed lemma bin_prim_long_pref: assumes "ws \ lists {x,y}" and "primitive ws" and "2 \ \<^bold>|ws\<^bold>|" - obtains ws' where "ws \ ws'" and "[x,y] \p ws'" + obtains ws' where "ws \ ws'" and "[x,y] \p ws'" proof- from pow_nemp_imprim[OF \2 \ \<^bold>|ws\<^bold>|\, of "[x]"] sing_lists_exp_len[of ws x] - have "\ ws \ lists {x}" - using \primitive ws\ \2 \ \<^bold>|ws\<^bold>|\ by fastforce + have "\ ws \ lists {x}" + using \primitive ws\ \2 \ \<^bold>|ws\<^bold>|\ by fastforce hence "x \ y" - using \ws \ lists {x,y}\ by fastforce + using \ws \ lists {x,y}\ by fastforce from switch_fac[OF \x \ y\ bin_prim_long_set[OF assms]] show thesis - using \2 \ \<^bold>|ws\<^bold>|\ rotate_into_pos_sq[of \ "[x,y]" ws thesis, unfolded clean_emp, OF \[x, y] \f ws \ ws\ _ _ that, of id] + using \2 \ \<^bold>|ws\<^bold>|\ rotate_into_pos_sq[of \ "[x,y]" ws thesis, unfolded emp_simps, OF \[x, y] \f ws \ ws\ _ _ that, of id] by force qed -end \ No newline at end of file +end diff --git a/thys/Combinatorics_Words/document/root.bib b/thys/Combinatorics_Words/document/root.bib --- a/thys/Combinatorics_Words/document/root.bib +++ b/thys/Combinatorics_Words/document/root.bib @@ -1,154 +1,154 @@ % Encoding: UTF-8 @article{DBLP:journals/corr/NagashimaK16, author = {Yutaka Nagashima and Ramana Kumar}, title = {A Proof Strategy Language and Proof Script Generation for Isabelle}, journal = {CoRR}, volume = {abs/1606.02941}, year = {2016}, url = {http://arxiv.org/abs/1606.02941}, timestamp = {Fri, 01 Jul 2016 17:39:49 +0200}, biburl = {http://dblp.uni-trier.de/rec/bib/journals/corr/NagashimaK16}, bibsource = {dblp computer science bibliography, http://dblp.org} } @Book{Lo83, author = "M. Lothaire", title = "Combinatorics on Words", publisher = "Addison-Wesley, Reading, Mass.", year = "1983", series = "Encyclopaedia of Mathematics and its Applications", volume = "17", note = "Reprinted in the {\em Cambridge Mathematical Library}, Cambridge University Press, Cambridge UK, 1997", } @Book{Lo2, author = {M. Lothaire}, title = {Algebraic Combinatorics on Words}, publisher = {Cambridge University Press}, year = {2002}, number = {90}, series = {Encyclopedia of Mathematics and its Applications} } @book{Lo3, author = {M. Lothaire}, title = {Applied Combinatorics on Words}, publisher = {Cambridge University Press}, year = {2005}, isbn = {978-0-521-84802-2}, series = {Encyclopedia of Mathematics and its Applications}, number = {105} } @book{theory_of_codes, author = {Berstel, Jean and Perrin, Dominique}, title = {Theory of Codes}, year = {1985}, isbn = {0120934205}, publisher = {Academic Press, Inc.}, address = {USA} } @incollection{rampersad_shallit_2016, -place={Cambridge}, series={Encyclopedia of Mathematics and its Applications}, title={Repetitions in words}, DOI={10.1017/CBO9781139924733.005}, booktitle={Combinatorics, Words and Symbolic Dynamics}, publisher={Cambridge University Press}, author={Rampersad, N. and Shallit, J.}, editor={Berthé, Valérie and Rigo, MichelEditors}, year={2016}, pages={101--150}, collection={Encyclopedia of Mathematics and its Applications}} +place={Cambridge}, series={Encyclopedia of Mathematics and its Applications}, title={Repetitions in words}, DOI={10.1017/CBO9781139924733.005}, booktitle={Combinatorics, Words and Symbolic Dynamics}, publisher={Cambridge University Press}, author={Rampersad, N. and Shallit, J.}, editor={Berthé, Valérie and Rigo, MichelEditors}, year={2016}, pages={101–150}, collection={Encyclopedia of Mathematics and its Applications}} @incollection{halava_harju_karki_2016, -place={Cambridge}, series={Encyclopedia of Mathematics and its Applications}, title={Similarity relations on words}, DOI={10.1017/CBO9781139924733.007}, booktitle={Combinatorics, Words and Symbolic Dynamics}, publisher={Cambridge University Press}, author={Halava, V. and Harju, T. and Kärki, T.}, editor={Berthé, Valérie and Rigo, MichelEditors}, year={2016}, pages={175--212}, collection={Encyclopedia of Mathematics and its Applications}} +place={Cambridge}, series={Encyclopedia of Mathematics and its Applications}, title={Similarity relations on words}, DOI={10.1017/CBO9781139924733.007}, booktitle={Combinatorics, Words and Symbolic Dynamics}, publisher={Cambridge University Press}, author={Halava, V. and Harju, T. and Kärki, T.}, editor={Berthé, Valérie and Rigo, MichelEditors}, year={2016}, pages={175–212}, collection={Encyclopedia of Mathematics and its Applications}} @article{EHRENFEUCHT1979, title = "Periodicity and unbordered segments of words", journal = "Discrete Mathematics", volume = "26", number = "2", pages = "101 - 109", year = "1979", issn = "0012-365X", doi = "https://doi.org/10.1016/0012-365X(79)90116-X", url = "http://www.sciencedirect.com/science/article/pii/0012365X7990116X", author = "Andrzej Ehrenfeucht and D.M. Silberger", abstract = "A nonempty word β is said to be a border of a word α if and only if α = λβ = βρ for some nonempty words λ and ρ. For an arbitrary (possibly infinite) sequence α the expression # α denotes the (possibly infinite) supremum of the set of all |β| for β an unbordered finite segment of α." } @inbook{ChoKa97, author = {Choffrut, Christian and Karhum\"{a}ki, Juhani}, title = {Combinatorics of Words}, year = {1997}, isbn = {3540604200}, publisher = {Springer-Verlag}, address = {Berlin, Heidelberg}, booktitle = {Handbook of Formal Languages, Vol. 1: Word, Language, Grammar}, -pages = {329--438}, +pages = {329–438}, numpages = {110} } @article{LySch62, author = {R. C. Lyndon and P. Sch\"utzenberger}, title = {The equation $a^M=b^Nc^P$ in a free group}, journal = {Michigan Math. J.}, volume = {9}, pages = {289--298}, year = 1962 } @article{FineWilf, title={Uniqueness theorems for periodic functions}, author={N. J. Fine and H. S. Wilf}, year={1965}, journal = {Proc. Am. Math. Soc.}, volume = {16}, number = 1, pages = {109--114} } @article{HarjuNowotka, author = {Harju, Tero and Nowotka, Dirk}, title = {Periodicity and Unbordered Words: A Proof of the Extended {D}uval Conjecture}, year = {2007}, issue_date = {July 2007}, publisher = {Association for Computing Machinery}, address = {New York, NY, USA}, volume = {54}, number = {4}, issn = {0004-5411}, url = {https://doi.org/10.1145/1255443.1255448}, doi = {10.1145/1255443.1255448}, abstract = {The relationship between the length of a word and the maximum length of its unbordered factors is investigated in this article. Consider a finite word w of length n. We call a word bordered if it has a proper prefix, which is also a suffix of that word. Let μ(w) denote the maximum length of all unbordered factors of w, and let ∂(w) denote the period of w. Clearly, μ(w) ≤ ∂(w).We establish that μ(w) = ∂(w), if w has an unbordered prefix of length μ(w) and n ≥ 2μ(w) − 1. This bound is tight and solves the stronger version of an old conjecture by Duval [1983]. It follows from this result that, in general, n ≥ 3μ(w) − 3 implies μ(w) = ∂(w), which gives an improved bound for the question raised by Ehrenfeucht and Silberger in 1979.}, journal = {J. ACM}, month = jul, -pages = {20--es}, +pages = {20–es}, numpages = {20}, keywords = {Combinatorics on words, Duval's conjecture, unbordered words, periodicity} } @Article{Berstel1979, author = {J Berstel and D Perrin and J.F Perrot and A Restivo}, journal = {Journal of Algebra}, title = {Sur le théorème du défaut}, year = {1979}, issn = {0021-8693}, number = {1}, pages = {169--180}, volume = {60}, doi = {https://doi.org/10.1016/0021-8693(79)90113-3}, url = {http://www.sciencedirect.com/science/article/pii/0021869379901133}, } @article{Dmsi2006, doi = {10.1016/j.tcs.2006.08.023}, year = {2006}, month = nov, publisher = {Elsevier {BV}}, volume = {366}, number = {3}, pages = {194--198}, author = {P{\'{a}}l D\"{o}m\"{o}si and G{\'{e}}za Horv{\'{a}}th}, title = {Alternative proof of the {L}yndon{\textendash}{S}ch\"{u}tzenberger Theorem}, journal = {Theoret. Comput. Sci.} } @Comment{jabref-meta: databaseType:bibtex;} diff --git a/thys/Combinatorics_Words_Graph_Lemma/Glued_Codes.thy b/thys/Combinatorics_Words_Graph_Lemma/Glued_Codes.thy --- a/thys/Combinatorics_Words_Graph_Lemma/Glued_Codes.thy +++ b/thys/Combinatorics_Words_Graph_Lemma/Glued_Codes.thy @@ -1,481 +1,479 @@ (* Title: Glued Codes - File: CoW_Graph_Lemma.Glued_Codes - Author: Štěpán Holub, Charles University + File: Combinatorics_Words_Graph_Lemma.Glued_Codes 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 \Lists that do not end with a fixed letter\ -lemma append_last_neq: +lemma append_last_neq: "us = \ \ last us \ w \ vs = \ \ last vs \ w \ us \ vs = \ \ last (us \ vs) \ w" - by (auto simp only: last_append split: if_split) + 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 = \ \ last us \ w" and emp: "P \" and hd_eq: "\us. us \ \ \ last us \ w \ P us \ P (w # us)" and hd_neq: "\u us. u \ w \ us = \ \ last us \ w \ P us \ P (u # us)" shows "P us" using invariant proof (induction us) case (Cons u us) have inv: "us = \ \ last us \ w" using Cons.prems by (intro disjI) simp show "P (u # us)" proof (cases) assume "u = w" have *: "us \ \" and "last us \ w" using Cons.prems unfolding \u = w\ by auto then show "P (u # us)" unfolding \u = w\ using Cons.IH[OF inv] by (fact hd_eq) qed (use inv Cons.IH[OF inv] in \fact hd_neq\) qed (rule \P \\) lemma last_neq_blockE: assumes last_neq: "us \ \" and "last us \ w" obtains k u us' where "u \ w" and "us' = \ \ last us' \ w" and "[w] \<^sup>@ k \ u # us' = us" using disjI2[OF \last us \ w\] \us \ \\ proof (induction us rule: last_neq_induct) case (hd_eq us) from \us \ \\ 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 = \ \ last us \ w" and emp: "P \" and block: "\k u us. u \ w \ us = \ \ last us \ w \ P us \ P ([w] \<^sup>@ k \ (u # us))" shows "P us" using last_neq proof (induction us rule: ssuf_induct) case (ssuf us) show ?case proof (cases "us = \") assume "us \ \" obtain k u us' where "u \ w" and "us' = \ \ last us' \ w" and "[w] \<^sup>@ k \ u # us' = us" using \us \ \\ \us = \ \ last us \ w\ by (elim last_neq_blockE) (simp add: \us \ \\) have "us' \ last us' \ w" using \us = \ \ last us \ w\ by (auto simp flip: \[w] \<^sup>@ k \ u # us' = us\) from \u \ w\ \us' = \ \ last us' \ w\ ssuf.IH[OF this] show "P us" unfolding \[w] \<^sup>@ k \ u # us' = us\[symmetric] by (fact block) qed (simp only: emp) qed section \Glue a list element with its successors/predecessors\ function glue :: "'a list \ 'a list list \ 'a list list" where glue_emp: "glue w \ = \" | glue_Cons: "glue w (u # us) = (let glue_tl = glue w us in if u = w then (u \ 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 \ snd)") simp_all lemma no_gluing: "w \ set us \ glue w us = us" by (induction us) auto lemma glue_nemp [simp, intro!]: "us \ \ \ glue w us \ \" by (elim hd_tlE) (auto simp only: glue.simps Let_def split!: if_split) lemma glue_is_emp_iff [simp]: "glue w us = \ \ us = \" using glue_nemp glue_emp by blast lemma len_glue: "us = \ \ last us \ w \ \<^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 = \ \ last us \ w" shows "\<^bold>|glue w us\<^bold>| \ \<^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 = \ \ last us \ w \ w \ set us \ \<^bold>|glue w us\<^bold>| < \<^bold>|us\<^bold>|" by (simp add: count_list_gr_0_iff flip: len_glue[of us]) lemma assumes "us = \ \ last us \ w" and "\ \ set us" shows emp_not_in_glue: "\ \ set (glue w us)" and glued_not_in_glue: "w \ 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 = \ \ last us \ w \ \ \ set us \ glue w (glue w us) = glue w us" using no_gluing[OF glued_not_in_glue]. lemma glue_block_append: assumes "u \ w" shows "glue w ([w] \<^sup>@ k \ (u # us)) = (w \<^sup>@ k \ u) # glue w us" by (induction k) (simp_all add: \u \ w\) lemma concat_glue [simp]: "us = \ \ last us \ w \ concat (glue w us) = concat us" by (induction us rule: last_neq_block_induct) (simp_all add: glue_block_append) lemma glue_append: "us = \ \ last us \ w \ glue w (us \ vs) = glue w us \ glue w vs" by (induction us rule: last_neq_block_induct) (simp_all add: glue_block_append) lemma glue_pow: assumes "us = \ \ last us \ 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 = \ \ last us \ w \ us \ lists G \ glue w us \ lists \G\" by (induction rule: last_neq_induct) (simp_all add: Let_def tl_in_lists prod_cl gen_in) \ \Gluing from the right (gluing a letter with its predecessor)\ function gluer :: "'a list \ 'a list list \ 'a list list" where gluer_emp: "gluer w \ = \" | gluer_Cons: "gluer w (u # us) = (let gluer_butlast = gluer w (butlast (u # us)) in if last (u # us) = w then (butlast gluer_butlast) \ [last gluer_butlast \ last (u # us)] else gluer_butlast \ [last (u # us)])" unfolding prod_eq_iff prod.sel by (cases rule: list.exhaust[of "snd _"]) blast+ termination by (relation "measure (length \ snd)") simp_all lemma gluer_nemp_def: assumes "us \ \" - shows "gluer w us = + shows "gluer w us = (let gluer_butlast = gluer w (butlast us) in if last us = w then (butlast gluer_butlast) \ [last gluer_butlast \ last us] else gluer_butlast \ [last us])" using gluer_Cons[of w "hd us" "tl us"] unfolding hd_Cons_tl[OF \us \ \\]. lemma gluer_nemp: assumes "us \ \" shows "gluer w us \ \" unfolding gluer_nemp_def[OF \us \ \\] by (simp only: Let_def split!: if_split) lemma hd_neq_induct [consumes 1, case_names emp snoc_eq snoc_neq]: assumes invariant: "us = \ \ hd us \ w" and emp: "P \" and snoc_eq: "\us. us \ \ \ hd us \ w \ P us \ P (us \ [w])" and snoc_neq: "\u us. u \ w \ us = \ \ hd us \ w \ P us \ P (us \ [u])" shows "P us" using last_neq_induct[where P="\x. P (rev x)" for P, reversed, unfolded rev_rev_ident, OF assms]. lemma gluer_rev [reversal_rule]: assumes "us = \ \ last us \ 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 = \ \ hd us \ 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 \Generators with glued element\ text \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\ inductive_set glued_gens :: "'a list \ 'a list set \ 'a list set" for w G where - other_gen: "g \ G \ g \ w \ g \ glued_gens w G" + other_gen: "g \ G \ g \ w \ g \ glued_gens w G" | glued [intro!]: "u \ glued_gens w G \ w \ u \ glued_gens w G" lemma in_glued_gensI: assumes "g \ G" "g \ w" shows "w \<^sup>@ k \ g = u \ u \ glued_gens w G" by (induction k arbitrary: u) (auto simp: other_gen[OF \g \ G\ \g \ w\]) lemma in_glued_gensE: assumes "u \ glued_gens w G" obtains k g where "g \ G" and "g \ w" and "w \<^sup>@ k \ 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 \ g | k g. g \ C \ g \ w}" by (blast elim!: in_glued_gensE intro: in_glued_gensI) lemma glued_hull_sub_hull [simp, intro!]: "w \ G \ \glued_gens w G\ \ \G\" by (rule hull_mono') (auto elim!: in_glued_gensE) lemma glued_hull_sub_hull': "w \ G \ u \ \glued_gens w G\ \ u \ \G\" using set_mp[OF glued_hull_sub_hull]. lemma in_glued_hullE: assumes "w \ G" and "u \ \glued_gens w G\" obtains us where "concat us = u" and "us \ lists G" and "us = \ \ last us \ w" using \u \ \glued_gens w G\\ proof (induction arbitrary: thesis) case (prod_cl v u) obtain k g where "g \ G" and "g \ w" and "concat ([w] \<^sup>@ k \ [g]) = v" - using \v \ glued_gens w G\ by (simp add: concat_pow) (elim in_glued_gensE) + using \v \ glued_gens w G\ by simp (elim in_glued_gensE) obtain us where u: "concat us = u" and "us \ lists G" and "(us = \ \ last us \ w)" by fact have "concat ([w] \<^sup>@ k \ [g] \ us) = v \ u" by (simp flip: \concat ([w] \<^sup>@ k \ [g]) = v\ \concat us = u\) with \(us = \ \ last us \ w)\ show thesis - by (elim prod_cl.prems, intro lists.intros + by (elim prod_cl.prems, intro lists.intros append_in_lists pow_in_lists \w \ G\ \g \ G\ \us \ lists G\) (auto simp: \g \ w\) qed (use concat.simps(1) in blast) lemma glue_in_lists [simp, intro!]: assumes "us = \ \ last us \ w" shows "us \ lists G \ glue w us \ 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 \ lists G \ us = \ \ last us \ w \ concat us \ \glued_gens w G\" unfolding concat_glue[symmetric] by (intro concat_in_hull' glue_in_lists) lemma glued_hull_conv: assumes "w \ G" shows "\glued_gens w G\ = {concat us | us. us \ lists G \ (us = \ \ last us \ w)}" by (blast elim!: in_glued_hullE[OF \w \ G\]) section \Bounded gluing\ lemma bounded_glue_in_lists: assumes "us = \ \ last us \ w" and "\ [w] \<^sup>@ n \f us" shows "us \ lists G \ glue w us \ lists {w \<^sup>@ k \ g | k g. g \ G \ g \ w \ k < n}" using assms proof (induction us rule: last_neq_block_induct) case (block k u us) have "k < n" and "\ [w] \<^sup>@ n \f us" using \\ [w] \<^sup>@ n \f [w] \<^sup>@ k \ u # us\ - by (blast intro!: not_le_imp_less pref_ext le_exps_pref, blast intro!: fac_ext_pref fac_ext_hd) + by (blast intro!: not_le_imp_less le_exps_pref, blast intro!: fac_ext_pref fac_ext_hd) then show ?case using \[w] \<^sup>@ k \ u # us \ lists G\ \u \ w\ unfolding glue_block_append[OF \u \ w\] by (blast intro!: block.IH del: in_listsD in_listsI) qed simp subsection \Gluing on binary alphabet\ lemma bounded_bin_glue_in_lists: \ \meaning: a binary code\ assumes "us = \ \ last us \ x" and "\ [x] \<^sup>@ n \f us" and "us \ lists {x, y}" shows "glue x us \ lists {x \<^sup>@ k \ y | k. k < n}" using bounded_glue_in_lists[OF assms] by blast lemma single_bin_glue_in_lists: \ \meaning: a single occurrence\ assumes "us = \ \ last us \ x" and "\ [x,x] \f us" and "us \ lists {x, y}" shows "glue x us \ lists {x \ 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 \ \" and "x \ y" and "us = \ \ last us \ x" and "us \ lists {x,y}" and "\ [x,x] \f us" shows "count_list (glue x us) (x \ 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 \[x] \<^sup>@ k \ u # us \ lists {x, y}\ \u \ x\ by simp have IH: "count_list (glue x us) (x \ y) = count_list us x \ 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 "\ [x] \<^sup>@ Suc (Suc 0) \f [x] \<^sup>@ k \ u # us" - using block.prems(2) by auto + using block.prems(2) by auto then have "k < Suc (Suc 0)" - by (blast intro!: not_le_imp_less pref_ext le_exps_pref) + by (blast intro!: not_le_imp_less le_exps_pref) then show ?case unfolding \u = y\ glue_block_append[OF \x \ y\[symmetric]] by (elim less_SucE less_zeroE) (simp_all add: \x \ y\ \x \ y\[symmetric] \x \ \\ IH) qed simp section \Code with glued element\ context code begin text \If the original generating set is a code, then also the glued generators form a code\ lemma glued_hull_last_dec: assumes "w \ \" and "u \ \glued_gens w \\" and "u \ \" shows "last (Dec \ u) \ w" using \u \ \glued_gens w \\\ by (elim in_glued_hullE[OF \w \ \\]) (auto simp: code_unique_dec \u \ \\) lemma in_glued_hullI [intro]: assumes "u \ \\\" and "(u = \ \ last (Dec \ u) \ w)" shows "u \ \glued_gens w \\" - using concat_in_glued_hull[OF dec_in_lists[OF \u \ \\\\], of w] + using concat_in_glued_hull[OF dec_in_lists[OF \u \ \\\\], of w] by (simp add: \u \ \\\\ \u = \ \ last (Dec \ u) \ w\) lemma code_glued_hull_conv: assumes "w \ \" shows "\glued_gens w \\ = {u \ \\\. u = \ \ last (Dec \ u) \ w}" proof show "\glued_gens w \\ \ {u \ \\\. u = \ \ last (Dec \ u) \ w}" using glued_hull_sub_hull'[OF \w \ \\] glued_hull_last_dec[OF \w \ \\] by blast show "{u \ \\\. u = \ \ last (Dec \ u) \ w} \ \glued_gens w \\" using in_glued_hullI by blast qed lemma in_glued_hull_iff: assumes "w \ \" and "u \ \\\" shows "u \ \glued_gens w \\ \ u = \ \ last (Dec \ u) \ w" by (simp add: \w \ \\ \u \ \\\\ code_glued_hull_conv) lemma glued_not_in_glued_hull: "w \ \ \ w \ \glued_gens w \\" unfolding in_glued_hull_iff[OF _ gen_in] code_el_dec - by (simp add: in_code_nemp) + by (simp add: nemp) lemma glued_gens_nemp: assumes "u \ glued_gens w \" shows "u \ \" - using assms by (induction) (auto simp add: in_code_nemp) + using assms by (induction) (auto simp add: nemp) lemma glued_gens_code: assumes "w \ \" shows "code (glued_gens w \)" proof show "us = vs" if "us \ lists (glued_gens w \)" and "vs \ lists (glued_gens w \)" and "concat us = concat vs" for us vs using that proof (induction rule: list_induct2') case (4 u us v vs) have *: "us \ lists (glued_gens w \) \ us \ lists \\\" for us using sub_lists_mono[OF subset_trans[OF genset_sub glued_hull_sub_hull[OF \w \ \\]]]. obtain k u' l v' where "u' \ \" "u' \ w" "w \<^sup>@ k \ u' = u" and "v' \ \" "v' \ w" "w \<^sup>@ l \ v' = v" using "4.prems"(1-2) by simp (elim conjE in_glued_gensE) from this(3, 6) "4.prems" \w \ \\ - have "concat (([w] \<^sup>@ k \ [u']) \ (Ref \ us)) = concat (([w] \<^sup>@ l \ [v']) \ (Ref \ vs))" - by (simp add: concat_ref * concat_pow lassoc) + have "concat (([w] \<^sup>@ k \ [u']) \ (Ref \ us)) = concat (([w] \<^sup>@ l \ [v']) \ (Ref \ vs))" + by (simp add: concat_ref * lassoc) with \w \ \\ \u' \ \\ \v' \ \\ "4.prems"(1-2) - have "[w] \<^sup>@ k \ [u'] \ [w] \<^sup>@ l \ [v']" + have "[w] \<^sup>@ k \ [u'] \ [w] \<^sup>@ l \ [v']" by (elim eqd_comp[OF is_code, rotated 2]) - (simp_all add: "*" pow_in_lists ref_in') + (simp_all add: "*" pow_in_lists ref_in') with \u' \ w\ \v' \ w\ \w \<^sup>@ k \ u' = u\ \w \<^sup>@ l \ v' = v\ 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 \A crucial lemma showing the relation between gluing and the decomposition into generators\ lemma dec_glued_gens: assumes "w \ \" and "u \ \glued_gens w \\" shows "Dec (glued_gens w \) u = glue w (Dec \ u)" using \u \ \glued_gens w \\\ glued_hull_sub_hull'[OF \w \ \\ \u \ \glued_gens w \\\] - by (intro code.code_unique_dec glued_gens_code) + by (intro code.code_unique_dec glued_gens_code) (simp_all add: in_glued_hull_iff \w \ \\) lemma ref_glue: "us = \ \ last us \ w \ us \ lists \ \ Ref \ (glue w us) = us" by (intro refI glue_in_lists_hull) simp_all -end (* end of context code *) - +end theorem glued_code: assumes "code C" and "w \ C" shows "code {w \<^sup>@ k \ u |k u. u \ C \ u \ w}" using code.glued_gens_code[OF \code C\ \w \ C\] unfolding glued_gens_alt_def. section \Gluing is primitivity preserving\ text \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.\ lemma (in code) code_prim_glue: assumes last_neq: "us = \ \ last us \ w" and "us \ lists \" shows "primitive us \ primitive (glue w us)" using prim_map_prim[OF prim_concat_prim, of "decompose \" "glue w us"] unfolding refine_def[symmetric] ref_glue[OF assms]. \ \In the context of code the inverse to the glue function is the @{const refine} function, i.e. @{term "\vs. concat (map (decompose \) 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).\ definition glue_block :: "'a list \'a list list \ 'a list list \ bool" where "glue_block w us bs = (\ps k u ss. (ps = \ \ last ps \ w) \ u \ w \ ps \ [w] \<^sup>@ k \ u # ss = us \ [w] \<^sup>@ k \ [u] = bs)" lemma glue_blockI [intro]: "ps = \ \ last ps \ w \ u \ w \ ps \ [w] \<^sup>@ k \ u # ss = us \ [w] \<^sup>@ k \ [u] = bs \ 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 = \ \ last ps \ w" and "u \ w" "ps \ [w] \<^sup>@ k \ u # ss = us" and "[w] \<^sup>@ k \ [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 \ vs) bs" and glue_block_of_appendR: "vs = \ \ last vs \ w \ glue_block w (vs \ us) bs" using \glue_block w us bs\ by (elim glue_blockE, use nothing in \ intro glue_blockI[of _ w _ _ "_ \ vs" "us \ vs" bs] glue_blockI[OF append_last_neq, of "vs" w _ _ _ _ "vs \ us" bs], simp_all only: eq_commute[of _ us] rassoc append_Cons refl not_False_eq_True\)+ lemma glue_block_of_block_append: "u \ w \ glue_block w us bs \ glue_block w ([w] \<^sup>@ k \ 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 = \ \ last us \ w" and "b \ 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 \b \ set (glue w ([w] \<^sup>@ k \ u # us))\ proof (auto simp add: glue_block_append \u \ w\) show "b = w \<^sup>@ k \ u \ thesis" - by (auto simp add: concat_pow intro!: block.prems(1) glue_blockI[OF _ \u \ w\ _ refl]) + by (auto intro!: block.prems(1) glue_blockI[OF _ \u \ w\ _ refl]) show "b \ set (glue w us) \ thesis" by (auto intro!: block.IH[OF block.prems(1)] glue_block_of_block_append \u \ w\) qed qed simp definition unglue :: "'a list \ 'a list list \ 'a list \ 'a list list" where "unglue w us b = (THE bs. glue_block w us bs \ concat bs = b)" lemma unglueI: assumes unique_blocks: "\bs\<^sub>1 bs\<^sub>2. glue_block w us bs\<^sub>1 \ glue_block w us bs\<^sub>2 \ concat bs\<^sub>1 = concat bs\<^sub>2 \ bs\<^sub>1 = bs\<^sub>2" shows "glue_block w us bs \ concat bs = b \ unglue w us b = bs" unfolding unglue_def by (blast intro: unique_blocks) lemma concat_map_unglue_glue: assumes last_neq: "us = \ \ last us \ w" and unique_blocks: "\vs\<^sub>1 vs\<^sub>2. glue_block w us vs\<^sub>1 \ glue_block w us vs\<^sub>2 \ concat vs\<^sub>1 = concat vs\<^sub>2 \ 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 \u \ w\) have *: "map (unglue w ([w] \<^sup>@ k \ 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 \us = \ \ last us \ w\], intro the_equality) (simp_all only: the_equality block.prems glue_block_of_block_append[OF \u \ w\]) show "concat (map (unglue w ([w] \<^sup>@ k \ u # us)) (glue w ([w] \<^sup>@ k \ u # us))) = [w] \<^sup>@ k \ u # us" - by (auto simp add: concat_pow glue_block_append[OF \u \ w\] * IH + by (auto simp add: glue_block_append[OF \u \ w\] * IH intro!: unglueI intro: glue_blockI[OF _ \u \ w\] block.prems) qed simp lemma prim_glue: assumes last_neq: "us = \ \ last us \ w" and unique_blocks: "\bs\<^sub>1 bs\<^sub>2. glue_block w us bs\<^sub>1 \ glue_block w us bs\<^sub>2 \ concat bs\<^sub>1 = concat bs\<^sub>2 \ bs\<^sub>1 = bs\<^sub>2" shows "primitive us \ 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 \Gluing on binary alphabet\ lemma bin_glue_blockE: assumes "us \ lists {x, y}" and "glue_block x us bs" obtains k where "[x] \<^sup>@ k \ [y] = bs" using assms by (auto simp only: glue_block_def del: in_listsD) lemma unique_bin_glue_blocks: assumes "us \ lists {x, y}" and "x \ \" shows "glue_block x us bs\<^sub>1 \ glue_block x us bs\<^sub>2 \ concat bs\<^sub>1 = concat bs\<^sub>2 \ bs\<^sub>1 = bs\<^sub>2" - by (auto simp: concat_pow eq_pow_exp[OF \x \ \\] elim!: bin_glue_blockE[OF \us \ lists {x, y}\]) + by (auto simp: eq_pow_exp[OF \x \ \\] elim!: bin_glue_blockE[OF \us \ lists {x, y}\]) lemma prim_bin_glue: assumes "us \ lists {x, y}" and "x \ \" and "us = \ \ last us \ x" shows "primitive us \ primitive (glue x us)" using prim_glue[OF \us = \ \ last us \ x\ 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,104 +1,104 @@ (* Title: Graph Lemma - File: CoW_Graph_Lemma.Graph_Lemma + File: Combinatorics_Words_Graph_Lemma.Graph_Lemma 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 Graph_Lemma imports Combinatorics_Words.Submonoids Glued_Codes begin chapter \Graph Lemma\ -text\The Graph Lemma is an important tool for gaining information about systems of word equations. +text\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\. Key ingredients of the proof are in the theory @{theory Combinatorics_Words_Graph_Lemma.Glued_Codes}\ +We formalize the algebraic proof from @{cite Berstel1979}. Key ingredients of the proof are in the @{theory "Combinatorics_Words_Graph_Lemma.Glued_Codes"}.\ section \Graph lemma\ theorem graph_lemma_last: "\\<^sub>F G = {last (Dec (\\<^sub>F G) g) | g. g \ G \ g \ \}" proof interpret code "\\<^sub>F G" using free_basis_code. \ \the core is to show that each element of the free basis must be a last of some word\ show "\\<^sub>F G \ {last (Dec \\<^sub>F G g) |g. g \ G \ g \ \}" proof (rule ccontr) \ \Assume the contrary.\ assume "\ \\<^sub>F G \ {last (Dec \\<^sub>F G g) |g. g \ G \ g \ \}" \ \And let w be the not-last\ then obtain w - where "w \ \\<^sub>F G" + where "w \ \\<^sub>F G" and hd_dec_neq: "\g. g \ G \ g \ \ \ last (Dec (\\<^sub>F G) g) \ w" by blast \ \For contradiction: We have a free hull which does not contain w but contains G.\ have "G \ \glued_gens w (\\<^sub>F G)\" by (blast intro!: gen_in_free_hull hd_dec_neq del: notI) then have "\\\<^sub>F G\ \ \glued_gens w (\\<^sub>F G)\" unfolding basis_gen_hull_free by (intro code.free_hull_min glued_gens_code \w \ \\<^sub>F G\) then show False using \w \ \\<^sub>F G\ glued_not_in_glued_hull by blast qed \ \The opposite inclusion is easy\ show "{last (Dec \\<^sub>F G g) |g. g \ G \ g \ \} \ \\<^sub>F G" by (auto intro!: dec_in_lists lists_hd_in_set[reversed] gen_in_free_hull del: notI) qed theorem graph_lemma: "\\<^sub>F G = {hd (Dec (\\<^sub>F G) g) | g. g \ G \ g \ \}" proof - have *: "rev u = last (Dec rev ` (\\<^sub>F G) (rev g)) \ g \ G \ g \ \ \ u = hd (Dec (\\<^sub>F G) g) \ g \ G \ g \ \" for u g by (cases "g \ G \ g \ \") (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 \Binary code\ text \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}. +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.\ lemma non_comm_hds_neq: assumes "u \ v \ v \ u" shows "hd (Dec \\<^sub>F {u,v} u) \ hd (Dec \\<^sub>F {u,v} v)" using assms proof (rule contrapos_nn) assume hds_eq: "hd (Dec \\<^sub>F {u,v} u) = hd (Dec \\<^sub>F {u,v} v)" have **: "\\<^sub>F {u,v} = {hd (Dec \\<^sub>F {u,v} u)}" using graph_lemma by (rule trans) (use assms in \auto intro: hds_eq[symmetric]\) show "u \ v = v \ u" by (intro comm_rootI[of _ "hd (Dec \\<^sub>F {u,v} u)"] sing_gen) (simp_all add: **[symmetric] gen_in_free_hull) qed theorem assumes "u \ v \ v \ u" shows "code {u, v}" proof have *: "w \ {u, v} \ w \ \" for w using \u \ v \ v \ u\ by blast fix xs ys show "xs \ lists {u, v} \ ys \ lists {u, v} \ concat xs = concat ys \ xs = ys" proof (induction xs ys rule: list_induct2') case (4 x xs y ys) have **: "hd (Dec \\<^sub>F {u,v} (concat (z # zs))) = hd (Dec \\<^sub>F {u,v} z)" if "z # zs \ 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) + free_basis_dec_morph * basis_gen_hull_free) have "hd (Dec \\<^sub>F {u,v} x) = hd (Dec \\<^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 \u \ v \ v \ u\] by (elim listsE insertE emptyE) simp_all with 4 show "x # xs = y # ys" by simp qed (simp_all add: *) qed end diff --git a/thys/Combinatorics_Words_Graph_Lemma/document/root.bib b/thys/Combinatorics_Words_Graph_Lemma/document/root.bib --- a/thys/Combinatorics_Words_Graph_Lemma/document/root.bib +++ b/thys/Combinatorics_Words_Graph_Lemma/document/root.bib @@ -1,102 +1,102 @@ % Encoding: UTF-8 @article{DBLP:journals/corr/NagashimaK16, author = {Yutaka Nagashima and Ramana Kumar}, title = {A Proof Strategy Language and Proof Script Generation for Isabelle}, journal = {CoRR}, volume = {abs/1606.02941}, year = {2016}, url = {http://arxiv.org/abs/1606.02941}, timestamp = {Fri, 01 Jul 2016 17:39:49 +0200}, biburl = {http://dblp.uni-trier.de/rec/bib/journals/corr/NagashimaK16}, bibsource = {dblp computer science bibliography, http://dblp.org} } @Book{Lo83, author = "M. Lothaire", title = "Combinatorics on Words", publisher = "Addison-Wesley, Reading, Mass.", year = "1983", series = "Encyclopaedia of Mathematics and its Applications", volume = "17", note = "Reprinted in the {\em Cambridge Mathematical Library}, Cambridge University Press, Cambridge UK, 1997", } @Book{Lo2, author = {M. Lothaire}, title = {Algebraic Combinatorics on Words}, publisher = {Cambridge University Press}, year = {2002}, number = {90}, series = {Encyclopedia of Mathematics and its Applications} } @book{Lo3, author = {M. Lothaire}, title = {Applied Combinatorics on Words}, publisher = {Cambridge University Press}, year = {2005}, isbn = {978-0-521-84802-2}, series = {Encyclopedia of Mathematics and its Applications}, number = {105} } @incollection{rampersad_shallit_2016, -place={Cambridge}, series={Encyclopedia of Mathematics and its Applications}, title={Repetitions in words}, DOI={10.1017/CBO9781139924733.005}, booktitle={Combinatorics, Words and Symbolic Dynamics}, publisher={Cambridge University Press}, author={Rampersad, N. and Shallit, J.}, editor={Berthé, Valérie and Rigo, MichelEditors}, year={2016}, pages={101--150}, collection={Encyclopedia of Mathematics and its Applications}} +place={Cambridge}, series={Encyclopedia of Mathematics and its Applications}, title={Repetitions in words}, DOI={10.1017/CBO9781139924733.005}, booktitle={Combinatorics, Words and Symbolic Dynamics}, publisher={Cambridge University Press}, author={Rampersad, N. and Shallit, J.}, editor={Berthé, Valérie and Rigo, MichelEditors}, year={2016}, pages={101–150}, collection={Encyclopedia of Mathematics and its Applications}} @incollection{halava_harju_karki_2016, -place={Cambridge}, series={Encyclopedia of Mathematics and its Applications}, title={Similarity relations on words}, DOI={10.1017/CBO9781139924733.007}, booktitle={Combinatorics, Words and Symbolic Dynamics}, publisher={Cambridge University Press}, author={Halava, V. and Harju, T. and Kärki, T.}, editor={Berthé, Valérie and Rigo, MichelEditors}, year={2016}, pages={175--212}, collection={Encyclopedia of Mathematics and its Applications}} +place={Cambridge}, series={Encyclopedia of Mathematics and its Applications}, title={Similarity relations on words}, DOI={10.1017/CBO9781139924733.007}, booktitle={Combinatorics, Words and Symbolic Dynamics}, publisher={Cambridge University Press}, author={Halava, V. and Harju, T. and Kärki, T.}, editor={Berthé, Valérie and Rigo, MichelEditors}, year={2016}, pages={175–212}, collection={Encyclopedia of Mathematics and its Applications}} @article{EHRENFEUCHT1979, title = "Periodicity and unbordered segments of words", journal = "Discrete Mathematics", volume = "26", number = "2", pages = "101 - 109", year = "1979", issn = "0012-365X", doi = "https://doi.org/10.1016/0012-365X(79)90116-X", url = "http://www.sciencedirect.com/science/article/pii/0012365X7990116X", author = "Andrzej Ehrenfeucht and D.M. Silberger", abstract = "A nonempty word β is said to be a border of a word α if and only if α = λβ = βρ for some nonempty words λ and ρ. For an arbitrary (possibly infinite) sequence α the expression # α denotes the (possibly infinite) supremum of the set of all |β| for β an unbordered finite segment of α." } @inbook{ChoKa97, author = {Choffrut, Christian and Karhum\"{a}ki, Juhani}, title = {Combinatorics of Words}, year = {1997}, isbn = {3540604200}, publisher = {Springer-Verlag}, address = {Berlin, Heidelberg}, booktitle = {Handbook of Formal Languages, Vol. 1: Word, Language, Grammar}, -pages = {329--438}, +pages = {329–438}, numpages = {110} } @article{LySch62, author = {R. C. Lyndon and P. Sch\"utzenberger}, title = {The equation $a^M=b^Nc^P$ in a free group}, journal = {Michigan Math. J.}, volume = {9}, pages = {289--298}, year = 1962 } @Article{Berstel1979, author = {J Berstel and D Perrin and J.F Perrot and A Restivo}, journal = {Journal of Algebra}, title = {Sur le théorème du défaut}, year = {1979}, issn = {0021-8693}, number = {1}, pages = {169--180}, volume = {60}, doi = {https://doi.org/10.1016/0021-8693(79)90113-3}, url = {http://www.sciencedirect.com/science/article/pii/0021869379901133}, } @Comment{jabref-meta: databaseType:bibtex;} 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,866 +1,863 @@ -(* Title: CoW_Lyndon.Lyndon +(* Title: Combinatorics_Words_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\A Lyndon word is a non-empty word that is lexicographically +text\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. +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>\\Chapter 5\ in Lo83\ and \<^cite>\Duval80 and Duval83\. +We present elementary results on Lyndon words, mostly covered by results in @{cite \Chapter 5\ Lo83} and @{cite Duval80 and Duval83}. This definition assumes a linear order on letters given by the context. \ section "Definition and elementary properties" subsection "Underlying order" lemma (in linorder) lexordp_mid_pref: "ord_class.lexordp u v \ ord_class.lexordp v (u\s) \ u \p v" by (induct rule: lexordp_induct, simp_all) -lemma (in linorder) lexordp_ext: "ord_class.lexordp u v \ \ u \p v \ +lemma (in linorder) lexordp_ext: "ord_class.lexordp u v \ \ u \p v \ ord_class.lexordp (u\w) (v\z)" - by (induct rule: lexordp_induct, simp_all) - -lemmas [code] = lexordp_simps + by (induct rule: lexordp_induct, simp_all) context linorder begin abbreviation Lyndon_less :: "'a list \ 'a list \ bool" (infixl " ord_class.lexordp xs ys" abbreviation Lyndon_le :: "'a list \ 'a list \ bool" (infixl "\lex" 50) where "Lyndon_le xs ys \ ord_class.lexordp_eq xs ys" -interpretation rlex: linorder "(\lex)" "(lex)" "( x y. y \lex x" "\ x y. y x y. y \lex x" "\ x y. y rlex.sorted (rev ws)" - unfolding rlex.sorted_rev_iff_nth_mono dual_rlex.sorted_iff_nth_mono by blast + unfolding rlex.sorted_rev_iff_nth_mono dual_rlex.sorted_iff_nth_mono by blast text \Several useful lemmas that are formulated for relations, interpreted for the default linear order.\ 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 \ bool" where "Lyndon w = (w \ \ \ (\n. 0 < n \ n < \<^bold>|w\<^bold>| \ w 0 < n \ n < \<^bold>|w\<^bold>| \ w w \ \" unfolding Lyndon.simps by blast lemma LyndonI: "w \ \ \ \ n. 0 < n \ n < \<^bold>|w\<^bold>| \ w Lyndon w" unfolding Lyndon.simps by blast -lemma Lyndon_sing: "Lyndon [a]" +lemma Lyndon_sing: "Lyndon [a]" unfolding Lyndon.simps by auto lemma Lyndon_prim: assumes "Lyndon w" shows "primitive w" proof- have "0 < n \ n < \<^bold>|w\<^bold>| \ rotate n w \ w" for n using LyndonD[OF \Lyndon w\, of n] rlex.less_irrefl[of w] by argo from no_rotate_prim[OF LyndonD_nemp[OF \Lyndon w\]] this show ?thesis by blast qed lemma Lyndon_conj_greater: "Lyndon (u\v) \ u \ \ \ v \ \ \ u\v u" - using LyndonD[of "u\v" "\<^bold>|u\<^bold>|", unfolded rotate_append[of u v]] + using LyndonD[of "u\v" "\<^bold>|u\<^bold>|", unfolded rotate_append[of u v]] by force subsection "Code equations for Lyndon words" primrec Lyndon_rec :: "'a list \ nat \ bool" where "Lyndon_rec w 0 = True" | "Lyndon_rec w (Suc n) = (if w |w\<^bold>|)" shows "n < \<^bold>|a#w\<^bold>| \ 0 < n \ 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 \ n < \<^bold>|w\<^bold>| \ Lyndon_rec w n" proof(induction n, simp) case (Suc n) have "w Suc n < \<^bold>|w\<^bold>|\], folded neq0_conv] Lyndon_rec.simps(1)[of w] + using Suc.IH[OF _ Suc_lessD[OF \Suc n < \<^bold>|w\<^bold>|\], 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 Nil = False" "Lyndon (a # w) = Lyndon_rec (a # w) (\<^bold>|w\<^bold>|)" proof- show "Lyndon Nil = False" by simp have "a # w \ \" by simp have ax: "0 < n \ Lyndon_rec (a#w) n \ (a#w) |w\<^bold>|) = (\n. n < \<^bold>|a#w\<^bold>| \ 0 < n \ Lyndon_rec (a#w) n)" proof(cases "w = \", simp) assume "w \ \" 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 \a # w \ \\]Lyndon_Lyndon_rec by blast qed subsection "Properties of Lyndon words" subsubsection "Lyndon words are unbordered" theorem Lyndon_unbordered: assumes "Lyndon w" shows "\ bordered w" proof assume "bordered w" from bordered_dec[OF this] - obtain u v where "u\v\u = w" and "u \ \". + obtain u v where "u\v\u = w" and "u \ \". hence "v \ u \ \" and "u \ v \ \" by blast+ - note lyn = \Lyndon w\[folded \u\v\u = w\] + note lyn = \Lyndon w\[folded \u\v\u = w\] have "u\v\u u\u" using Lyndon_conj_greater[of u "v\u", OF lyn \u \ \\ \v \ u \ \\, unfolded rassoc]. from this[unfolded lassoc] - have "u \ v \ v \ u" + have "u \ v \ v \ u" by force from lexord_suf_linorder[OF _ this, of u u] - have "u\v u" + have "u\v u" using \u\v\u u\u\ by simp from lexord_append_leftI_linorder[of "u\v" "v\u", unfolded lassoc, OF this, unfolded rassoc] have "u\u\v v\u". from this Lyndon_conj_greater[of "u\v" u, unfolded rassoc, OF lyn \u \ v \ \\ \u \ \\] - show False + 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 \ \" using prim_nemp[OF \primitive w\]. let ?ConClass = "{rotate n w | n. 0 \ n \ n < \<^bold>|w\<^bold>|}" have "?ConClass \ {}" - using \w \ \\ by blast + using \w \ \\ by blast + have "finite ?ConClass" + by force have "w \ ?ConClass" - using \w \ \\ id_apply[of w, folded rotate0] - by force - have "finite ?ConClass" - by simp + by (rule CollectI) + (use le0[of 0] nemp_pos_len[OF \w \ \\] id_apply[of w, folded rotate0] in metis) have all_rot: "rotate m w \ ?ConClass" for m using rotate_conv_mod[of _ w] mod_less_divisor[of "\<^bold>|w\<^bold>|"] \w \ \\ by blast obtain w' n where "w' \ ?ConClass" and all_b: "\ b \ ?ConClass. b \lex w' \ w' = b" and w': "w' = rotate n w" - using rlex.finite_has_minimal[OF \finite ?ConClass\ \?ConClass \ {}\] by auto + using rlex.finite_has_minimal[OF \finite ?ConClass\ \?ConClass \ {}\] by auto have "rotate n w |w\<^bold>|" for na proof- from prim_no_rotate[OF assms[unfolded prim_rotate_conv[of w n]], of na] \na < \<^bold>|w\<^bold>|\ \0 < na\ have "rotate na (rotate n w) \ rotate n w" by force hence "\ rotate na (rotate n w) \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 w \ \\ by auto + using \w \ \\ by auto from that[OF this] show thesis. qed lemma conjug_Lyndon_ex': assumes "primitive w" obtains v where "w \ v" and "Lyndon v" unfolding conjug_rotate_iff using conjug_Lyndon_ex[OF \primitive w\] by metis - + section "Characterization by suffixes" lemma Lyndon_suf_less: assumes "Lyndon w" "s \ns w" "s \ w" shows "w |s\<^bold>| w" - have "\<^bold>|s\<^bold>| \ \<^bold>|w\<^bold>|" + define p where "p = take \<^bold>|s\<^bold>| w" + have "\<^bold>|s\<^bold>| \ \<^bold>|w\<^bold>|" using nsD[OF \s \ns w\] - by (simp add: suffix_length_le) + by (simp add: suffix_length_le) have "p \p w" and "\<^bold>|p\<^bold>| = \<^bold>|s\<^bold>|" unfolding p_def - using take_is_prefix \\<^bold>|s\<^bold>| \ \<^bold>|w\<^bold>|\ take_len by blast+ - hence "p \ s" - using Lyndon_unbordered[OF \Lyndon w\] \s \ns w\ \s \ w\ assms + using take_is_prefix \\<^bold>|s\<^bold>| \ \<^bold>|w\<^bold>|\ take_len by blast+ + hence "p \ s" + using Lyndon_unbordered[OF \Lyndon w\] \s \ns w\ \s \ w\ assms by auto define p' s' where "p' = drop \<^bold>|s\<^bold>| w" and "s' = take \<^bold>|p'\<^bold>| w" - have "p \ p' = w" + have "p \ p' = w" unfolding p'_def p_def s'_def by simp have "s' \ s = w" unfolding p'_def p_def s'_def using suf_len[OF nsD[OF \s \ns w\]] nsD[OF \s \ns w\] - length_drop suffix_take by metis + length_drop suffix_take by metis have "\<^bold>|p'\<^bold>| = \<^bold>|s'\<^bold>|" - using s'_def \p\p' = w\ by auto + using s'_def \p\p' = w\ by auto have "w s'" - using Lyndon_conj_greater[of s' s, unfolded \s' \ s = w\, OF \Lyndon w\] \p \ s\ + using Lyndon_conj_greater[of s' s, unfolded \s' \ s = w\, OF \Lyndon w\] \p \ s\ unfolding \s' \ s = w\ p_def using \s' \ s = w\ assms(3) by fastforce from lexord_suf_linorder[OF _ \p \ s\ \\<^bold>|p\<^bold>| = \<^bold>|s\<^bold>|\ \\<^bold>|p'\<^bold>| = \<^bold>|s'\<^bold>|\, OF this[folded \p \ p' = w\]] have "p , unfolded \p \ p' = w\] \\<^bold>|p\<^bold>| = \<^bold>|s\<^bold>|\ show "w p w" "s \ns w" "s \ w" shows "p w" show "p p \ w\ assms(2) lexordp_append_rightI - by (fastforce simp add: prefix_def) + by (fastforce simp add: prefix_def) show "w \" and "\s. (s \ns w \ s \ w \ w primitive w" obtain q k where "q \ \" "1 < k" "q\<^sup>@k=w" "w\q" \ \the exact match of @{thm non_prim} fastens the proof considerably\ using non_prim[OF \\ primitive w\ \w \ \\] by blast hence "q \ns w" 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

1 < k\ \q \<^sup>@ k = w\ + using \1 < k\ \q \<^sup>@ k = w\ unfolding pow_eq_if_list[of q k] pow_eq_if_list[of q "k-1"] using \w \ \\ by auto - from lexordp_append_rightI[of "q\\<^sup>>w" q, + from lexordp_append_rightI[of "q\\<^sup>>w" q, unfolded lq_pref[OF sprefD1[OF this]], OF lq_spref[OF this]] have "q q \ns w\ \w \ \\ assms(2) rlex.order.strict_trans by blast -next +next assume "primitive w" - have "w |w\<^bold>|" for l + have "w |w\<^bold>|" for l proof- have "take l w \np w" and "\<^bold>|take l w\<^bold>| = l" using assms_l take_is_prefix \l < \<^bold>|w\<^bold>|\ by auto - have "drop l w \ns w" + have "drop l w \ns w" using \l < \<^bold>|w\<^bold>|\ suffix_drop by auto have "drop l w \ w" using append_take_drop_id[of l w] npD'[OF \take l w \np w\] by force have "drop l w \ take l w = rotate l w" - using rotate_append[of "take l w" "drop l w", symmetric, unfolded \\<^bold>|take l w\<^bold>| = l\, + using rotate_append[of "take l w" "drop l w", symmetric, unfolded \\<^bold>|take l w\<^bold>| = l\, unfolded append_take_drop_id]. have "w drop l w \ns w\ \drop l w \ w\ assms(2) by blast from lexord_app_right_linorder[OF this suffix_length_le[OF conjunct2[OF \drop l w \ns w\[unfolded nonempty_suffix_def]]], of \ "take l w", unfolded append.right_neutral] have "w take l w". thus "w drop l w \ take l w = rotate l w\) qed thus "Lyndon w" by (simp add: \w \ \\ local.LyndonI) qed corollary Lyndon_suf_char: "w \ \ \ Lyndon w \ (\s. s \ns w \ s \ w \ w s \ns w \ w \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\v) \ u \ \ \ \ bordered u \ Lyndon u" unfolding Lyndon_suf_char proof(standard+) fix s assume "Lyndon (u \ v)" and "u \ \" and "\ bordered u" and "s \ns u" and "s \ u" hence "u \ v v" using Lyndon_suf_less[OF \Lyndon (u \ v)\, of "s \ v"] by auto have "\ s \p u" - using \\ bordered u\ \s \ns u\ \s \ u\ by auto + using \\ bordered u\ \s \ns u\ \s \ u\ by auto moreover have "\ u \p s" using suf_pref_eq[OF nsD[OF\s \ns u\]] \s \ u\ by blast ultimately show "u u \ v v\] by blast qed section "Concatenation of Lyndon words" theorem Lyndon_concat: assumes "Lyndon u" and "Lyndon v" and "u v)" proof- have "u\v p v") assume "u \p v" obtain z where "u\z = v" and "z \ns v" using lq_pref[OF \u \p v\] nsI' rlex.less_imp_neq[OF \u ] self_append_conv by metis from Lyndon_suf_less[OF \Lyndon v\ this(2), THEN lexord_append_leftI_linorder, of u] LyndonD_nemp[OF \Lyndon u\] this(1) show ?thesis by blast next assume "\ u \p v" then show ?thesis - using local.lexordp_linear[of v "u\v"] + using local.lexordp_linear[of v "u\v"] local.lexordp_mid_pref[OF \u ,of v] prefixI[of v u v] by argo qed { fix z assume "z \ns (u\v)" "z \ u\v" have "u\v ns v") assume "z \ns v" from Lyndon_suf_less[OF \Lyndon v\ this] have "z \ v \ v v u \ v rlex.less_trans by fast next assume "\ z \ns v" then obtain z' where "z' \ns u" "z' \ u" "z'\v = z" using \z \ns u \ v\ \z \ u \ v\ suffix_append[of z u v] unfolding nonempty_suffix_def by force from Lyndon_suf_less[OF \Lyndon u\ this(1) this(2)] have "u v z' \ns u\ lexord_app_right_linorder[of u z' v v] suffix_length_le[of z' u] unfolding nonempty_suffix_def \z' \ v = z\ by blast qed } thus ?thesis using suf_nemp[OF LyndonD_nemp[OF \Lyndon v\], of u, THEN suf_less_Lyndon] by blast qed section "Longest Lyndon suffix" fun longest_Lyndon_suffix:: "'a list \ 'a list" ("LynSuf") where "longest_Lyndon_suffix \ = \" | "longest_Lyndon_suffix (a#w) = (if Lyndon (a#w) then a#w else longest_Lyndon_suffix w)" lemma longest_Lyndon_suf_ext: "\ Lyndon (a # w) \ LynSuf w = LynSuf (a # w)" using longest_Lyndon_suffix.simps(2) by presburger lemma longest_Lyndon_suf_suf: "w \ \ \ LynSuf w \s w" proof(induction w rule: longest_Lyndon_suffix.induct) case 1 - then show ?case by simp + 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: +lemma longest_Lyndon_suf_max: "v \s w \ Lyndon v \ v \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 + 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 \ 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 qed -lemma longest_Lyndon_suf_Lyndon_id: assumes "Lyndon w" +lemma longest_Lyndon_suf_Lyndon_id: assumes "Lyndon w" shows "LynSuf w = w" proof(cases "w = \", simp) case False from longest_Lyndon_suf_suf[OF this] suffix_order.order_refl[THEN longest_Lyndon_suf_max[OF _ assms]] - suffix_order.antisym + suffix_order.antisym show ?thesis by blast qed lemma longest_Lyndon_suf_longest: "w \ \ \ v' \s w \ Lyndon v' \ \<^bold>|v'\<^bold>| \ \<^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 \ \ \ 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 +qed lemma longest_Lyndon_suf_nemp: "w \ \ \ LynSuf w \ \" using longest_Lyndon_suf_Lyndon[THEN LyndonD_nemp]. lemma longest_Lyndon_sufI: - assumes "q \s w" and "Lyndon q" and all_s: "(\ s. (s \s w \ Lyndon s) \ s \s q)" + assumes "q \s w" and "Lyndon q" and all_s: "(\ s. (s \s w \ Lyndon s) \ s \s q)" shows "LynSuf w = q" proof(cases "w = \") case True then show ?thesis - using assms(1) longest_Lyndon_suffix.simps(1) suffix_bot.extremum_uniqueI by blast + 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 \s w" and "Lyndon q" and all_s: "\ s. (s \s w \ Lyndon s) \ \<^bold>|s\<^bold>| \ \<^bold>|q\<^bold>|" +corollary longest_Lyndon_sufI': + assumes "q \s w" and "Lyndon q" and all_s: "\ s. (s \s w \ Lyndon s) \ \<^bold>|s\<^bold>| \ \<^bold>|q\<^bold>|" shows "LynSuf w = q" using longest_Lyndon_sufI[OF \q \s w\ \Lyndon q\] suf_ruler_le all_s \q \s w\ by blast text\The next lemma is fabricated to suit the upcoming definition of longest Lyndon factorization.\ -lemma longest_Lyndon_suf_shorter: assumes "w \ \" +lemma longest_Lyndon_suf_shorter: assumes "w \ \" shows "\<^bold>|w\<^sup><\(LynSuf w)\<^bold>| < \<^bold>|w\<^bold>|" - using nemp_len[OF longest_Lyndon_suf_nemp[OF \w \ \\]] arg_cong[OF rq_suf[OF longest_Lyndon_suf_suf[OF \w \ \\]], of length] - unfolding lenmorph by linarith + using nemp_len[OF longest_Lyndon_suf_nemp[OF \w \ \\]] arg_cong[OF rq_suf[OF longest_Lyndon_suf_suf[OF \w \ \\]], of length] + unfolding lenmorph by linarith section "Lyndon factorizations" function Lyndon_fac::"'a list \ 'a list list" ("LynFac") where "Lyndon_fac w = (if w \ \ then ((Lyndon_fac (w \<^sup><\(LynSuf w) )) \ [LynSuf w]) else \)" using longest_Lyndon_suffix.cases by blast+ termination proof(relation "measure length", simp) show "\w. w \ \ \ (w\<^sup><\LynSuf w, w) \ measure length" unfolding measure_def inv_image_def using longest_Lyndon_suf_shorter by blast qed -text\The factorization @{term "Lyndon_fac w"} obtained by taking always the longest Lyndon suffix is well defined, +text\The factorization @{term "Lyndon_fac w"} obtained by taking always the longest Lyndon suffix is well defined, and called ``Lyndon factorization (of $w$)''.\ lemma Lyndon_fac_simp: "w \ \ \ Lyndon_fac w = Lyndon_fac (w\<^sup><\LynSuf w) \ (LynSuf w # \)" using Lyndon_fac.simps[of w] by meson lemma Lyndon_fac_emp: "Lyndon_fac \ = \" by simp text\Note that the Lyndon factorization of a Lyndon word is trivial.\ lemma Lyndon_fac_longest_Lyndon_id: "Lyndon w \ Lyndon_fac w = [w]" - by (simp add: longest_Lyndon_suf_Lyndon_id) + by (simp add: longest_Lyndon_suf_Lyndon_id) text\Lyndon factorization is composed of Lyndon words ...\ lemma Lyndon_fac_set: "z \ set (Lyndon_fac w) \ Lyndon z" proof(induction w rule: Lyndon_fac.induct) case (1 w) then show "Lyndon z" proof (cases "w = \") assume "w \ \" have "Lyndon_fac w = (Lyndon_fac (w \<^sup><\(LynSuf w) )) \ [LynSuf w]" using Lyndon_fac_simp[OF \w \ \\]. from set_ConsD[OF "1.prems"(1)[unfolded rotate1.simps(2)[of "LynSuf w" "Lyndon_fac (w \<^sup><\(LynSuf w) )", folded this, symmetric], unfolded set_rotate1]] have "z = LynSuf w \ z \ set (Lyndon_fac (w \<^sup><\(LynSuf w) ))". thus "Lyndon z" using "1.IH"[OF \w \ \\] longest_Lyndon_suf_Lyndon[OF \w \ \\] by blast next assume "w = \" thus "Lyndon z" using "1.prems" unfolding Lyndon_fac_emp[folded \w = \\] list.set(1) empty_iff by blast qed qed text\...and it indeed is a factorization of the argument.\ 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 = \", simp) assume "w \ \" have eq: "concat (Lyndon_fac w) = concat ( (Lyndon_fac (w \<^sup><\(LynSuf w) )) ) \ concat ([LynSuf w])" unfolding Lyndon_fac_simp[OF \w \ \\] concat_morph.. from this[unfolded "1.IH"[OF \w \ \\] concat_sing' rq_suf[OF longest_Lyndon_suf_suf[OF \w \ \\]]] show ?case. qed qed text\The following lemma makes explicit the inductive character of the definition of @{term Lyndon_fac}.\ lemma Lyndon_fac_longest_pref: "us \p Lyndon_fac w \ 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 = \", simp) assume "w \ \" have step: "Lyndon_fac w = (Lyndon_fac (w \<^sup><\(LynSuf w))) \ [LynSuf w]" using Lyndon_fac_simp[OF \w \ \\]. consider (neq) "us \ 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 \p Lyndon_fac (w\<^sup><\LynSuf w)" - using "1.prems" last_no_split[of us "Lyndon_fac (w\<^sup><\LynSuf w)" "LynSuf w"] + using "1.prems" last_no_split[of us "Lyndon_fac (w\<^sup><\LynSuf w)" "LynSuf w"] unfolding step[symmetric] by blast thus "LynFac (concat us) = us" - using "1.IH" \w \ \\ by blast + using "1.IH" \w \ \\ 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\We give name to an important predicate: monotone (nonincreasing) list of Lyndon words.\ definition Lyndon_mono :: "'a list list \ bool" where "Lyndon_mono ws \ (\ u \ set ws. Lyndon u) \ (rlex.sorted (rev ws))" lemma Lyndon_mono_set: "Lyndon_mono ws \ u \ set ws \ Lyndon u" unfolding Lyndon_mono_def by blast lemma Lyndon_mono_sorted: "Lyndon_mono ws \ rlex.sorted (rev ws)" unfolding Lyndon_mono_def by blast lemma Lyndon_mono_nth: "Lyndon_mono ws \ i \ j \ j < \<^bold>|ws\<^bold>| \ ws!j \lex ws!i" unfolding Lyndon_mono_def using rlex.sorted_rev_nth_mono by blast lemma Lyndon_mono_empty[simp]: "Lyndon_mono \" unfolding Lyndon_mono_def by auto lemma Lyndon_mono_sing: "Lyndon u \ Lyndon_mono [u]" unfolding Lyndon_mono_def by auto -lemma Lyndon_mono_fac_Lyndon_mono: - assumes "ps \f ws" and "Lyndon_mono ws" shows "Lyndon_mono ps" +lemma Lyndon_mono_fac_Lyndon_mono: + assumes "ps \f ws" and "Lyndon_mono ws" shows "Lyndon_mono ps" unfolding Lyndon_mono_def proof - show "\x \ (set ps). Lyndon x" + show "\x \ (set ps). Lyndon x" using \Lyndon_mono ws\[unfolded Lyndon_mono_def] set_mono_sublist[OF \ps \f ws\] by blast show "linorder.sorted (\lex) (rev ps)" using rlex.sorted_append \Lyndon_mono ws\[unfolded Lyndon_mono_def] \ps \f ws\[unfolded sublist_def] by fastforce qed -text\Lyndon factorization is monotone! -Altogether, we have shown that the Lyndon factorization is a monotone factorization +text\Lyndon factorization is monotone! +Altogether, we have shown that the Lyndon factorization is a monotone factorization into Lyndon words.\ 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 \ [x]) = w" using Lyndon_fac_longest_dec[of w, folded snoc.hyps(2)] by auto then show "Lyndon_mono (LynFac w)" proof (cases "xs = \") assume "xs = \" show "Lyndon_mono (LynFac w)" - unfolding Lyndon_mono_def \xs \ [x] = LynFac w\[symmetric] \xs = \\ append.left_neutral - rlex.sorted1[of x] + unfolding Lyndon_mono_def \xs \ [x] = LynFac w\[symmetric] \xs = \\ append.left_neutral + rlex.sorted1[of x] using \Lyndon x\ by force next assume "xs \ \" have "concat (xs \ [x]) \ \" and "w \ \" using Lyndon_fac_longest_dec snoc.hyps(2) by auto - have "x = LynSuf w" and "xs = LynFac (w\<^sup><\LynSuf w )" + have "x = LynSuf w" and "xs = LynFac (w\<^sup><\LynSuf w )" using Lyndon_fac.simps[of w, folded snoc.hyps(2)] \w \ \\ - Lyndon_fac_longest_dec append1_eq_conv[of xs x "LynFac (w\<^sup><\LynSuf w )" "LynSuf w"] by presburger+ + Lyndon_fac_longest_dec append1_eq_conv[of xs x "LynFac (w\<^sup><\LynSuf w )" "LynSuf w"] by presburger+ from Lyndon_mono_sorted[OF snoc.hyps(1)[OF \xs = LynFac (w\<^sup><\LynSuf w )\], 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><\LynSuf w", folded \xs = LynFac (w\<^sup><\LynSuf w)\, OF last_in_set[OF \xs \ \\]]. have "x \lex last xs" proof(rule ccontr) assume "\ x \lex last xs" hence "last xs Lyndon (last xs)\ \Lyndon x\ this] have "Lyndon ((last xs) \ x)". have "(last xs) \ x \s concat (xs \ [x])" using \xs \ \\ concat_last_suf by auto - from longest_Lyndon_suf_longest[OF \concat (xs \ [x]) \ \\ this \Lyndon ((last xs) \ x)\, + from longest_Lyndon_suf_longest[OF \concat (xs \ [x]) \ \\ this \Lyndon ((last xs) \ x)\, unfolded \concat (xs \ [x]) = w\, folded \x = LynSuf w\] show False - using \Lyndon (last xs)\ by simp - qed + using \Lyndon (last xs)\ by simp + qed have "dual_rlex.sorted (butlast xs \ [last xs])" by (simp add: \linorder.sorted (\x y. y \lex x) xs\ \xs \ \\) from this \x \lex last xs\ have "dual_rlex.sorted (butlast xs \ [last xs,x])" - using dual_rlex.sorted_append by auto + using dual_rlex.sorted_append by auto from this[unfolded hd_word[of "last xs" "[x]"] lassoc append_butlast_last_id[OF \xs \ \\]] have "rlex.sorted (rev (LynFac w))" unfolding \xs \ [x] = LynFac w\[symmetric] sorted_dual_rev_iff[symmetric]. thus "Lyndon_mono (LynFac w)" unfolding Lyndon_mono_def using Lyndon_fac_set by blast qed qed text\Now we want to show the converse: any monotone factorization into Lyndon words is the Lyndon factorization\ text\The last element in the Lyndon factorization is the smallest suffix.\ lemma Lyndon_mono_last_smallest: "Lyndon_mono ws \s \ns (concat ws) \ last ws \lex s" proof(induct ws arbitrary: s rule: rev_induct, fastforce) case (snoc a ws) have "ws\[a] \ \" by blast have "last (ws\[a]) = a" by simp from last_in_set[OF \ws\[a] \ \\, unfolded this] \Lyndon_mono (ws \ [a])\[unfolded Lyndon_mono_def] have "Lyndon a" by blast show ?case proof(cases "s \ns a") case True from Lyndon_suf_le[OF \Lyndon a\] this show ?thesis by simp next case False hence "ws \ \" using snoc.prems(2) by force obtain s' where "s = s'\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' \ns concat ws" using False snoc.prems(2) by fastforce have "Lyndon_mono ws" using \Lyndon_mono (ws\[a])\ Lyndon_mono_fac_Lyndon_mono by blast from snoc.hyps[OF this \s' \ns concat ws\] - have "last ws \lex s'" + have "last ws \lex s'" by auto hence "last ws \lex s'\a" using local.lexordp_eq_trans ord.lexordp_eq_pref by blast have "a \lex last ws" using \Lyndon_mono (ws\[a])\ unfolding Lyndon_mono_def by (simp add: \ws \ \\ last_ConsL) from dual_rlex.order_trans[OF \last ws \lex s' \ a\ this, folded \s = s' \ a\] show ?thesis unfolding \last (ws\[a]) = a\ by blast qed qed text\A monotone list, if seen as a factorization, must end with the longest suffix\ -lemma Lyndon_mono_last_longest: assumes "ws \ \" and "Lyndon_mono ws" +lemma Lyndon_mono_last_longest: assumes "ws \ \" 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 \ \" using LyndonD_nemp by blast hence "last ws \ns LynSuf (concat ws)" using longest_Lyndon_suf_max[OF concat_last_suf[OF assms(1)] \Lyndon (last ws)\] unfolding nonempty_suffix_def by blast have "concat ws \ \" 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) \ns concat ws" unfolding nonempty_suffix_def by simp - + show ?thesis using Lyndon_mono_last_smallest[OF \Lyndon_mono ws\ \LynSuf (concat ws) \ns concat ws\] Lyndon_suf_le[OF longest_Lyndon_suf_Lyndon[OF \concat ws \ \\], OF \last ws \ns LynSuf (concat ws)\] eq_iff by simp qed -text\Therefore, by construction, +text\Therefore, by construction, any monotone list is the Lyndon factorization of its concatenation\ lemma Lyndon_mono_fac: "Lyndon_mono ws \ ws = Lyndon_fac (concat ws)" proof (induct ws rule: rev_induct, simp) case (snoc x xs) have "Lyndon_mono xs" - using \Lyndon_mono (xs \ [x])\ + using \Lyndon_mono (xs \ [x])\ unfolding Lyndon_mono_def - by simp + by simp from snoc.hyps[OF this] have "xs = LynFac (concat xs)". have "x = LynSuf (concat (xs \ [x]))" using Lyndon_mono_last_longest[OF _ \Lyndon_mono (xs \ [x])\, unfolded last_snoc] by simp have "concat (xs \ [x])\<^sup><\x = concat xs" by simp have "concat (xs \ [x]) \ \" using Lyndon_mono_set snoc.prems by auto from this show ?case using Lyndon_fac.simps[of "concat (xs \ [x])", folded \x = LynSuf (concat (xs \ [x]))\, - unfolded \concat (xs \ [x])\<^sup><\x = concat xs\, folded \xs = LynFac (concat xs)\] + unfolded \concat (xs \ [x])\<^sup><\x = concat xs\, folded \xs = LynFac (concat xs)\] by presburger qed text\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). \ corollary Lyndon_mono_fac_iff: "Lyndon_mono ws \ 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" +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 \Lyndon_mono ws\] Lyndon_mono_fac[OF \Lyndon_mono zs\] + using Lyndon_mono_fac[OF \Lyndon_mono ws\] Lyndon_mono_fac[OF \Lyndon_mono zs\] unfolding \concat ws = concat zs\ by simp subsection "Standard factorization" lemma Lyndon_std: assumes "Lyndon w" "1 < \<^bold>|w\<^bold>|" obtains l m where "w = l\m" and "Lyndon l" and "Lyndon m" and "l \" "tl w \ \" using \1 < \<^bold>|w\<^bold>|\ long_list_tl by auto define m where "m = LynSuf (tl w)" hence "Lyndon m" using \tl w \ \\ local.longest_Lyndon_suf_Lyndon by blast have "m \s w" - unfolding m_def - using suffix_order.trans[OF longest_Lyndon_suf_suf[OF \tl w \ \\] suffix_tl[of w]]. + unfolding m_def + using suffix_order.trans[OF longest_Lyndon_suf_suf[OF \tl w \ \\] suffix_tl[of w]]. moreover have "m \ w" unfolding m_def using hd_tl[OF \w \ \\] longest_Lyndon_suf_suf[OF \tl w \ \\] same_suffix_nil not_Cons_self2 by metis ultimately obtain l where "w = l\m" and "l \ \" - by (auto simp add: suf_def) + by (auto simp add: suffix_def) have "Lyndon l" proof (rule unbordered_pref_Lyndon[OF \Lyndon w\[unfolded \w = l\m\] \l \ \\], rule) assume "bordered l" from unbordered_border[OF this, unfolded border_def] obtain s where "s \ \" and "s \ l" and "s \p l" and "s \s l" and "\ bordered s" - by blast - have "Lyndon s" + by blast + have "Lyndon s" using unbordered_pref_Lyndon[OF _ \s \ \\ \\ bordered s\, of "s\\<^sup>>l\m", unfolded lassoc lq_pref[OF \s \p l\]] \Lyndon w\[unfolded \w = l \ m\] by blast have "s Lyndon w\ _ nsI[OF LyndonD_nemp[OF \Lyndon m\] \m \s w\] - \m \ w\, of s] Lyndon.elims(2)[OF \Lyndon m\] + using Lyndon_pref_suf_less[OF \Lyndon w\ _ nsI[OF LyndonD_nemp[OF \Lyndon m\] \m \s w\] + \m \ w\, of s] Lyndon.elims(2)[OF \Lyndon m\] \s \p l\ prefix_append[of s l m, folded \w = l \ m\] by presburger from Lyndon_concat[OF \Lyndon s\ \Lyndon m\ this] have "Lyndon (s\m)". - moreover have "s\m \s tl w" + moreover have "s\m \s tl w" unfolding \w = l \ m\ using \s \ l\ \s \s l\ list.collapse[OF \w \ \\, unfolded \w = l \ m\] - by (auto simp add: suf_def) + by (auto simp add: suffix_def) ultimately show False using m_def \s \ \\ longest_Lyndon_suf_max same_suffix_nil by blast qed have "l Lyndon w\ prefI[OF \w = l \ m\[symmetric]] + using Lyndon_pref_suf_less[OF \Lyndon w\ prefI[OF \w = l \ m\[symmetric]] nsI[OF longest_Lyndon_suf_nemp[OF \tl w \ \\, folded m_def] \m \s w\] \m \ w\]. from that[OF \w = l \ m\ \Lyndon l\ \Lyndon m\ this] show thesis. qed -corollary Lyndon_std_iff: - "Lyndon w \ (\<^bold>|w\<^bold>| = 1 \ (\ l m. w = l\m \ Lyndon l \ Lyndon m \ l (\<^bold>|w\<^bold>| = 1 \ (\ l m. w = l\m \ Lyndon l \ Lyndon m \ l ?R") proof assume ?L show ?R - using Lyndon_std[OF \Lyndon w\] + using Lyndon_std[OF \Lyndon w\] nemp_le_len[OF LyndonD_nemp[OF \Lyndon w\], unfolded le_eq_less_or_eq] by metis next assume ?R thus ?L proof(rule disjE, fastforce) - show \\l m. w = l \ m \ Lyndon l \ Lyndon m \ l Lyndon w\ + show \\l m. w = l \ m \ Lyndon l \ Lyndon m \ l Lyndon w\ using Lyndon_concat by blast qed qed end \ \end context linorder\ 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,108 +1,108 @@ -(* Title: CoW_Lyndon.Lyndon_Addition +(* Title: Combinatorics_Words_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 \We define the minimal relation which guarantees the lexicographic minimality of w compared to its +text \We define the minimal relation which guarantees the lexicographic minimality of w compared to its nontrivial conjugates.\ inductive_set rotate_rel :: "'a list \ 'a rel" for w where "0 < n \ n < \<^bold>|w\<^bold>| \ (mismatch_pair w (rotate n w)) \ rotate_rel w" text\A word is Lyndon iff the corresponding order of letters is compatible with @{term "rotate_rel w"}.\ lemma (in linorder) rotate_rel_iff: assumes "w \ \" shows "Lyndon w \ rotate_rel w \ {(x,y). x < y}" (is "?L \ ?R") proof assume "Lyndon w" show "rotate_rel w \ {(x,y). x < y}" proof fix x assume "x \ 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 Lyndon w\ \0 < n\ \n < \<^bold>|w\<^bold>|\]. - from this[unfolded lexordp_conv_lexord] + have "w Lyndon w\ \0 < n\ \n < \<^bold>|w\<^bold>|\]. + from this[unfolded lexordp_conv_lexord] prim_no_rotate[OF Lyndon_prim[OF \Lyndon w\] \0 < n\ \n < \<^bold>|w\<^bold>|\] - show "x \ {(a, b). a < b}" + show "x \ {(a, b). a < b}" using lexord_mismatch[of w "rotate n w" "{(a,b). a < b}", folded \x = mismatch_pair w (rotate n w)\] - \rotate n w \ w\ rotate_comp_eq[of w n] + \rotate n w \ w\ rotate_comp_eq[of w n] unfolding irrefl_def by blast qed next - assume "?R" + assume "?R" show "?L" unfolding Lyndon.simps proof(simp add: assms) - have "w |w\<^bold>|" for n + have "w |w\<^bold>|" for n proof- - have "\ w \ rotate n w" + have "\ w \ rotate n w" using rotate_comp_eq[of w n] subsetD[OF \?R\, OF rotate_rel.intros[OF \0 < n\ \n < \<^bold>|w\<^bold>|\]] mismatch_pair_lcp[of w "rotate n w"] by fastforce from mismatch_lexord_linorder[OF this subsetD[OF \?R\, OF rotate_rel.intros[OF \0 < n\ \n < \<^bold>|w\<^bold>|\]]] show "w n. 0 < n \ n < \<^bold>|w\<^bold>| \ w n. 0 < n \ n < \<^bold>|w\<^bold>| \ w 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. \ lemma Lyndon_rotate_rel_iff: "acyclic (rotate_rel w) \ (\ r. strict_linear_order r \ rotate_rel w \ r)" (is "?L \ ?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 \ class.linorder (\ a b. (a,b) \ r\<^sup>=) (\ a b. (a,b) \ r)" unfolding strict_linear_order_on_def strict_partial_order_def irrefl_def trans_def total_on_def by unfold_locales blast+ text\Application examples\ lemma assumes "w \ \" and "acyclic (rotate_rel w)" shows "primitive w" proof- obtain r where "strict_linear_order r" and "rotate_rel w \ r" - using Lyndon_rotate_rel_iff assms by auto + using Lyndon_rotate_rel_iff assms by blast - interpret r: linorder "\ a b. (a,b) \ r\<^sup>=" "\ a b. (a,b) \ r" - using slo_linorder[OF \strict_linear_order r\]. + interpret r: linorder "\ a b. (a,b) \ r\<^sup>=" "\ a b. (a,b) \ r" + using slo_linorder[OF \strict_linear_order r\]. have "r.Lyndon w" using r.rotate_rel_iff[OF \w \ \\] \rotate_rel w \ r\ by blast from r.Lyndon_prim[OF this] show "primitive w". qed lemma assumes "w \ \" and "acyclic (rotate_rel w)" shows "\ bordered w" proof- obtain r where "strict_linear_order r" and "rotate_rel w \ r" - using Lyndon_rotate_rel_iff assms by auto + using Lyndon_rotate_rel_iff assms by blast - interpret r: linorder "\ a b. (a,b) \ r\<^sup>=" "\ a b. (a,b) \ r" - using slo_linorder[OF \strict_linear_order r\]. + interpret r: linorder "\ a b. (a,b) \ r\<^sup>=" "\ a b. (a,b) \ r" + using slo_linorder[OF \strict_linear_order r\]. have "r.Lyndon w" using r.rotate_rel_iff[OF \w \ \\] \rotate_rel w \ r\ by blast from r.Lyndon_unbordered[OF this] show "\ bordered w". qed -end \ No newline at end of file +end diff --git a/thys/Two_Generated_Word_Monoids_Intersection/Two_Generated_Word_Monoids_Intersection.thy b/thys/Two_Generated_Word_Monoids_Intersection/Two_Generated_Word_Monoids_Intersection.thy --- a/thys/Two_Generated_Word_Monoids_Intersection/Two_Generated_Word_Monoids_Intersection.thy +++ b/thys/Two_Generated_Word_Monoids_Intersection/Two_Generated_Word_Monoids_Intersection.thy @@ -1,1424 +1,1411 @@ (* Title: Two Generated Word Monoids_Intersection File: Two_Generated_Word_Monoids_Intersection.Two_Generated_Word_Monoids_Intersection 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 Two_Generated_Word_Monoids_Intersection - imports - Combinatorics_Words.Equations_Basic - Combinatorics_Words.Binary_Code_Morphisms - Combinatorics_Words_Graph_Lemma.Glued_Codes + imports Combinatorics_Words.Equations_Basic Combinatorics_Words.Binary_Code_Morphisms Combinatorics_Words_Graph_Lemma.Glued_Codes begin text \The characterization of intersection of binary languages formalized here is due to @{cite Ka_intersections}.\ chapter "Binary Intersection Formalized" -locale binary_codes_coincidence = two_binary_code_morphisms + - assumes alphas_len: "\<^bold>|\\<^sub>h\<^bold>| \ \<^bold>|\\<^sub>g\<^bold>|" and - coin_ex: "\ r s. g r =\<^sub>m h s" -begin - -lemma alphas_pref: "\\<^sub>h \p \\<^sub>g" - using alphas_pref[OF alphas_len] coin_ex by force - -definition \ where "\ \ \\<^sub>h\\<^sup>>\\<^sub>g" -definition critical_overflow ("\") where "critical_overflow \ \\<^sub>g\<^sup><\\\<^sub>h" - -lemma lcp_diff: "\\<^sub>h \ \ = \\<^sub>g" - unfolding \_def lq_pref using lq_pref[OF alphas_pref]. - -lemma solution_marked_version_conv: "g r = h s \ \ \ g\<^sub>m r = h\<^sub>m s \ \ " - unfolding cancel[of \\<^sub>h "\ \ g\<^sub>m r" "h\<^sub>m s \ \", symmetric] - unfolding lassoc lcp_diff h.marked_version_conjugates g.marked_version_conjugates - unfolding rassoc lcp_diff cancel_right.. - -end - -locale binary_codes_coincidence_two_generators = binary_codes_coincidence + +locale binary_codes_coincidence_two_generators = binary_codes_coincidence + assumes two_coins: "\ r s r' s'. g r =\<^sub>m h s \ g r' =\<^sub>m h s' \ (r,s) \ (r',s')" begin lemma criticalE': obtains p q r1 s1 r2 s2 where "g p \ \\<^sub>g = h q \ \\<^sub>h" and "g (p \ r1) = h (q \ s1)" and "g (p \ r2) = h (q \ s2)" and - "r1 \ \" and "r2 \ \" and + "r1 \ \" and "r2 \ \" and "hd r1 \ hd r2" proof- - obtain r s r' s' where "g r =\<^sub>m h s" and "g r' =\<^sub>m h s'" and "(r,s) \ (r',s')" + obtain r s r' s' where "g r =\<^sub>m h s" and "g r' =\<^sub>m h s'" and "(r,s) \ (r',s')" using two_coins by blast note eqs = min_coinD[OF \g r =\<^sub>m h s\] min_coinD[OF \g r' =\<^sub>m h s'\] have "s \ s' \ s' \ s" - proof + proof assume "s \ s' = s' \ s" from arg_cong[OF this, of h] have "g (r \ r') = g (r' \ r)" unfolding g.morph h.morph using \g r = h s\ \g r' = h s'\ by argo from g.code_morph_code[OF this] have "r \ r' = r' \ r". - from ruler_eq[OF \r \ r' = r' \ r\] ruler_eq[OF \s \ s' = s' \ s\] + from ruler_eq[OF \r \ r' = r' \ r\] ruler_eq[OF \s \ s' = s' \ s\] have "s \p s' \ r \p r'" and "s' \p s \ r' \p r" - using \g r = h s\ \g r' = h s'\ g.pref_morph_pref_eq h.pref_mono by metis+ + using \g r = h s\ \g r' = h s'\ g.pref_morph_pref_eq h.pref_mono by metis+ hence "(r, s) = (r', s')" - using \s \p s' \ s' \p s\ \g r =\<^sub>m h s\ \g r' =\<^sub>m h s'\ npI + using \s \p s' \ s' \p s\ \g r =\<^sub>m h s\ \g r' =\<^sub>m h s'\ npI unfolding min_coin_def by metis thus False using \(r, s) \ (r', s')\ by blast qed hence "h (s \ s') \ \\<^sub>h \ h (s' \ s) \ \\<^sub>h" unfolding cancel_right using h.code_morph_code by blast hence "\ h (s \ s') \ \\<^sub>h \ h (s' \ s) \ \\<^sub>h" unfolding h.morph using comm_comp_eq_conv comp_prefs_comp by metis hence h\<^sub>m: "h (s \ s') \ \\<^sub>h \ \ \\<^sub>p h(s' \ s) \ \\<^sub>h \ \ = h (s \ s' \\<^sub>p s' \ s) \ \\<^sub>h" - using lcp_ext_right_conv[of "h (s \ s') \ \\<^sub>h" "h (s' \ s) \ \\<^sub>h" "\" "\"] - h.bin_code_lcp[symmetric] unfolding h.bin_code_lcp[symmetric] rassoc by blast + using lcp_ext_right_conv[of "h (s \ s') \ \\<^sub>h" "h (s' \ s) \ \\<^sub>h" "\" "\"] + h.bin_code_lcp[symmetric] unfolding h.bin_code_lcp[symmetric] rassoc by blast let ?p = "r \ r' \\<^sub>p r' \ r" let ?q = "s \ s' \\<^sub>p s' \ s" let ?r1 = "?p\\<^sup>>(r \ r')" let ?r2 = "?p\\<^sup>>(r' \ r)" let ?s1 = "?q\\<^sup>>(s \ s')" let ?s2 = "?q\\<^sup>>(s' \ s)" from eqs - have "g (r \ r') \ \\<^sub>g = h (s \ s') \ \\<^sub>h \ \" and + have "g (r \ r') \ \\<^sub>g = h (s \ s') \ \\<^sub>h \ \" and "g (r' \ r) \ \\<^sub>g = h (s' \ s) \ \\<^sub>h \ \" - unfolding g.morph h.morph lcp_diff cancel_right by auto + unfolding g.morph h.morph lcp_diff cancel_right by auto hence "g ?p \ \\<^sub>g = h ?q \ \\<^sub>h" unfolding g.bin_code_lcp[symmetric] h\<^sub>m[symmetric] by argo - have "g (?p \ ?r1) = h (?q \ ?s1)" + have "g (?p \ ?r1) = h (?q \ ?s1)" unfolding lq_pref[OF lcp_pref] g.morph h.morph \g r = h s\ \g r' = h s'\.. - have "g (?p \ ?r2) = h (?q \ ?s2)" + have "g (?p \ ?r2) = h (?q \ ?s2)" unfolding lq_pref[OF lcp_pref'] g.morph h.morph \g r = h s\ \g r' = h s'\.. have "r \ r' \ r' \ r" proof assume "r \ r' = r' \ r" from arg_cong[OF this, of g] have "h (s \ s') = h (s' \ s)" unfolding g.morph h.morph using \g r = h s\ \g r' = h s'\ by argo from h.code_morph_code[OF this] \s \ s' \ s' \ s\ show False by blast - qed + qed from \r \ r' \ r' \ r\ have "\ r \ r' \ r' \ r" - using comm_comp_eq by blast + using comm_comp_eq by blast - from that[OF \g ?p \ \\<^sub>g = h ?q \ \\<^sub>h\ \g (?p \ ?r1) = h (?q \ ?s1)\ + from that[OF \g ?p \ \\<^sub>g = h ?q \ \\<^sub>h\ \g (?p \ ?r1) = h (?q \ ?s1)\ \g (?p \ ?r2) = h (?q \ ?s2)\] lcp_mismatch_lq[OF \\ r \ r' \ r' \ r\] show thesis by blast qed lemma alphas_suf: "\\<^sub>h \s \\<^sub>g" proof- from criticalE' obtain p q where "g p \ \\<^sub>g = h q \ \\<^sub>h" by meson from eqd[reversed, OF this[symmetric] alphas_len] show "\\<^sub>h \s \\<^sub>g" by blast qed lemma c_def: "\ \ \\<^sub>h = \\<^sub>g" unfolding critical_overflow_def using rq_suf[OF alphas_suf]. lemma marked_version_solution_conv: "g\<^sub>m r = h\<^sub>m s \ g r \ \ = \ \ h s" unfolding cancel_right[of "g r \ \" \\<^sub>h "\ \ h s", symmetric] c_def rassoc g.marked_version_conjugates[symmetric] h.marked_version_conjugates[symmetric] unfolding lassoc c_def cancel.. lemma criticalE: obtains p q r1 s1 r2 s2 where "\\<^sub>g \ g\<^sub>m p = \\<^sub>h \ h\<^sub>m q" and - "\ p' q'. \\<^sub>g \ g\<^sub>m p' = \\<^sub>h \ h\<^sub>m q' \ p \p p' \ q \p q'" and + "\ p' q'. \\<^sub>g \ g\<^sub>m p' = \\<^sub>h \ h\<^sub>m q' \ p \p p' \ q \p q'" and "g\<^sub>m (r1 \ p) = h\<^sub>m (s1 \ q)" and "g\<^sub>m (r2 \ p) = h\<^sub>m (s2 \ q)" and - "r1 \ p \ \" and "r2 \ p \ \" and + "r1 \ p \ \" and "r2 \ p \ \" and "hd (r1 \ p) \ hd (r2 \ p)" proof- from criticalE' obtain p' q' r1 s1 r2 s2 where "g p' \ \\<^sub>g = h q' \ \\<^sub>h" and "g (p' \ r1) = h (q' \ s1)" and "g (p' \ r2) = h (q' \ s2)" and - "r1 \ \" and "r2 \ \" and + "r1 \ \" and "r2 \ \" and "hd r1 \ hd r2". from this(1)[folded g.marked_version_conjugates h.marked_version_conjugates] have "\\<^sub>g \ g\<^sub>m p' = \\<^sub>h \ h\<^sub>m q'". from min_completionE[OF this] obtain p q where "\\<^sub>g \ g\<^sub>m p = \\<^sub>h \ h\<^sub>m q" and "\p' q'. \\<^sub>g \ g\<^sub>m p' = \\<^sub>h \ h\<^sub>m q' \ p \p p' \ q \p q'" by blast show thesis - proof + proof(rule) show "\\<^sub>g \ g\<^sub>m p = \\<^sub>h \ h\<^sub>m q" by fact hence "g p \ \ = h q" unfolding g.marked_version_conjugates h.marked_version_conjugates unfolding c_def[symmetric] lassoc cancel_right. from \g (p' \ r1) = h (q' \ s1)\[unfolded g.morph h.morph] have "g r1 = \ \ h s1" unfolding \g p' \ \\<^sub>g = h q' \ \\<^sub>h\[unfolded c_def[symmetric] lassoc cancel_right, symmetric] rassoc cancel. show "g\<^sub>m (r1 \ p) = h\<^sub>m (s1 \ q)" unfolding marked_version_solution_conv g.morph h.morph rassoc \g p \ \ = h q\ \g r1 = \ \ h s1\.. from \g (p' \ r2) = h (q' \ s2)\[unfolded g.morph h.morph] have "g r2 = \ \ h s2" unfolding \g p' \ \\<^sub>g = h q' \ \\<^sub>h\[unfolded c_def[symmetric] lassoc cancel_right, symmetric] rassoc cancel. show "g\<^sub>m (r2 \ p) = h\<^sub>m (s2 \ q)" unfolding marked_version_solution_conv g.morph h.morph rassoc \g p \ \ = h q\ \g r2 = \ \ h s2\.. - show "r1 \ p \ \" + show "r1 \ p \ \" using \r1 \ \\ by blast show "r2 \ p \ \" using \r2 \ \\ by blast show "hd (r1 \ p) \ hd (r2 \ p)" using \hd r1 \ hd r2\ \r1 \ \\ \r2 \ \\ by simp show " \p' q'. \\<^sub>g \ g\<^sub>m p' = \\<^sub>h \ h\<^sub>m q' \ p \p p' \ q \p q'" by fact qed qed text \Defining the beginning block\ definition beginning_block :: "binA list * binA list" where - "beginning_block = (SOME pair. \\<^sub>g \ g\<^sub>m (fst pair) = \\<^sub>h \ h\<^sub>m (snd pair) \ + "beginning_block = (SOME pair. \\<^sub>g \ g\<^sub>m (fst pair) = \\<^sub>h \ h\<^sub>m (snd pair) \ (\ p' q'. \\<^sub>g \ g\<^sub>m p' = \\<^sub>h \ h\<^sub>m q' \ (fst pair) \p p' \ (snd pair) \p q'))" definition fst_beginning_block ("p") where "fst_beginning_block \ fst beginning_block" definition snd_beginning_block ("q") where "snd_beginning_block \ snd beginning_block" lemma begin_block: "\ \ g\<^sub>m p = h\<^sub>m q" and begin_block_min: "\ \ g\<^sub>m p' = h\<^sub>m q' \ p \p p' \ q \p q'" proof- - from criticalE - obtain pa qa where "\\<^sub>g \ g\<^sub>m pa = \\<^sub>h \ h\<^sub>m qa" and "\p' q'. \\<^sub>g \ g\<^sub>m p' = \\<^sub>h \ h\<^sub>m q' \ pa \p p' \ qa \p q'" by metis + from criticalE + obtain pa qa r1 s1 r2 s2 where + "\\<^sub>g \ g\<^sub>m pa = \\<^sub>h \ h\<^sub>m qa" and + "(\p' q'. \\<^sub>g \ g\<^sub>m p' = \\<^sub>h \ h\<^sub>m q' \ pa \p p' \ qa \p q')" and + "g\<^sub>m (r1 \ pa) = h\<^sub>m (s1 \ qa)" and "g\<^sub>m (r2 \ pa) = h\<^sub>m (s2 \ qa)" and + "r1 \ pa \ \" and "r2 \ pa \ \" and "hd (r1 \ pa) \ hd (r2 \ pa)" by blast hence *: "\\<^sub>g \ g\<^sub>m (fst (pa, qa)) = \\<^sub>h \ h\<^sub>m (snd (pa, qa)) \ (\p' q'. \\<^sub>g \ g\<^sub>m p' = \\<^sub>h \ h\<^sub>m q' \ fst (pa, qa) \p p' \ snd (pa, qa) \p q')" unfolding fst_conv snd_conv by fast - let ?P = "\ pair. (\\<^sub>g \ g\<^sub>m (fst pair) = \\<^sub>h \ h\<^sub>m (snd pair) \ - (\ p' q'. \\<^sub>g \ g\<^sub>m p' = \\<^sub>h \ h\<^sub>m q' \ (fst pair) \p p' \ (snd pair) \p q'))" + let ?P = "\ pair. (\\<^sub>g \ g\<^sub>m (fst pair) = \\<^sub>h \ h\<^sub>m (snd pair) \ + (\ p' q'. \\<^sub>g \ g\<^sub>m p' = \\<^sub>h \ h\<^sub>m q' \ (fst pair) \p p' \ (snd pair) \p q'))" from someI[of ?P, OF *] have pq: "\\<^sub>g \ g\<^sub>m p = \\<^sub>h \ h\<^sub>m q" "\\<^sub>g \ g\<^sub>m p' = \\<^sub>h \ h\<^sub>m q' \ p \p p' \ q \p q'" - unfolding fst_beginning_block_def snd_beginning_block_def beginning_block_def by fast+ + unfolding fst_beginning_block_def snd_beginning_block_def beginning_block_def + by blast+ show "\ \ g\<^sub>m p = h\<^sub>m q" and "\ \ g\<^sub>m p' = h\<^sub>m q' \ p \p p' \ q \p q'" - using pq unfolding lcp_diff[symmetric] rassoc cancel. + using pq unfolding lcp_diff[symmetric] rassoc cancel. qed lemma begin_block_conjug_conv: assumes "r \ p = p \ r'" and "s \ q = q \ s'" shows "g r = h s \ g\<^sub>m r' = h\<^sub>m s'" unfolding solution_marked_version_conv proof- - have "\ \ g\<^sub>m r = h\<^sub>m s \ \ \ \ \ g\<^sub>m r \ g\<^sub>m p = h\<^sub>m s \ \ \ g\<^sub>m p" + have "\ \ g\<^sub>m r = h\<^sub>m s \ \ \ \ \ g\<^sub>m r \ g\<^sub>m p = h\<^sub>m s \ \ \ g\<^sub>m p" unfolding lassoc cancel_right.. also have "... \ \ \ g\<^sub>m p \ g\<^sub>m r' = h\<^sub>m q \ h\<^sub>m s'" - unfolding begin_block marked.g.morph[symmetric] marked.h.morph[symmetric] assms.. + unfolding begin_block gm.morph[symmetric] hm.morph[symmetric] assms.. also have "... \ g\<^sub>m r' = h\<^sub>m s'" unfolding lassoc begin_block cancel.. finally show "(\ \ g\<^sub>m r = h\<^sub>m s \ \) = (g\<^sub>m r' = h\<^sub>m s')". qed lemma solution_ext_conv: "g r = h s \ \ \ g\<^sub>m (r \ p) = h\<^sub>m (s \ q)" - unfolding marked.g.morph marked.h.morph lassoc begin_block[symmetric] cancel_right solution_marked_version_conv.. + unfolding gm.morph hm.morph lassoc begin_block[symmetric] cancel_right solution_marked_version_conv.. text \Both block exist\ lemma both_blocks: "marked.blockP c" proof- from criticalE - obtain p' q' r1 s1 r2 s2 - where "\\<^sub>g \ g\<^sub>m p' = \\<^sub>h \ h\<^sub>m q'" + obtain p' q' r1 s1 r2 s2 + where "\\<^sub>g \ g\<^sub>m p' = \\<^sub>h \ h\<^sub>m q'" "g\<^sub>m (r1 \ p') = h\<^sub>m (s1 \ q')" "g\<^sub>m (r2 \ p') = h\<^sub>m (s2 \ q')" "r1 \ p' \ \" "r2 \ p' \ \" "hd (r1 \ p') \ hd (r2 \ p')". - let ?ua = "r1 \ p'" let ?va = "s1 \ q'" let ?ub = "r2 \ p'" let ?vb = "s2 \ q'" + let ?ua = "r1 \ p'" let ?va = "s1 \ q'" let ?ub = "r2 \ p'" let ?vb = "s2 \ q'" obtain ea fa where "g\<^sub>m (ea) =\<^sub>m h\<^sub>m (fa)" and "hd ea = hd ?ua" using marked.min_coin_prefE[OF \g\<^sub>m (?ua) = h\<^sub>m (?va)\ \?ua \ \\]. obtain eb fb where "g\<^sub>m (eb) =\<^sub>m h\<^sub>m (fb)" and "hd eb = hd ?ub" using marked.min_coin_prefE[OF \g\<^sub>m ?ub = h\<^sub>m ?vb\ \?ub \ \\]. - from neq_induct[OF \hd ?ua \ hd ?ub\[folded \hd ea = hd ?ua\ \hd eb = hd ?ub\] marked.block_ex[OF \g\<^sub>m ea =\<^sub>m h\<^sub>m fa\] marked.block_ex[OF \g\<^sub>m eb =\<^sub>m h\<^sub>m fb\]] + from bin_neq_induct[OF \hd ?ua \ hd ?ub\[folded \hd ea = hd ?ua\ \hd eb = hd ?ub\] marked.block_ex[OF \g\<^sub>m ea =\<^sub>m h\<^sub>m fa\] marked.block_ex[OF \g\<^sub>m eb =\<^sub>m h\<^sub>m fb\]] show "marked.blockP c". qed notation marked.suc_fst ("\") and marked.suc_snd ("\") lemma sucs_eq: "g\<^sub>m (\ \) = h\<^sub>m (\ \)" - using marked.blocks_eq both_blocks by blast + using marked.blocks_eq both_blocks by blast sublocale marked: two_binary_marked_blocks g\<^sub>m h\<^sub>m - by (standard) (simp add: both_blocks) + by unfold_locales (use both_blocks in fast) + section \Blocks and intersection\ text\Every solution has a block decomposition. However, not all block combinations yield a solution. This motivates the following definition.\ definition coin_block where "coin_block \ \ p \s p \ (\ \) \ q \s q \ (\ \)" theorem char_coincidence: "g r = h s \ (\ \. coin_block \ \ r = (p \ \ \)\<^sup><\p \ s = (q \ \ \)\<^sup><\q)" (is "g r = h s \ ?Q") proof assume "g r = h s" hence "p \p r \ p" and "q \p s \ q" unfolding solution_ext_conv using begin_block_min by blast+ from lq_pref[OF this(1), symmetric] lq_pref[OF this(2), symmetric] - have "r \ p = p \ p\\<^sup>>(r \ p)" and "s \ q = q \ q\\<^sup>>(s \ q)". + have "r \ p = p \ p\\<^sup>>(r \ p)" and "s \ q = q \ q\\<^sup>>(s \ q)". hence "g\<^sub>m (p\\<^sup>>(r \ p)) = h\<^sub>m (q\\<^sup>>(s \ q))" using \g r = h s\ begin_block_conjug_conv[of r "p\\<^sup>> (r \ p)" s "q\\<^sup>> (s \ q)"] - by fast + by fast from marked.block_decomposition[OF this] obtain \ where gsuc: "\ \ = p\\<^sup>>(r \ p)" and hsuc: "\ \ = q\\<^sup>>(s \ q)". note lq = lq_pref[OF \p \p r \ p\] lq_pref[OF \q \p s \ q\] have r: "r = (p \ \ \)\<^sup><\p" and s: "s = (q \ \ \)\<^sup><\q" unfolding \\ \ = p\\<^sup>>(r \ p)\ \\ \ = q\\<^sup>>(s \ q)\lq rq_triv by simp_all have "coin_block \" unfolding coin_block_def gsuc hsuc lq using triv_suf by blast+ thus ?Q using s r by blast next assume ?Q then obtain \ where "p \s p \ (\ \)" and "q \s q \ (\ \)" and r: "r = (p\ (\ \))\<^sup><\p" and s: "s = (q\(\ \))\<^sup><\q" unfolding coin_block_def by blast hence gp: "g\<^sub>m p \ g\<^sub>m (\ \) = g\<^sub>m ((p\(\ \))\<^sup><\p) \ g\<^sub>m p" - unfolding marked.g.morph[symmetric] rq_suf[OF \p \s p \ (\ \)\] by blast + unfolding gm.morph[symmetric] rq_suf[OF \p \s p \ (\ \)\] by blast have hq: "h\<^sub>m q \ h\<^sub>m (\ \) = h\<^sub>m ((q\(\ \))\<^sup><\q) \ h\<^sub>m q" - unfolding marked.h.morph[symmetric] rq_suf[OF \q \s q \ (\ \)\] by blast + unfolding hm.morph[symmetric] rq_suf[OF \q \s q \ (\ \)\] by blast from this show "g r = h s" - unfolding begin_block[symmetric] sucs_eq[symmetric] rassoc gp + unfolding begin_block[symmetric] sucs_eq[symmetric] rassoc gp unfolding lassoc cancel_right unfolding solution_marked_version_conv unfolding r s. qed theorem char_coincidence': "g r = h s \ (g\<^sub>m (p\\<^sup>>(r \ p)) = h\<^sub>m (q\\<^sup>>(s \ q)) \ p \p r \ p \ q \p s \ q)" (is "g r = h s \ ?Q") proof assume "g r = h s" from this[unfolded char_coincidence coin_block_def] obtain e f where "g\<^sub>m e = h\<^sub>m f" "p \s p \ e" "q \s q \ f" "r = (p \ e)\<^sup><\p" "s = (q \ f)\<^sup><\q" using sucs_eq by blast have "r \ p = p \ e" and "s \ q = q \ f" - unfolding \r = (p \ e)\<^sup><\p\ rq_suf[OF \p \s p \ e\] \s = (q \ f)\<^sup><\q\ rq_suf[OF \q \s q \ f\] by blast+ - hence "e = p\\<^sup>>(r \ p)" and "f = q\\<^sup>>(s \ q)" + unfolding \r = (p \ e)\<^sup><\p\ rq_suf[OF \p \s p \ e\] \s = (q \ f)\<^sup><\q\ rq_suf[OF \q \s q \ f\] by blast+ + hence "e = p\\<^sup>>(r \ p)" and "f = q\\<^sup>>(s \ q)" using lq_triv by fastforce+ from \g\<^sub>m e = h\<^sub>m f\[unfolded this] show ?Q using triv_pref \r \ p = p \ e\ \s \ q = q \ f\ by blast next assume ?Q hence "g\<^sub>m (p\\<^sup>>(r \ p)) = h\<^sub>m (q\\<^sup>>(s \ q))" and "p \p r \ p" and "q \p s \ q" by blast+ from this(1) show "g r = h s" - unfolding begin_block_conjug_conv[of r "p\\<^sup>>(r \ p)" s "q\\<^sup>>(s \ q)", OF lq_pref[symmetric] lq_pref[symmetric], OF \p \p r \ p\ \q \p s \ q\]. + unfolding begin_block_conjug_conv[of r "p\\<^sup>>(r \ p)" s "q\\<^sup>>(s \ q)", OF lq_pref[symmetric] lq_pref[symmetric], OF \p \p r \ p\ \q \p s \ q\]. qed theorem coincidence_eq_blocks: "\ g h = {((p \ \ \)\<^sup><\p,(q \ \ \)\<^sup><\q) | \. coin_block \}" - unfolding coincidence_set_def + unfolding coincidence_set_def using pairs_extensional'[OF char_coincidence]. -lemma - minblock0: "g\<^sub>m (\ \) =\<^sub>m h\<^sub>m (\ \)" and - minblock1: "g\<^sub>m (\ \) =\<^sub>m h\<^sub>m (\ \)" and - hdblock0: "hd (\ \) = bin0" and - hdblock1: "hd (\ \) = bin1" +lemma + minblock0: "g\<^sub>m (\ \) =\<^sub>m h\<^sub>m (\ \)" and + minblock1: "g\<^sub>m (\ \) =\<^sub>m h\<^sub>m (\ \)" and + hdblock0: "hd (\ \) = bina" and + hdblock1: "hd (\ \) = binb" using marked.blockP_D both_blocks marked.blockP_D_hd by blast+ definition \ where "\ \ {\ . coin_block \}" lemma \_def': "\ \ \ \ coin_block \" unfolding \_def mem_Collect_eq.. text\Properties of the set of coincidence blocks\ lemma \_closed: assumes "coin_block \\<^sub>1" and "coin_block \\<^sub>2" - shows "coin_block (\\<^sub>1\\\<^sub>2)" + shows "coin_block (\\<^sub>1\\\<^sub>2)" proof- from assms - have "p \s p \ \ \\<^sub>2" and "p \s p \ \ \\<^sub>1" and + have "p \s p \ \ \\<^sub>2" and "p \s p \ \ \\<^sub>1" and "q \s q \ \ \\<^sub>2" and "q \s q \ \ \\<^sub>1" - unfolding coin_block_def by blast+ + unfolding coin_block_def by blast+ from suf_prolong[OF this(1-2), unfolded rassoc] suf_prolong[OF this(3-4), unfolded rassoc] - show "coin_block (\\<^sub>1\\\<^sub>2)" + show "coin_block (\\<^sub>1\\\<^sub>2)" unfolding coin_block_def marked.sucs.h.morph marked.sucs.g.morph by blast qed -lemma emp_block: "coin_block \" +lemma emp_block: "coin_block \" unfolding coin_block_def marked.sucs.g.emp_to_emp marked.sucs.h.emp_to_emp by force -lemma \_hull: "\\\ = \" +lemma \_hull: "\\\ = \" proof (intro hull_I) show "\ \ \" unfolding \_def' coin_block_def marked.sucs.g.emp_to_emp marked.sucs.h.emp_to_emp by force show "\x y. x \ \ \ y \ \ \ x \ y \ \" unfolding \_def' using \_closed. qed lemma \_pref: "coin_block \\<^sub>1 \ coin_block (\\<^sub>1 \ \\<^sub>2) \ coin_block \\<^sub>2" using suf_prod_suf[of p "p \ \ \\<^sub>1" "\ \\<^sub>2"] suf_prod_suf[of q "q \ \ \\<^sub>1" "\ \\<^sub>2"] - unfolding coin_block_def marked.sucs.g.morph marked.sucs.h.morph rassoc + unfolding coin_block_def marked.sucs.g.morph marked.sucs.h.morph rassoc by blast text \Translation from blocks to the intersection\ lemma translate_coin_blocks_to_intersection: - "(h \ (\ x. (q \ x)\<^sup><\q) \ \) ` \ = range g \ range h" - unfolding coin_set_inter_snd[of h g, unfolded coincidence_eq_blocks, symmetric] \_def + "(h \ (\ x. (q \ x)\<^sup><\q) \ \) ` \ = range g \ range h" + unfolding coin_set_inter_snd[of h g, unfolded coincidence_eq_blocks, symmetric] \_def proof- have "(h \ snd) ` {(F x, G x) | x. coin_block x} = {h (G x) | x. coin_block x}" for F G :: "binA list \ binA list" - by force + by (standard, standard, auto, force) note rule1 = this[of "\\. (p \ \ \)\<^sup><\p" "\\. (q \ \ \)\<^sup><\q"] have "(h \ I \ \) ` {x . coin_block x} = {h (I (\ x))| x. coin_block x}" for I - by force + by rule auto from this[of "(\x. (q \ x)\<^sup><\q)", folded rule1] show "(h \ (\x. (q \ x)\<^sup><\q ) \ \) ` Collect coin_block = (h \ snd) ` {((p \ \ \)\<^sup><\p , (q \ \ \)\<^sup><\q ) |\. coin_block \}". -qed +qed -lemma translation_blocks_inj: +lemma translation_blocks_inj: "inj_on (h \ (\ x. (q \ x)\<^sup><\q) \ \) \\\" proof fix x y assume "x \ \\\" and "y \ \\\" hence "q \s q \ \ x" and "q \s q \ \ y" unfolding \_def' \_hull coin_block_def by blast+ assume "(h \ (\x. (q \ x)\<^sup><\q ) \ \) x = (h \ (\x. (q \ x)\<^sup><\q ) \ \) y" hence "h ((q \ \ x)\<^sup><\q) = h ((q \ \ y)\<^sup><\q)" by simp from h.code_morph_code[OF this] rq_suf[OF \q \s q \ \ x\] rq_suf[OF \q \s q \ \ y\] have "\ x = \ y" - unfolding cancel[of q "\ x" "\ y", symmetric] by argo + unfolding cancel[of q "\ x" "\ y", symmetric] by argo thus "x = y" using marked.sucs.h.code_morph_code by blast qed lemma translation_blocks_morph_on: "morphism_on (h \ (\ x. (q \ x)\<^sup><\q) \ \) \" proof fix x y assume "x \ \\\" and "y \ \\\" hence "q \s q \ \ x" and "q \s q \ \ y" unfolding \_hull \_def' coin_block_def by blast+ show "(h \ (\x. (q \ x)\<^sup><\q ) \ \) (x \ y) = - (h \ (\x. (q \ x)\<^sup><\q ) \ \) x\ (h \ (\x. (q \ x)\<^sup><\q ) \ \) y" + (h \ (\x. (q \ x)\<^sup><\q ) \ \) x\ (h \ (\x. (q \ x)\<^sup><\q ) \ \) y" unfolding comp_apply h.morph[symmetric] rq_reassoc[OF \q \s q \ \ y\] lassoc rq_suf[OF \q \s q \ \ x\] unfolding rassoc marked.sucs.h.morph.. qed interpretation morphism_on "(h \ (\ x. (q \ x)\<^sup><\q) \ \)" \ using translation_blocks_morph_on. theorem inter_basis: "\ (range g \ range h) = (h \ (\ x. (q \ x)\<^sup><\q) \ \) ` (\ \)" using inj_basis_to_basis[OF translation_blocks_inj, unfolded \_hull] - translate_coin_blocks_to_intersection by presburger + translate_coin_blocks_to_intersection by presburger section \Simple blocks\ text \If both letters are blocks, the situation is easy\ -theorem simple_blocks: assumes "\ a. coin_block [a]" shows - "coin_block \" +theorem simple_blocks: assumes "\ a. coin_block [a]" shows + "coin_block \" by (induct "\", simp add: emp_block) (use assms \_closed[OF assms] hd_word in force) -theorem simple_blocks_UNIV: "(\ a. coin_block [a]) \ \ = UNIV" - using simple_blocks \_def' by auto +theorem simple_blocks_UNIV: "(\ a. coin_block [a]) \ \ = UNIV" + using simple_blocks \_def' by auto -theorem simple_blocks_basis: assumes "\a. coin_block [a]" - shows "\ \ = {\, \}" - using basis_of_hull[of "{\,\}"] code.code_is_basis[OF bin_basis_code] +theorem simple_blocks_basis: assumes "\a. coin_block [a]" + shows "\ \ = {\, \}" + using basis_of_hull[of "{\,\}"] code.code_is_basis[OF bin_basis_code] unfolding bin_basis_generates simple_blocks_UNIV[OF assms, symmetric] by argo section \At least one block\ text \At least one letter -- the last one -- is a block\ lemma last_letter_fst_suf: assumes "coin_block (z \ [c])" shows "p [c]" proof- from assms have "p \s p \ \ (z \ [c])" and "q \s q \ \ (z \ [c])" unfolding coin_block_def by blast+ hence "p \\<^sub>s \ [c]" and "q \\<^sub>s \ [c]" - unfolding marked.sucs.g.morph marked.sucs.h.morph lassoc using ruler_pref''[reversed] by blast+ + unfolding marked.sucs.g.morph marked.sucs.h.morph lassoc using ruler_suf'' by blast+ have "\ \ [c] \s p" proof assume "\ [c] \s p" hence "g\<^sub>m (\ [c]) \s \ \ g\<^sub>m p" - using marked.g.suf_mono suf_ext by blast + using gm.suf_mono suf_ext by blast hence "h\<^sub>m (\ [c]) \s h\<^sub>m q" unfolding begin_block sucs_eq. hence "\ [c] \s q" - using marked.h.suf_mono - \q \\<^sub>s \ [c]\[unfolded suf_comp_or] marked.h.code_morph_code suffix_order.antisym by metis + using hm.suf_mono + \q \\<^sub>s \ [c]\[unfolded suf_comp_or] hm.code_morph_code suffix_order.antisym by metis have "\ \ g\<^sub>m (p\<^sup><\\ [c] \ \ [c]) = h\<^sub>m (q\<^sup><\\[c] \ \[c])" unfolding rq_suf[OF \\ [c] \s p\] rq_suf[OF \\ [c] \s q\] begin_block[symmetric].. hence "\ \ g\<^sub>m (p\<^sup><\\ [c]) = h\<^sub>m (q\<^sup><\\[c])" - unfolding marked.g.morph marked.h.morph marked.block_eq[OF both_blocks] lassoc cancel_right. + unfolding gm.morph hm.morph marked.block_eq[OF both_blocks] lassoc cancel_right. from conjunct1[OF begin_block_min[OF this]] - have "\ [c] = \" + have "\ [c] = \" using rq_suf[OF \\ [c] \s p\] same_prefix_nil by metis thus False - using marked.sucs.g.sing_to_nemp by blast + using marked.sucs.g.sing_to_nemp by blast qed - thus "p [c]" + thus "p [c]" unfolding strict_suffix_def using \p \\<^sub>s \ [c]\[unfolded suf_comp_or] by metis qed lemma rich_block_suf_fst': assumes "coin_block (z \ [1-c] \ [c]\<^sup>@Suc i)" - shows "marked.g.bin_code_lcs \ g\<^sub>m p \s g\<^sub>m (\ ([1-c]\[c]\<^sup>@Suc i))" + shows "gm.bin_code_lcs \ g\<^sub>m p \s g\<^sub>m (\ ([1-c]\[c]\<^sup>@Suc i))" proof- - from last_letter_fst_suf assms[unfolded pow_Suc2 lassoc] + from last_letter_fst_suf assms[unfolded pow_Suc' lassoc] have "p [c]" by blast hence "\ [c] = [c] \ tl (\ [c])" using marked.blockP_D_hd[OF both_blocks[of c]] hd_tl[OF marked.sucs.g.sing_to_nemp] by metis - then obtain p' where "\ [c] = [c] \ p' \ p" - using ssufE[OF \p [c]\] ssuf_tl_suf suf_def by metis - hence *: "\([1-c] \ [c]\<^sup>@Suc i) = \ ([1-c] \ [c]\<^sup>@i) \ [c] \ p' \ p" - unfolding pow_Suc2 marked.sucs.g.morph by force + then obtain p' where "\ [c] = [c] \ p' \ p" + using ssufE[OF \p [c]\] ssuf_tl_suf suffix_def by metis + hence *: "\([1-c] \ [c]\<^sup>@Suc i) = \ ([1-c] \ [c]\<^sup>@i) \ [c] \ p' \ p" + unfolding pow_Suc' marked.sucs.g.morph by force have f1: "[c] \f \ ([1 - c] \ [c] \<^sup>@ i) \ [c] \ p'" by fast - have "[1 - c] \f ([1 - c] \ tl (\ [1 - c])) \ \ ([c] \<^sup>@ i) \ [c] \ p'" + have "[1 - c] \f ([1 - c] \ tl (\ [1 - c])) \ \ ([c] \<^sup>@ i) \ [c] \ p'" unfolding rassoc by blast - from this[unfolded hd_tl[OF marked.sucs.g.sing_to_nemp, of "1-c", unfolded marked.blockP_D_hd[OF both_blocks[of "1-c"]]]] + from this[unfolded hd_tl[OF marked.sucs.g.sing_to_nemp, of "1-c", unfolded marked.blockP_D_hd[OF both_blocks[of "1-c"]]]] have f2: "[1-c] \f \ ([1 - c] \ [c] \<^sup>@ i) \ [c] \ p'" unfolding marked.sucs.g.morph rassoc. from marked.revs.g.bin_lcp_pref''[reversed, OF f1 f2, unfolded g.marked_lcs] g.marked_lcs - show "marked.g.bin_code_lcs \ g\<^sub>m p \s g\<^sub>m (\ ([1-c]\[c]\<^sup>@Suc i))" - unfolding * marked.g.morph lassoc suf_cancel_conv lcp_diff[symmetric] by simp + show "gm.bin_code_lcs \ g\<^sub>m p \s g\<^sub>m (\ ([1-c]\[c]\<^sup>@Suc i))" + unfolding * gm.morph lassoc suf_cancel_conv lcp_diff[symmetric] by simp qed lemma rich_block_suf_fst: assumes "coin_block (z \ [1-c] \ [c]\<^sup>@Suc i)" shows "\ \ g\<^sub>m (p) \s g\<^sub>m (\ ([1-c]\[c]\<^sup>@Suc i))" using rich_block_suf_fst'[OF assms] using g.marked_lcs lcp_diff[symmetric] rassoc - using suffix_appendD by metis + using suf_extD by metis lemma rich_block_suf_snd': assumes "coin_block (z \ [1-c] \ [c]\<^sup>@Suc i)" shows "\\<^sub>h \ h\<^sub>m q \s h\<^sub>m (\ ([1-c]\[c]\<^sup>@Suc i))" - using rich_block_suf_fst'[OF assms, unfolded marked.suc_eq'[OF both_blocks] g.marked_lcs rassoc] + using rich_block_suf_fst'[OF assms, unfolded marked.suc_eq'[OF both_blocks] g.marked_lcs rassoc] unfolding lcp_diff[symmetric] rassoc begin_block - using suffix_appendD by blast + using suf_extD by blast lemma rich_block_suf_snd: assumes "coin_block (z \ [1-c] \ [c]\<^sup>@Suc i)" shows "q \s \ ([1-c]\[c]\<^sup>@Suc i)" proof(rule ccontr) assume notsuf: "\ q \s \ ([1 - c] \ [c] \<^sup>@ Suc i)" from conjunct2[OF assms[unfolded coin_block_def]] have "q \s (q \ \ z) \ \ ([1 - c] \ [c] \<^sup>@ Suc i)" unfolding marked.sucs.h.morph rassoc. note ruler = suf_ruler[OF this triv_suf] from this have "\ ([1 - c] \ [c] \<^sup>@ Suc i) [c])" shows "coin_block [c]" proof (cases) assume "z \ [c]*" from sing_pow_exp[OF this] obtain i where "z = [c]\<^sup>@i" - by blast + by blast have "z \ [c] = [c]\<^sup>@Suc i" - unfolding \z = [c]\<^sup>@i\ pow_Suc2.. + unfolding \z = [c]\<^sup>@i\ pow_Suc'.. have "\ (z \ [c]) = (\ [c])\<^sup>@Suc i" and "\ (z \ [c]) = (\ [c])\<^sup>@Suc i" unfolding \z \ [c] = [c]\<^sup>@Suc i\ marked.sucs.g.pow_morph marked.sucs.h.pow_morph by simp_all from \coin_block (z \ [c])\[unfolded coin_block_def this] show "coin_block [c]" - unfolding coin_block_def using per_drop_exp_rev[OF Suc_not_Zero] by metis + unfolding coin_block_def using per_drop_exp_rev[OF zero_less_Suc] by metis next assume "z \ [c]*" from distinct_letter_in_suf[OF this] obtain t z' b where z: "z = z' \ [b] \ [c]\<^sup>@t" and "b \ c" - unfolding suf_def by metis + unfolding suffix_def by metis have "p [c]" using last_letter_fst_suf[OF \coin_block (z \ [c])\]. - from ssufD[OF this, unfolded suf_def] + from ssufD[OF this, unfolded suffix_def] obtain p' where "p'\ p = \[c]" and "p' \ \" by force hence "hd p' = c" using marked.blockP_D_hd[OF both_blocks[of c]] hd_append2[OF \p' \ \\, of p] by argo - hence "\[c] = [c] \ tl p' \ p" + hence "\[c] = [c] \ tl p' \ p" unfolding \p'\ p = \[c]\[symmetric] using hd_tl[OF \p' \ \\] by simp show "coin_block [c]" proof(cases) assume "q \s q \ \ [c]" thus "coin_block [c]" - unfolding coin_block_def using ssufD1[OF ssuf_ext[OF \p [c]\]] by fast + unfolding coin_block_def using ssufD1[OF ssuf_ext[OF \p [c]\]] by blast next \ \the other option leads to a contradiction\ write marked.sucs.h.bin_morph_mismatch_suf ("\

") and marked.sucs.h.bin_code_lcs ("\\<^sub>\") and - marked.h.bin_code_lcs ("\\<^sub>H") and - marked.g.bin_code_lcs ("\\<^sub>G") and + hm.bin_code_lcs ("\\<^sub>H") and + gm.bin_code_lcs ("\\<^sub>G") and g.bin_code_lcs ("\\<^sub>g") assume "\ q \s q \ \ [c]" \ \suffix of @{term q}\ - hence "\ q \s q \ \ ([c]\<^sup>@ Suc t)" - unfolding marked.sucs.h.pow_morph using per_drop_exp'[reversed] by blast + hence "\ q \s q \ \ ([c]\<^sup>@ Suc t)" + unfolding marked.sucs.h.pow_morph using per_drop_exp'[reversed] by blast hence "\ q \s \\<^sub>\ \ \ ([c]\<^sup>@Suc t)" - using suf_prolong_per_root[OF _ marked.sucs.revs.h.bin_lcp_pref_all[reversed], of q "[c]\<^sup>@Suc t"] by blast + using suf_prolong_per_root[OF _ marked.sucs.revs.h.bin_lcp_pref_all[reversed], of q "[c]\<^sup>@Suc t"] by blast \ \analysis of q\ have "q \s q \ \(z' \ [b] \ [c]\<^sup>@Suc t)" using \coin_block (z \ [c])\ - unfolding z coin_block_def rassoc pow_Suc2 by blast + unfolding z coin_block_def rassoc pow_Suc' by blast note per_exp_pref[reversed, OF this, of 2, unfolded pow_two] hence suf1: "q \s q \ \ (z' \ [b]) \ \ ([c] \<^sup>@ Suc t \ z' \ [b]) \ \ ([c] \<^sup>@ Suc t)" unfolding marked.sucs.h.morph rassoc. have "[\
b] \ \\<^sub>\ \s \ ([c]\<^sup>@Suc t \ z') \ \ [b]" by (rule marked.sucs.revs.h.bin_lcp_mismatch_pref_all_set[reversed]) - (simp add: \b \ c\[unfolded bin_neq_iff]) - from this[folded marked.sucs.h.morph lassoc, unfolded suf_def] + (unfold bin_neq_swap[OF \b \ c\], simp) + from this[folded marked.sucs.h.morph lassoc, unfolded suffix_def] obtain zs where "\ ([c] \<^sup>@ Suc t \ z' \ [b]) = zs \ [\
b] \ \\<^sub>\" by blast - have suf2: "[\
b] \ \\<^sub>\ \ \ ([c]\<^sup>@Suc t) \s q \ \ (z' \ [b]) \ \ ([c] \<^sup>@ Suc t \ z' \ [b]) \ \ ([c] \<^sup>@ Suc t)" - unfolding \\ ([c] \<^sup>@ Suc t \ z' \ [b]) = zs \ [\
b] \ \\<^sub>\\ - using triv_suf[of "[\
b] \ \\<^sub>\ \ \ ([c] \<^sup>@ Suc t)" "q \ \ (z' \ [b]) \ zs"] unfolding rassoc. + have suf2: "[\
b] \ \\<^sub>\ \ \ ([c]\<^sup>@Suc t) \s q \ \ (z' \ [b]) \ \ ([c] \<^sup>@ Suc t \ z' \ [b]) \ \ ([c] \<^sup>@ Suc t)" + unfolding \\ ([c] \<^sup>@ Suc t \ z' \ [b]) = zs \ [\
b] \ \\<^sub>\\ + using triv_suf[of "[\
b] \ \\<^sub>\ \ \ ([c] \<^sup>@ Suc t)" "q \ \ (z' \ [b]) \ zs"] unfolding rassoc. have "q \\<^sub>s [\
b] \ \\<^sub>\ \ \ ([c]\<^sup>@Suc t)" - using ruler[reversed, OF suf1 suf2] unfolding suf_comp_or. - with \\ q \s \\<^sub>\ \ \ ([c]\<^sup>@Suc t)\ - have "[\
b] \ \\<^sub>\ \ \ ([c]\<^sup>@Suc t) \s q" - unfolding suf_comp_or hd_word[symmetric] suffix_Cons using suffix_order.eq_refl[OF sym, of q] by blast + using ruler[reversed, OF suf1 suf2] unfolding suf_comp_or. + with \\ q \s \\<^sub>\ \ \ ([c]\<^sup>@Suc t)\ + have "[\
b] \ \\<^sub>\ \ \ ([c]\<^sup>@Suc t) \s q" + unfolding suf_comp_or hd_word[symmetric] suffix_Cons using suffix_order.eq_refl[OF sym, of q] by blast from suffixE[OF this] obtain q' where q_factors: "q = q' \ [\
b] \ \\<^sub>\ \ \ ([c] \<^sup>@ Suc t)". \ \length of @{term "\\<^sub>H \\<^sub>p \"}\ \ \1. inequality\ from marked.lcs_fst_suf_snd - have "\\<^sub>G \s \\<^sub>H \ h\<^sub>m \\<^sub>\". + have "\\<^sub>G \s \\<^sub>H \ h\<^sub>m \\<^sub>\". from suf_len[OF this, unfolded lenmorph] have ineq1: "\<^bold>|\\<^sub>G\<^bold>| \ \<^bold>|\\<^sub>H\<^bold>| + \<^bold>|h\<^sub>m \\<^sub>\\<^bold>|" - using lenarg[OF lcp_diff, unfolded lenmorph] by linarith + using lenarg[OF lcp_diff, unfolded lenmorph] by linarith \ \2. inequality\ - from begin_block[unfolded q_factors, unfolded pow_Suc2 marked.sucs.h.morph marked.h.morph, folded sucs_eq[of "[c]"], unfolded \\[c] = [c] \ tl p' \ p\ marked.g.morph lassoc cancel_right, unfolded rassoc] + from begin_block[unfolded q_factors, unfolded pow_Suc' marked.sucs.h.morph hm.morph, folded sucs_eq[of "[c]"], unfolded \\[c] = [c] \ tl p' \ p\ gm.morph lassoc cancel_right, unfolded rassoc] have "\ = h\<^sub>m q' \ h\<^sub>m [\
b] \ h\<^sub>m \\<^sub>\ \ h\<^sub>m (\ ([c] \<^sup>@ t)) \ g\<^sub>m [c] \ g\<^sub>m (tl p')". from lenarg[OF this] lenarg[OF lcp_diff] - have ineq2: "\<^bold>|h\<^sub>m [\
b]\<^bold>| + \<^bold>|g\<^sub>m [c]\<^bold>| + \<^bold>|h\<^sub>m \\<^sub>\\<^bold>| \ \<^bold>|\\<^sub>g\<^bold>|" - unfolding lenmorph by linarith + have ineq2: "\<^bold>|h\<^sub>m [\
b]\<^bold>| + \<^bold>|g\<^sub>m [c]\<^bold>| + \<^bold>|h\<^sub>m \\<^sub>\\<^bold>| \ \<^bold>|\\<^sub>g\<^bold>|" + unfolding lenmorph by linarith \ \conclusions\ have concl1: "\<^bold>|h\<^sub>m [\
b]\<^bold>| + \<^bold>|g\<^sub>m [c]\<^bold>| \ \<^bold>|\\<^sub>g\<^bold>|" using ineq2 by linarith have concl2: "\<^bold>|h\<^sub>m [\
b]\<^bold>| + \<^bold>|g\<^sub>m [c]\<^bold>| \ \<^bold>|\\<^sub>H\<^bold>|" using ineq1 ineq2 lenarg[OF g.marked_lcs, unfolded lenmorph] by linarith from suf_comp_monotone[OF marked.suf_comp_lcs] sufI[OF g.marked_lcs[symmetric]] have "\\<^sub>g \\<^sub>s \\<^sub>H" by blast have concl: "\<^bold>|h\<^sub>m [\
b]\<^bold>| + \<^bold>|g\<^sub>m [c]\<^bold>| \ \<^bold>|\\<^sub>g \\<^sub>s \\<^sub>H\<^bold>|" - by (rule disjE[OF \\\<^sub>g \\<^sub>s \\<^sub>H\[unfolded suf_comp_or], unfolded lcs_suf_conv[symmetric] lcs_sym[of \\<^sub>H]]) + by (rule disjE[OF \\\<^sub>g \\<^sub>s \\<^sub>H\[unfolded suf_comp_or], unfolded lcs_suf_conv[symmetric] lcs_sym[of \\<^sub>H]]) (use concl1 concl2 in argo)+ \ \two periods of @{term "\\<^sub>g \\<^sub>s \\<^sub>H"}\ have "\\<^sub>g \s \\<^sub>g \ g\<^sub>m [c]" unfolding g.marked_version_conjugates by blast hence per1: "\\<^sub>g \\<^sub>s \\<^sub>H \s (\\<^sub>g \\<^sub>s \\<^sub>H) \ g\<^sub>m [c]" - using lcs_suf suf_keeps_root by blast - have "\\<^sub>H \s \\<^sub>H \ h\<^sub>m [\
b]" + using lcs_suf suf_keeps_root by blast + have "\\<^sub>H \s \\<^sub>H \ h\<^sub>m [\
b]" using marked.revs.h.bin_lcp_pref_all[reversed]. hence per2: "\\<^sub>g \\<^sub>s \\<^sub>H \s (\\<^sub>g \\<^sub>s \\<^sub>H) \ h\<^sub>m [\
b]" - using lcs_suf' suf_keeps_root by blast + using lcs_suf' suf_keeps_root by blast from two_pers[reversed, OF per2 per1 concl] - have "g\<^sub>m [c] \ h\<^sub>m [\
b] = h\<^sub>m [\
b] \ g\<^sub>m [c]". + have "g\<^sub>m [c] \ h\<^sub>m [\
b] = h\<^sub>m [\
b] \ g\<^sub>m [c]". from marked.comm_sings_block[OF this] obtain n where "\ [c] = [\
b] \<^sup>@ Suc n" by blast from marked.sucs.h.sing_pow_mismatch_suf[OF \\ [c] = [\
b] \<^sup>@ Suc n\] - \b \ c\ marked.sucs.h.bin_mismatch_suf_inj - have False + \b \ c\ marked.sucs.h.bin_mismatch_suf_inj + have False unfolding inj_on_def by blast thus "coin_block [c]" by blast qed qed end section "Infinite case" -locale binary_codes_coincidence_infinite = binary_codes_coincidence_two_generators for a1 + +locale binary_codes_coincidence_infinite = binary_codes_coincidence_two_generators for a1 + assumes non_block: "\ coin_block [a1]" begin -subsection \Description of coincidence blocks\ +subsection \Description of coincidence blocks\ lemma swap_coin_block: "coin_block [1-a1]" proof- obtain u v where "g u =\<^sub>m h v" using coin_ex by blast from min_coinD[OF this, unfolded char_coincidence] obtain \ where "coin_block \" and "u = (p \ \ \)\<^sup><\p" by blast from conjunct1[OF min_coinD'[OF \g u =\<^sub>m h v\], unfolded this(2)] have "\ \ \" - using rq_self[of p] marked.sucs.g.emp_to_emp clean_emp(1) by metis + using rq_self[of p] marked.sucs.g.emp_to_emp emp_simps(1) by metis from append_butlast_last_id[OF this] have "coin_block [last \]" using \coin_block \\ last_letter_block by metis with non_block show "coin_block [1-a1]" - by (cases rule: bin_swap_exhaust[of "last \" a1]) simp_all -qed + by (cases rule: bin_swap_exhaust[of "last \" a1]) simp_all +qed definition coincidence_exponent ("t") where "coincidence_exponent = (LEAST x. (q \s q \ \([a1] \ [1-a1]\<^sup>@Suc x)))" lemma q_nemp: "q \ \" proof (rule notI) assume "q = \" with coin_block_def - marked.ne_g[OF suf_of_emp[OF begin_block[unfolded marked.h.emp_to_emp'[OF this]]]] non_block + marked.ne_g[OF suf_of_emp[OF begin_block[unfolded hm.emp_to_emp'[OF this]]]] non_block show False by blast qed lemma p_suf: "p [1-a1]" - using last_letter_fst_suf[of \, unfolded clean_emp, OF swap_coin_block]. + using last_letter_fst_suf[of \, unfolded emp_simps, OF swap_coin_block]. lemma coin_exp: "coin_block ([a1] \ [1-a1]\<^sup>@Suc t)" and coin_exp_min: "j \ t \ \ coin_block ([a1] \ [1-a1]\<^sup>@j)" proof- have "\<^bold>|q\<^bold>| \ \<^bold>|\ ([1-a1]\<^sup>@\<^bold>|q\<^bold>|)\<^bold>|" - using long_pow_exp marked.sucs.h.pow_morph marked.sucs.h.sing_to_nemp by metis - moreover have "q \s q \ \ ([1-a1]\<^sup>@\<^bold>|q\<^bold>|)" - unfolding marked.sucs.h.pow_morph using conjunct2[OF swap_coin_block[unfolded coin_block_def]] using per_exp_suf by blast + using long_pow marked.sucs.h.pow_morph marked.sucs.h.sing_to_nemp by metis + moreover have "q \s q \ \ ([1-a1]\<^sup>@\<^bold>|q\<^bold>|)" + unfolding marked.sucs.h.pow_morph using conjunct2[OF swap_coin_block[unfolded coin_block_def]] using per_exp_suf by blast ultimately have "q \s \ ([a1] \ [1-a1]\<^sup>@\<^bold>|q\<^bold>|)" - unfolding marked.sucs.h.morph using suf_prod_le suf_ext by blast - from LeastI[of "\ x. (q \s q \ \([a1] \ [1-a1]\<^sup>@Suc x))", - folded coincidence_exponent_def, of "\<^bold>|q\<^bold>| - 1"] suf_ext[OF this, of q] + unfolding marked.sucs.h.morph using suf_prod_le suf_ext by blast + from LeastI[of "\ x. (q \s q \ \([a1] \ [1-a1]\<^sup>@Suc x))", + folded coincidence_exponent_def, of "\<^bold>|q\<^bold>| - 1"] suf_ext[OF this, of q] have "q \s q \ \ ([a1] \ [1 - a1] \<^sup>@ Suc t)" - unfolding Suc_minus[OF nemp_len[OF q_nemp]] by blast + unfolding Suc_minus[OF nemp_len[OF q_nemp]] by blast thus "coin_block ([a1] \ [1-a1]\<^sup>@Suc t)" - unfolding pow_Suc2 marked.sucs.g.morph coin_block_def - using suf_ext[OF ssufD1[OF p_suf], of "p \ \ [a1] \ \ ([1 - a1] \<^sup>@ t)", unfolded rassoc] by blast + unfolding pow_Suc' marked.sucs.g.morph coin_block_def + using suf_ext[OF ssufD1[OF p_suf], of "p \ \ [a1] \ \ ([1 - a1] \<^sup>@ t)", unfolded rassoc] by blast next - fix j assume "j \ t" + fix j assume "j \ t" show "\ coin_block ([a1] \ [1-a1]\<^sup>@j)" - proof (cases "j = 0") + proof (cases "j = 0", simp add: non_block) assume "j \ 0" hence "j - 1 < t" and "t \ 0" using \j \ t\ \j \ 0\ by simp_all - thus "\ coin_block ([a1] \ [1-a1]\<^sup>@j)" + thus "\ coin_block ([a1] \ [1-a1]\<^sup>@j)" using not_less_Least[of "j - 1" "\ x. q \s q \ \ ([a1] \ [1 - a1] \<^sup>@ Suc x)", folded coincidence_exponent_def] unfolding coin_block_def Suc_minus[OF \j \ 0\] by linarith - qed (simp add: non_block) + qed qed lemma exp_min: "\ q \s \ [1-a1]\<^sup>@t" -proof (cases "t = 0") +proof (cases "t = 0", simp add: q_nemp) assume "t \ 0" hence "t -1 < t" by simp - show ?thesis - using not_less_Least[of "t -1" "\ m. q \s q \ \ ([a1] \ [1 - a1] \<^sup>@ Suc m)", folded coincidence_exponent_def, OF \t - 1 < t\, unfolded marked.sucs.h.morph Suc_minus[OF \t \ 0\]] - unfolding marked.sucs.h.pow_morph using suf_ext by metis -qed (simp add: q_nemp) + show ?thesis + using not_less_Least[of "t -1" "\ m. q \s q \ \ ([a1] \ [1 - a1] \<^sup>@ Suc m)", folded coincidence_exponent_def, OF \t - 1 < t\, unfolded marked.sucs.h.morph Suc_minus[OF \t \ 0\]] + unfolding marked.sucs.h.pow_morph using suf_ext by metis +qed lemma q_suf_conv: "q \s \ ([a1]\[1-a1]\<^sup>@Suc k) \ t \ k" -proof +proof have psuf': "p \s p \ \ ([a1] \ [1 - a1] \<^sup>@ Suc k)" for k - unfolding pow_Suc2 using marked.sucs.g.morph ssufD1[OF p_suf] suffix_appendI by metis + unfolding pow_Suc' using marked.sucs.g.morph ssufD1[OF p_suf] suffix_appendI by metis assume "q \s \ ([a1] \ [1 - a1] \<^sup>@ Suc k)" hence "\ Suc k \ t" - using coin_exp_min[of "Suc k"] psuf'[of k] suf_ext[of q _ q] unfolding coin_block_def by blast - thus "t \ k" + using coin_exp_min[of "Suc k"] psuf'[of k] suf_ext[of q _ q] unfolding coin_block_def by blast + thus "t \ k" by linarith next assume "t \ k" have "q \s q \ \[1-a1]" using coin_block_def swap_coin_block by blast have "q \s \ [a1] \ \ ([1-a1]\<^sup>@Suc t)" - using coin_exp rich_block_suf_snd[of \ "1 - a1" t, unfolded clean_emp binsimp] unfolding marked.sucs.h.morph by blast + using coin_exp rich_block_suf_snd[of \ "1 - a1" t, unfolded emp_simps binA_simps] unfolding marked.sucs.h.morph by blast from suf_prolong[OF per_exp_suf[OF \q \s q \ \[1-a1]\, folded marked.sucs.h.pow_morph] this, of "k-t", folded marked.sucs.h.morph lassoc, folded add_exps[of "[1-a1]" "Suc t"]] show "q \s \ ([a1] \ [1-a1]\<^sup>@Suc k)" using \t \k\ by fastforce qed lemma coin_block_with_bad_letter: assumes "a1 \ set w" shows "coin_block w \ [1-a1]\<^sup>@Suc t \s w" proof- - obtain i b where "[b] \ [1-a1]\<^sup>@i \s w" and "b \ 1-a1" + obtain i b where "[b] \ [1-a1]\<^sup>@i \s w" and "b \ 1-a1" using distinct_letter_in_suf[of w "1-a1", OF neq_set_not_root[OF bin_swap_neq, OF assms]]. - note \b \ 1-a1\[symmetric, unfolded bin_neq_iff binsimp] - from \[b] \ [1-a1]\<^sup>@i \s w\[unfolded this, unfolded suf_def] + have "b = a1" + using bin_neq_swap'''[OF \b \ 1-a1\, unfolded binA_simps]. + from \[b] \ [1-a1]\<^sup>@i \s w\[unfolded this, unfolded suffix_def] obtain w' where w: "w = w' \ [a1] \ [1-a1]\<^sup>@i" by blast show ?thesis proof(cases) assume "i = 0" - have "\ [1 - a1] \<^sup>@ Suc t \s w' \ [a1]" - unfolding pow_Suc2 using bin_swap_neq[of a1] - by simp + have "\ [1 - a1] \<^sup>@ Suc t \s w' \ [a1]" + unfolding pow_Suc' using bin_swap_neq[of a1] + by simp then show "coin_block w \ [1-a1]\<^sup>@Suc t \s w" - unfolding w \i = 0\ clean_pows using last_letter_block non_block by meson + unfolding w \i = 0\ cow_simps using last_letter_block non_block by meson next assume "i \ 0" have psuf: "p \s p \ \ (w' \ [a1] \ [1 - a1] \<^sup>@ Suc k)" for k - unfolding pow_Suc2 using marked.sucs.g.morph ssufD1[OF p_suf] suffix_appendI by metis + unfolding pow_Suc' using marked.sucs.g.morph ssufD1[OF p_suf] suffix_appendI by metis have psuf': "p \s p \ \ ([a1] \ [1 - a1] \<^sup>@ Suc k)" for k - unfolding pow_Suc2 using marked.sucs.g.morph ssufD1[OF p_suf] suffix_appendI by metis + unfolding pow_Suc' using marked.sucs.g.morph ssufD1[OF p_suf] suffix_appendI by metis have equiv1: "coin_block (w'\[a1]\[1-a1]\<^sup>@Suc k) \ q \s \ ([a1]\[1-a1]\<^sup>@Suc k)" for k - proof + proof show "coin_block (w' \ [a1] \ [1 - a1] \<^sup>@ Suc k) \ q \s \ ([a1] \ [1 - a1] \<^sup>@ Suc k)" - using rich_block_suf_snd[of w' "1 - a1" k] suffix_append unfolding binsimp marked.sucs.h.morph by blast + using rich_block_suf_snd[of w' "1 - a1" k] suffix_append unfolding binA_simps marked.sucs.h.morph by blast show "q \s \ ([a1] \ [1 - a1] \<^sup>@ Suc k) \ coin_block (w' \ [a1] \ [1 - a1] \<^sup>@ Suc k)" unfolding coin_block_def marked.sucs.h.morph using psuf suffix_appendI by metis qed have "t \ k \ [1-a1]\<^sup>@Suc t \s w'\[a1]\[1-a1]\<^sup>@Suc k" for k - using sing_exp_pref_iff[reversed, OF bin_swap_neq', symmetric, of "Suc t" "Suc k" "1-a1", unfolded Suc_le_mono binsimp rassoc]. - from equiv1[unfolded q_suf_conv this, of "i-1", unfolded Suc_minus[OF \i \ 0\], folded w] + using sing_exp_pref_iff[reversed, OF bin_swap_neq', symmetric, of "Suc t" "Suc k" "1-a1", unfolded Suc_le_mono binA_simps rassoc]. + from equiv1[unfolded q_suf_conv this, of "i-1", unfolded Suc_minus[OF \i \ 0\], folded w] show ?thesis. qed qed section \Description of the basis\ text\The infinite part of the basis\ inductive_set \ :: "binA list set" where "[a1] \ [1-a1]\<^sup>@Suc t \ \" | "\ \ \ \ i \ t \ [a1] \ [1-a1]\<^sup>@i \ \ \ \" lemma \_nemp: "x \ \ \ x \ \" by (rule \.cases[of x "x \ \"], simp_all) lemma \_nemp': "x \ ({[1 - a1]} \ \) \ x \ \" - using \_nemp by blast + using \_nemp by blast lemma \_hd: "x \ \ \ hd x = a1" by (induction x rule: \.induct, simp_all) lemma \_set: "x \ \ \ a1 \ set x" - using \_hd \_nemp hd_in_set by blast + using \_hd \_nemp hd_in_set by blast lemma \_butlast_hd_tl: "x \ \ \ butlast x = [a1] \ butlast (tl x)" - by (induction x rule: \.induct, auto) + by (induction x rule: \.induct, auto) lemma \_suf: "x \ \ \ [a1] \[1-a1]\<^sup>@Suc t \s x" by (induction x rule: \.induct, simp_all add: suffix_Cons suffix_append) lemma \_fac: "x \ \ \ \ [1-a1]\<^sup>@Suc t \f butlast x" -proof (induction x rule: \.induct) +proof (induction x rule: \.induct) show "\ [1 - a1] \<^sup>@ Suc t \f butlast ([a1] \ [1 - a1] \<^sup>@ Suc t)" using fac_len_eq[of "[1 - a1] \<^sup>@ Suc t" "butlast ([a1] \ [1 - a1] \<^sup>@ Suc t)"] - unfolding pow_Suc2 lassoc butlast_snoc sing_pow_len lenmorph sing_len + unfolding pow_Suc' lassoc butlast_snoc sing_pow_len lenmorph sing_len unfolding pow_comm[of "[1-a1]"] add.commute[of t] cancel_right - using bin_swap_neq by fast - fix x' i + using bin_swap_neq by fast + fix x' i assume "x' \ \" and notf: "\ [1 - a1] \<^sup>@ Suc t \f butlast x'" and "i \ t" show "\ [1 - a1] \<^sup>@ Suc t \f butlast ([a1] \ [1 - a1] \<^sup>@ i \ x')" proof assume "[1 - a1] \<^sup>@ Suc t \f butlast ([a1] \ [1 - a1] \<^sup>@ i \ x')" - hence "[1 - a1] \<^sup>@ Suc t \f [a1] \ [1 - a1] \<^sup>@ i \ butlast x'" + hence "[1 - a1] \<^sup>@ Suc t \f [a1] \ [1 - a1] \<^sup>@ i \ butlast x'" unfolding lassoc butlast_append using \_nemp[OF \x' \ \\] by force - then obtain pp ss where fac: "pp \ [1 - a1] \<^sup>@ Suc t \ ss = ([a1] \ [1 - a1] \<^sup>@ i) \ butlast x'" unfolding rassoc by fast + then obtain pp ss where fac: "pp \ [1 - a1] \<^sup>@ Suc t \ ss = ([a1] \ [1 - a1] \<^sup>@ i) \ butlast x'" unfolding rassoc by fast from notf eqd[OF this[symmetric]] have "\ \<^bold>|[a1] \ [1 - a1] \<^sup>@ i\<^bold>| \ \<^bold>|pp\<^bold>|" unfolding fac_def by metis hence "\<^bold>|pp\<^bold>| \ i" unfolding lenmorph by simp have "pp \ \" - using fac clean_emp(2) bin_swap_neq[of a1] unfolding pow_Suc rassoc by force + using fac emp_simps(2) bin_swap_neq[of a1] unfolding pow_Suc rassoc by force have "Suc i < \<^bold>|pp\<^bold>| + Suc t" and "Suc i -\<^bold>|pp\<^bold>| < Suc t" using nemp_len[OF \pp \ \\] \i \ t\ by linarith+ have "(pp \ [1 - a1] \<^sup>@ Suc t \ ss)!(Suc i) = a1" unfolding fac \_butlast_hd_tl[OF \x' \ \\] using nth_append_length[of "[a1] \ [1 - a1] \<^sup>@ i" a1] unfolding lenmorph sing_pow_len sing_len swap_len by force from this[unfolded lassoc nth_append[of _ ss]] have "(pp \ [1 - a1] \<^sup>@ Suc t)!(Suc i) = a1" - unfolding lenmorph sing_pow_len using \Suc i < \<^bold>|pp\<^bold>| + Suc t\ by presburger - from this[unfolded nth_append] + unfolding lenmorph sing_pow_len using \Suc i < \<^bold>|pp\<^bold>| + Suc t\ by presburger + from this[unfolded nth_append] have "([1 - a1] \<^sup>@ Suc t)!(Suc i - \<^bold>|pp\<^bold>|) = a1" using \\<^bold>|pp\<^bold>| \ i\ by force thus False unfolding sing_pow_nth[OF \Suc i -\<^bold>|pp\<^bold>| < Suc t\] - using bin_swap_neq by blast + using bin_swap_neq by blast qed qed lemma pref_code_\: "pref_code ({[1-a1]} \ \)" proof - show nemp: "u \ {[1 - a1]} \ \ \ u \ \" for u + show nemp: "\ \ {[1 - a1]} \ \" using \_nemp by auto - show "u = v" if u_in: "u \ {[1 - a1]} \ \" and v_in: "v \ {[1 - a1]} \ \" and "u \p v" for u v + show "u = v" if u_in: "u \ {[1 - a1]} \ \" and v_in: "v \ {[1 - a1]} \ \" and "u \p v" for u v proof (rule bin_swap_exhaust[of "hd u" a1]) assume "hd u = 1 - a1" hence "u = [1-a1]" - using u_in[unfolded Un_def mem_Collect_eq] + using u_in[unfolded Un_def mem_Collect_eq] \_hd[of u] bin_swap_neq' by blast from sing_pref_hd[OF \u \p v\[unfolded this]] have "hd v = 1 - a1". hence "v = [1-a1]" - using v_in[unfolded Un_def mem_Collect_eq] + using v_in[unfolded Un_def mem_Collect_eq] \_hd[of v] bin_swap_neq' by blast with \u = [1-a1]\ show "u = v" by simp next assume "hd u = a1" - note nemp[OF u_in] and nemp[OF v_in] + have "u \ \" "v \ \" + using nemp u_in v_in by blast+ from pref_hd_eq[OF \u \p v\ \u \ \\] have "hd v = a1" using \hd u = a1\ by simp from u_in \hd u = a1\ bin_swap_neq[of a1] - have "u \ \" + have "u \ \" unfolding Un_def mem_Collect_eq using singletonD[of u "[1-a1]"] list.sel(1)[of "1-a1" \] by metis from \hd v = a1\ v_in \hd u = a1\ bin_swap_neq[of a1] - have "v \ \" + have "v \ \" unfolding Un_def mem_Collect_eq using singletonD[of v "[1-a1]"] list.sel(1)[of "1-a1" \] by metis from \_suf[OF \u \ \\] have "[1 - a1] \<^sup>@ Suc t \s u" - using suffix_appendD by blast + using suf_extD by blast hence "\ u \p butlast v" - using \_fac[OF \v \ \\] unfolding fac_def suf_def pref_def by fastforce + using \_fac[OF \v \ \\] unfolding fac_def suffix_def prefix_def by fastforce with \u \p v\ show "u = v" using spref_butlast_pref by blast qed qed lemma \_coin_blocks: assumes "x \ {[1 - a1]} \ \" shows "x \ \" -proof- +proof- consider "x = [1-a1]" | "x \ \" using \x \ {[1 - a1]} \ \\ by blast - thus "x \ \" + thus "x \ \" proof (cases) assume "x = [1-a1]" show "x \ \" unfolding \_def' \x = [1-a1]\ using swap_coin_block. next assume "x \ \" show "x \ \" - unfolding \_def' coin_block_with_bad_letter[OF \_set[OF \x \ \\]] using suffix_appendD[OF \_suf[OF \x \ \\]]. + unfolding \_def' coin_block_with_bad_letter[OF \_set[OF \x \ \\]] using suf_extD[OF \_suf[OF \x \ \\]]. qed qed lemma \_gen_T: "\{[1-a1]} \ \\ = \" proof - from subsetI[OF \_coin_blocks, THEN hull_mono] + from subsetI[OF \_coin_blocks, THEN hull_mono] show "\{[1 - a1]} \ \\ \ \" - unfolding \_hull. + unfolding \_hull. next show "\ \ \{[1 - a1]} \ \\" proof fix x assume "x \ \" from this[unfolded \_def'] have "coin_block x". thus "x \ \{[1 - a1]} \ \\" proof (induction "\<^bold>|x\<^bold>|" arbitrary: x rule: less_induct) case less show ?case proof (cases "\ px. px \ \ \ px

coin_block px") assume "\ px. px \ \ \ px

coin_block px" from exE[OF this] obtain px where "px \ \" and "px

px

] + from spref_exE[OF \px

] obtain sx where "px\sx = x" and "sx \ \". from \_pref[OF \coin_block px\ \coin_block x\[folded \px\sx = x\]] have "coin_block sx". have "\<^bold>|px\<^bold>| < \<^bold>|x\<^bold>|" and "\<^bold>|sx\<^bold>| < \<^bold>|x\<^bold>|" using \px\sx = x\ \px \ \\ \sx \ \\ by auto from less.hyps[OF this(1) \coin_block px\] less.hyps[OF this(2) \coin_block sx\] show "x \ \{[1 - a1]} \ \\" using \px\sx = x\ by auto next assume non_ex: "\ px. px \ \ \ px

coin_block px" show "x \ \{[1 - a1]} \ \\" proof (cases "a1 \ set x") assume "a1 \ set x" then obtain k where "x = [1 - a1]\<^sup>@k" using bin_without_letter by blast thus "x \ \{[1 - a1]} \ \\" using gen_in[THEN power_in] by fast next assume "a1 \ set x" hence "x \ \" by force have "hd x = a1" proof (rule ccontr) assume "hd x \ a1" hence "hd x = 1-a1" using bin_neq_iff by auto from non_ex swap_coin_block hd_tl[OF \x \ \\, unfolded this] have "tl x = \" by blast - from \[1 - a1] \ tl x = x\[unfolded this clean_emp] + from \[1 - a1] \ tl x = x\[unfolded this emp_simps] show False - using neq_in_set_not_pow[OF bin_swap_neq[of a1] \a1 \ set x\, of 1, unfolded clean_pows] by simp + using neq_in_set_not_pow[OF bin_swap_neq[of a1] \a1 \ set x\, of 1, unfolded exp_simps] by simp qed define j where "j = (LEAST k. \ [a1]\[1-a1]\<^sup>@Suc k \p x)" hence "\ [a1]\[1-a1]\<^sup>@(Suc t)

[a1]\[1-a1]\<^sup>@Suc(Suc t) \p x" - unfolding pow_Suc2[of _ "Suc t"] lassoc - using prefix_snocD by metis + unfolding pow_Suc'[of _ "Suc t"] lassoc + using prefix_snocD by metis from Least_le[of "\ i. \ ([a1]\[1-a1]\<^sup>@Suc i) \p x", OF this, folded j_def] have "j \ Suc t". have "\ [a1]\[1-a1]\<^sup>@ Suc j \p x" using LeastI[of "\ i. \ ([a1]\[1-a1]\<^sup>@Suc i) \p x", OF \\ ([a1]\[1-a1]\<^sup>@Suc(Suc t)) \p x\, folded j_def]. - have "[a1]\[1-a1]\<^sup>@j \p x" + have "[a1]\[1-a1]\<^sup>@j \p x" using not_less_Least[of "j-1" "\ i. \ ([a1]\[1-a1]\<^sup>@Suc i) \p x"] - unfolding j_def[symmetric] not_not + unfolding j_def[symmetric] not_not by (cases "j = 0", simp_all add: hd_pref[OF \x \ \\, unfolded \hd x = a1\]) show "x \ \{[1 - a1]} \ \\" proof(cases "j = Suc t") assume "j = Suc t" have "x = [a1]\[1-a1]\<^sup>@j" - using \[a1]\[1-a1]\<^sup>@j \p x\ \\ [a1] \ [1 - a1] \<^sup>@ Suc t

+ using \[a1]\[1-a1]\<^sup>@j \p x\ \\ [a1] \ [1 - a1] \<^sup>@ Suc t

unfolding \j = Suc t\ by force - from \.intros(1)[folded \j = Suc t\, folded this] - show "x \ \{[1 - a1]} \ \\" by auto + from \.intros(1)[folded \j = Suc t\, folded this] + show "x \ \{[1 - a1]} \ \\" by auto next assume "j \ Suc t" hence "j \ t" using \j \ Suc t\ by force from prefE[OF \[a1]\[1-a1]\<^sup>@j \p x\, unfolded rassoc] obtain x' where "x = [a1] \ [1-a1]\<^sup>@j \ x'". - with coin_exp_min[OF \j \ t\] \coin_block x\ + with coin_exp_min[OF \j \ t\] \coin_block x\ have "x' \ \" - by auto - from \\ [a1] \ [1-a1]\<^sup>@Suc j \p x\ hd_tl[OF this] - have "hd x' = a1" - unfolding \x = [a1] \ [1-a1]\<^sup>@j \ x'\ pow_Suc2 pref_cancel_conv - using bin_neq_iff'[of "hd x'" "1-a1", unfolded binsimp] by fastforce - from \[hd x'] \ tl x' = x'\[unfolded this] + by auto + from \\ [a1] \ [1-a1]\<^sup>@Suc j \p x\ hd_tl[OF this] + have "hd x' = a1" + unfolding \x = [a1] \ [1-a1]\<^sup>@j \ x'\ pow_Suc' pref_cancel_conv + using bin_neq_iff'[of "hd x'" "1-a1", unfolded binA_simps] by fastforce + from \[hd x'] \ tl x' = x'\[unfolded this] \coin_block x\[unfolded coin_block_with_bad_letter[OF \a1 \ set x\]] - have "[1-a1]\<^sup>@Suc t \s [a1] \ [1 - a1] \<^sup>@ j \ [a1] \ tl x'" + have "[1-a1]\<^sup>@Suc t \s [a1] \ [1 - a1] \<^sup>@ j \ [a1] \ tl x'" unfolding \x = [a1] \ [1-a1]\<^sup>@j \ x'\ by presburger have "a1 \ set ([1-a1]\<^sup>@Suc t)" using neq_in_set_not_pow[OF bin_swap_neq, of a1] by blast hence "\ [a1] \ tl x' \s [1-a1]\<^sup>@Suc t" - unfolding suf_def using Cons_eq_appendI in_set_conv_decomp by metis + unfolding suffix_def using Cons_eq_appendI in_set_conv_decomp by metis with ruler[reversed, of x', OF _ \[1-a1]\<^sup>@Suc t \s x\] - have "[1-a1]\<^sup>@Suc t \s x'" - unfolding \x = [a1] \ [1-a1]\<^sup>@j \ x'\ \[a1] \ tl x' = x'\ suf_def by fastforce + have "[1-a1]\<^sup>@Suc t \s x'" + unfolding \x = [a1] \ [1-a1]\<^sup>@j \ x'\ \[a1] \ tl x' = x'\ suffix_def by fastforce have "a1 \ set x'" - using \hd x' = a1\ \x' \ \\ hd_in_set by blast + using \hd x' = a1\ \x' \ \\ hd_in_set by blast from coin_block_with_bad_letter[OF this] have "coin_block x'" using \[1-a1]\<^sup>@Suc t \s x'\ by blast - have "\<^bold>|x'\<^bold>| < \<^bold>|x\<^bold>|" + have "\<^bold>|x'\<^bold>| < \<^bold>|x\<^bold>|" using lenarg[OF \x = [a1] \ [1-a1]\<^sup>@j \ x'\] unfolding lenmorph by simp - from less.hyps[OF this \coin_block x'\] + from less.hyps[OF this \coin_block x'\] obtain xs' where "xs' \ lists ({[1 - a1]} \ \)" and "concat xs' = x'" using hull_concat_listsE by blast have "xs' \ \" using \concat xs' = x'\ \x' \ \\ concat.simps(1) by blast from lists_hd_in_set[OF this \xs' \ lists ({[1 - a1]} \ \)\] have "hd xs' \ ({[1 - a1]} \ \)". from \_coin_blocks[OF this] \_nemp'[OF this] have "coin_block (hd xs')" and "hd xs' \ \" unfolding \_def'. have "hd (hd xs') = a1" using hd_concat[OF \xs' \ \\ \hd xs' \ \\, symmetric] unfolding \concat xs' = x'\ \hd x' = a1\. hence "hd xs' \ \" using \hd xs' \ ({[1 - a1]} \ \)\ bin_swap_neq[of a1] list.sel(1)[of "1-a1" \] - unfolding Un_def mem_Collect_eq singleton_iff by metis - hence "[a1] \ [1-a1]\<^sup>@j \ hd xs' \ \" + unfolding Un_def mem_Collect_eq singleton_iff by metis + hence "[a1] \ [1-a1]\<^sup>@j \ hd xs' \ \" using \j \ t\ \.intros(2) by blast with \_coin_blocks have "coin_block ([a1] \ [1-a1]\<^sup>@j \ hd xs')" unfolding \_def' Un_def by blast have "[a1] \ [1-a1]\<^sup>@j \ hd xs' \p x" - using hd_concat_tl[OF \xs' \ \\] + using hd_concat_tl[OF \xs' \ \\] unfolding \concat xs' = x'\ \x = [a1] \ [1-a1]\<^sup>@j \ x'\ by fastforce with non_ex \coin_block (hd xs')\ \hd xs' \ \\ have "x = [a1] \ [1-a1]\<^sup>@j \ hd xs'" - using \coin_block ([a1] \ [1 - a1] \<^sup>@ j \ hd xs')\ strict_prefixI suf_nemp by metis + using \coin_block ([a1] \ [1 - a1] \<^sup>@ j \ hd xs')\ strict_prefixI suf_nemp by metis from \[a1] \ [1-a1]\<^sup>@j \ hd xs' \ \\[folded this] show "x \ \{[1 - a1]} \ \\" by auto qed qed qed qed qed qed -lemma \_explicit: "\ = {w \ [a1] \ [1-a1]\<^sup>@Suc t | w. w \ \{[a1] \ [1-a1]\<^sup>@i | i. i \ t}\}" +lemma \_explicit: "\ = {w \ [a1] \ [1-a1]\<^sup>@Suc t | w. w \ \{[a1] \ [1-a1]\<^sup>@i | i. i \ t}\}" proof show "\ \ {w \ [a1] \ [1 - a1] \<^sup>@ Suc t |w. w \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\}" proof - fix x assume "x \ \" + fix x assume "x \ \" thus "x \ {w \ [a1] \ [1 - a1] \<^sup>@ Suc t |w. w \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\}" unfolding mem_Collect_eq - proof (induction x rule: \.induct, force) + proof (induction x rule: \.induct, simp) case (2 \ i) then obtain w where "\ = w \ [a1] \ [1 - a1] \<^sup>@ Suc t" and "w \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\" by blast - from hull.prod_cl[OF _ this(2), of "[a1] \ [1 - a1] \<^sup>@ i"] \i \ t\ + from hull.prod_cl[OF _ this(2), of "[a1] \ [1 - a1] \<^sup>@ i"] \i \ t\ have "[a1] \ [1 - a1] \<^sup>@ i \ w \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\" unfolding mem_Collect_eq by simp thus ?case using \\ = w \ [a1] \ [1 - a1] \<^sup>@ Suc t\ by auto qed qed next show "{w \ [a1] \ [1 - a1] \<^sup>@ Suc t |w. w \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\} \ \" proof fix x assume "x \ {w \ [a1] \ [1 - a1] \<^sup>@ Suc t |w. w \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\}" then obtain w where "x = w \ [a1] \ [1 - a1] \<^sup>@ Suc t" and "w \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\" unfolding mem_Collect_eq by blast show "x \ \" unfolding \x = w \ [a1] \ [1 - a1] \<^sup>@ Suc t\ by (rule hull.induct[OF \w \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\\], use \.intros(1) in force) (use \.intros(2) in force) qed qed -theorem infinite_basis: "\ \ = ({[1-a1]} \ \)" +theorem infinite_basis: "\ \ = ({[1-a1]} \ \)" using basis_of_hull[of "{[1-a1]} \ \"] unfolding \_gen_T code.code_is_basis[OF pref_code.code, OF pref_code_\]. end section Intersection lemma bin_inter_coin_set_fst: "\{x,y}\ \ \{u,v}\ = ((bin_morph_of x y) \ fst) ` \ (bin_morph_of x y) (bin_morph_of u v)" using bin_morph_of_range coin_set_inter_fst by metis lemma bin_inter_coin_set_snd: "\{x,y}\ \ \{u,v}\ = ((bin_morph_of u v) \ snd) ` \ (bin_morph_of x y) (bin_morph_of u v)" using bin_inter_coin_set_fst unfolding coin_set_eq. -theorem bin_inter_basis: assumes "binary_code x y" and "binary_code u v" +theorem bin_inter_basis: assumes "binary_code x y" and "binary_code u v" shows "\ (\{x,y}\ \ \{u,v}\) = ((bin_morph_of u v) \ snd) ` \\<^sub>m (bin_morph_of x y) (bin_morph_of u v)" unfolding bin_inter_coin_set_snd - using two_code_morphisms.range_inter_basis_snd(1)[OF two_code_morphisms.intro, OF bin_code_code_morph bin_code_code_morph, OF assms, folded coin_set_inter_snd] unfolding image_comp. + using two_code_morphisms.range_inter_basis_snd(1)[OF two_code_morphisms.intro, OF binary_code.code_morph_of binary_code.code_morph_of, OF assms, folded coin_set_inter_snd] unfolding image_comp. theorem binary_intersection_code: - assumes "binary_code x y" and "binary_code u v" - shows "code \ (\{x,y}\ \ \{u,v}\)" - using two_code_morphisms.range_inter_code[OF two_code_morphisms.intro[OF bin_code_code_morph[OF assms(1)] bin_code_code_morph[OF assms(2)]]] - unfolding bin_morph_of_range. + assumes "binary_code x y" and "binary_code u v" + shows "code \ (\{x,y}\ \ \{u,v}\)" + using two_code_morphisms.range_inter_code[OF two_code_morphisms.intro[OF binary_code.code_morph_of[OF assms(1)] binary_code.code_morph_of[OF assms(2)]]] + unfolding bin_morph_of_range. theorem binary_intersection: assumes "binary_code x y" and "binary_code u v" obtains - "\ (\{x,y}\ \ \{u,v}\) = {}" - | + "\ (\{x,y}\ \ \{u,v}\) = {}" + | \ where "\ (\{x,y}\ \ \{u,v}\) = {\}" - | + | \ \ where "\ (\{x,y}\ \ \{u,v}\) = {\,\}" - | - \ \ \ \ where "\ \ \" and "\ \ \ \ \" and "hd \ \ hd (\ \ \)" + | + \ \ \ \ where "\ \ \" and "\ \ \ \ \" and "hd \ \ hd (\ \ \)" "\ (\{x,y}\ \ \{u,v}\) = {\ \ \} \ {\ \ (\ \ \)\<^sup>@\ \ w \ \ \ \ | w. w \ \{\ \ (\ \ \)\<^sup>@i | i. i \ \}\}" | \ \ \ \ \ where "\ \ \"and "\ \ \ \ \" and "hd \ \ hd (\ \ \)" and "1 \ \ \ \ \ \" and "\ (\{x,y}\ \ \{u,v}\) = {\ \ \} \ {\ \ (\ \ \)\<^sup>@\ \ w \ \\<^sup><\(\ \ (\ \ \)\<^sup>@(\-\)) | - w. w \ \{\ \ (\ \ \)\<^sup>@i | i. i \ \ - 1}\}" + w. w \ \{\ \ (\ \ \)\<^sup>@i | i. i \ \ - 1}\}" proof- define x' where "x' = (if \<^bold>|bin_lcp u v\<^bold>| \ \<^bold>|bin_lcp x y\<^bold>| then x else u)" define y' where "y' = (if \<^bold>|bin_lcp u v\<^bold>| \ \<^bold>|bin_lcp x y\<^bold>| then y else v)" define u' where "u' = (if \<^bold>|bin_lcp u v\<^bold>| \ \<^bold>|bin_lcp x y\<^bold>| then u else x)" define v' where "v' = (if \<^bold>|bin_lcp u v\<^bold>| \ \<^bold>|bin_lcp x y\<^bold>| then v else y)" have lcp_le: "\<^bold>|bin_lcp u' v'\<^bold>| \ \<^bold>|bin_lcp x' y'\<^bold>|" unfolding x'_def y'_def u'_def v'_def by simp - have int': "\{x,y}\ \ \{u,v}\ = \{x',y'}\ \ \{u',v'}\" - unfolding x'_def y'_def u'_def v'_def using Int_commute by force + have int': "\{x,y}\ \ \{u,v}\ = \{x',y'}\ \ \{u',v'}\" + unfolding x'_def y'_def u'_def v'_def using Int_commute by force have assms': "binary_code x' y'" "binary_code u' v'" using assms unfolding x'_def y'_def u'_def v'_def by simp_all - define first_morphism ("g") - where "first_morphism \ bin_morph_of x' y'" + define first_morphism ("g ") + where "first_morphism \ bin_morph_of x' y'" define second_morphism ("h") - where "second_morphism \ bin_morph_of u' v'" - note mdefs = first_morphism_def second_morphism_def + where "second_morphism \ bin_morph_of u' v'" + note mdefs = first_morphism_def second_morphism_def have ranges: "range g = \{x',y'}\" "range h = \{u',v'}\" unfolding mdefs bin_morph_of_range by blast+ have nemp: "x' \ \" "y' \ \" "u' \ \" "v' \ \" using assms' binary_code.non_comm by blast+ - interpret two_nonerasing_morphisms g h - by (simp add: assms'(1) assms'(2) bin_code_morph_iff binary_code.non_comm first_morphism_def second_morphism_def two_bin_code_morphs_nonerasing_morphs) + interpret two_binary_code_morphisms g h + using two_binary_code_morphisms.intro + unfolding binary_code_morphism_def first_morphism_def second_morphism_def + using binary_code.code_morph_of assms' by blast - interpret two_binary_code_morphisms g h - by (metis assms'(1) assms'(2) bin_code_morph_iff binary_code.bin_not_comp_suf first_morphism_def second_morphism_def suf_comp_refl two_binary_code_morphisms_def two_binary_morphisms_def two_morphisms_axioms) + interpret two_nonerasing_morphisms g h + using code.two_nonerasing_morphisms_axioms. show thesis proof (cases) assume "\\<^sub>m g h = {}" \ \simple case: coincidence set is empty\ - have "\{x',y'}\ \ \{u',v'}\ = {\}" + have "\{x',y'}\ \ \{u',v'}\ = {\}" unfolding bin_inter_coin_set_snd image_comp[symmetric] mdefs[symmetric] - min_coin_gen_snd[symmetric, unfolded \\\<^sub>m g h = {}\] + code.min_coin_gen_snd[symmetric, unfolded \\\<^sub>m g h = {}\] by (simp add: emp_gen_set) from that(1)[unfolded int' this] show ?thesis - unfolding emp_basis_iff by simp - next + unfolding emp_basis_iff by simp + next assume "\\<^sub>m g h \ {}" then obtain r1 s1 where "g r1 =\<^sub>m h s1" unfolding min_coincidence_set_def by blast interpret binary_codes_coincidence g h proof show "\r s. g r =\<^sub>m h s" using \g r1 =\<^sub>m h s1\ by blast - show "\<^bold>|h.bin_code_lcp\<^bold>| \ \<^bold>|g.bin_code_lcp\<^bold>|" - unfolding bin_morph_ofD mdefs using lcp_le. + show "\<^bold>|h.bin_code_lcp\<^bold>| \ \<^bold>|g.bin_code_lcp\<^bold>|" + unfolding bin_morph_ofD mdefs using lcp_le. qed show thesis proof (cases) assume "\\<^sub>m g h = {(r1,s1)}" \ \min. coincidence set contains 1 element\ - from that(2)[unfolded int'] - show thesis + from that(2)[unfolded int'] + show thesis unfolding bin_inter_basis [OF assms', unfolded \\\<^sub>m g h = {(r1,s1)}\[unfolded mdefs] image_comp[symmetric]] by simp next assume "\\<^sub>m g h \ {(r1,s1)}" \ \min. coincidence set contains more than 1 element\ then obtain r2 s2 where "(r2,s2) \ \\<^sub>m g h" and "(r2,s2) \ (r1,s1)" using \\\<^sub>m g h \ {}\ by auto from min_coin_setD[OF this(1)] \g r1 =\<^sub>m h s1\ this(2) interpret binary_codes_coincidence_two_generators g h by unfold_locales auto write g.marked_version ("g\<^sub>m") and h.marked_version ("h\<^sub>m") and fst_beginning_block ("p") and snd_beginning_block ("q") and h.bin_code_lcp ("\\<^sub>h") and - marked.suc_snd ("\") + marked.suc_snd ("\") show thesis proof(cases) - assume "\ a. coin_block [a]" + assume "\ a. coin_block [a]" hence "\ a. coin_block [a]" by force - define \ where "\ = (h \ (\x. (q \ x)\<^sup><\q ) \ \) \" - define \ where "\ = (h \ (\x. (q \ x)\<^sup><\q ) \ \) \" + define \ where "\ = (h \ (\x. (q \ x)\<^sup><\q ) \ \) \" + define \ where "\ = (h \ (\x. (q \ x)\<^sup><\q ) \ \) \" have "range (bin_morph_of x' y') = \{x',y'}\" using bin_morph_of_range by auto from that(3)[ of \ \, unfolded int' \_def \_def mdefs[symmetric]] show thesis using inter_basis[unfolded simple_blocks_basis[OF \\ a. coin_block [a]\] bin_morph_of_range] unfolding ranges by blast next assume "\ (\ a. coin_block [a])" then obtain a1 where "\ coin_block [a1]" by blast then interpret binary_codes_coincidence_infinite g h a1 - by unfold_locales + by unfold_locales write coincidence_exponent ("t") from inter_basis[unfolded ranges infinite_basis bin_morph_of_range, folded Setcompr_eq_image, unfolded mem_Collect_eq] have inter:"\ (\{x', y'}\ \ \{u', v'}\) = {(h \ (\x. (q \ x)\<^sup><\q ) \ \) x |x. x \ {[1 - a1]} \ \}". have "q \s q \ \ [1 - a1]" using swap_coin_block[unfolded coin_block_def] by blast from conjug_eqE[OF rq_suf[OF this]] conjug_emp_emp'[OF this] marked.sucs.h.sing_to_nemp - obtain q1 q2 k where q21: "\ [1 - a1] = q2 \ q1" and - q_def: "q = (q1 \ q2)\<^sup>@k \ q1" and "q2 \ \" + obtain q1 q2 k where q21: "\ [1 - a1] = q2 \ q1" and + q_def: "q = (q1 \ q2)\<^sup>@k \ q1" and "q2 \ \" by metis have "(h q1 \ h q2) \ (h q1 \ \\<^sub>h) = (h q1 \ \\<^sub>h) \ (h\<^sub>m q2 \ h\<^sub>m q1)" - unfolding rassoc h.marked_version_conjugates[of "q2 \ q1", unfolded marked.h.morph h.morph].. + unfolding rassoc h.marked_version_conjugates[of "q2 \ q1", unfolded hm.morph h.morph].. from conjug_eqE[OF this] h.nemp_to_nemp[OF \q2 \ \\] obtain \ \ k' where bg: "\ \ \ = h (q1 \ q2)" and "\ \ \ = h\<^sub>m (q2 \ q1)" and - k': "\ \ (\ \ \)\<^sup>@k' = h q1 \ \\<^sub>h" and "\ \ \" - unfolding marked.h.morph h.morph shift_pow by blast + k': "\ \ (\ \ \)\<^sup>@k' = h q1 \ \\<^sub>h" and "\ \ \" + unfolding hm.morph h.morph shift_pow by blast have bgb_q: "\ \ (\ \ \)\<^sup>@(k' + k) = \\<^sub>h \ h\<^sub>m q" unfolding add_exps lassoc \\ \ (\ \ \)\<^sup>@k' = h q1 \ \\<^sub>h\ unfolding \\ \ \ = h\<^sub>m (q2 \ q1)\ h.marked_version_conjugates[symmetric] - rassoc cancel q_def shift_pow unfolding marked.h.morph marked.h.pow_morph.. + rassoc cancel q_def shift_pow unfolding hm.morph hm.pow_morph.. define \ where "\ = h\<^sub>m (\ [a1])" have bg_def: "\ \ \ = h ((q \ \ [1 - a1])\<^sup><\q )" - unfolding bg q_def q21 rassoc shift_pow pow_comm using rq_triv - marked.h.morph by force - have bg_def': "(h \ (\x. (q \ x)\<^sup><\q ) \ \) [1-a1] = \ \ \" + unfolding bg q_def q21 rassoc shift_pow pow_comm + unfolding lassoc[of "q1"] + unfolding rq_triv.. + have bg_def': "(h \ (\x. (q \ x)\<^sup><\q ) \ \) [1-a1] = \ \ \" using bg_def by simp have gb_def: "\ \ \ = h\<^sub>m (\ [1 - a1])" - unfolding \\ \ \ = h\<^sub>m (q2 \ q1)\ q21.. + unfolding \\ \ \ = h\<^sub>m (q2 \ q1)\ q21.. have "\ \ \ \ \" using \\ \ \\ by blast have "\ \ \" - unfolding \_def using marked.h.nonerasing marked.sucs.h.sing_to_nemp by blast + unfolding \_def using hm.nonerasing marked.sucs.h.sing_to_nemp by blast have "hd \ \ hd (\ \ \)" unfolding \_def gb_def - using marked.h.hd_im_eq_hd_eq marked.sucs.h.bin_marked_sing marked.sucs.h.sing_to_nemp by blast + using hm.hd_im_eq_hd_eq marked.sucs.h.bin_marked_sing marked.sucs.h.sing_to_nemp by blast have w_decode: "w \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\ \ h\<^sub>m (\ w) \ \{\ \ (\ \ \) \<^sup>@ i |i. i \ t}\" for w - proof (induct w rule: hull.induct, unfold marked.sucs.h.emp_to_emp marked.h.emp_to_emp, fast) + proof (induct w rule: hull.induct, unfold marked.sucs.h.emp_to_emp hm.emp_to_emp, fast) case (prod_cl w1 w2) then obtain i where "w1 = [a1] \ [1-a1]\<^sup>@i" and "i \ t" by blast with prod_cl.hyps - show ?case - unfolding marked.sucs.h.morph marked.sucs.h.pow_morph marked.h.morph - marked.h.pow_morph \w1 = [a1] \ [1-a1]\<^sup>@i\ \_def[symmetric] gb_def[symmetric] - by fast + show ?case + unfolding marked.sucs.h.morph marked.sucs.h.pow_morph hm.morph + hm.pow_morph \w1 = [a1] \ [1-a1]\<^sup>@i\ \_def[symmetric] gb_def[symmetric] + by blast qed have w_decode': "w \ \{\ \ (\ \ \) \<^sup>@ i |i. i \ t}\ \ \ w'. w' \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\ \ h\<^sub>m (\ w') = w" for w - proof (induct w rule: hull.induct, use marked.sucs.h.emp_to_emp marked.h.emp_to_emp in force) + proof (induct w rule: hull.induct, use marked.sucs.h.emp_to_emp hm.emp_to_emp in force) case (prod_cl w1 w2) then obtain w' j where "w' \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\" and "h\<^sub>m (\ w') = w2" and "w1 = \ \ (\ \ \) \<^sup>@ j" and "j \ t" by blast have "([a1] \ [1 - a1] \<^sup>@ j) \ w' \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\" - using \w' \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\\ \j \ t\ by fast + using \w' \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\\ \j \ t\ by blast moreover have "h\<^sub>m (\ (([a1] \ [1 - a1] \<^sup>@ j) \ w')) = w1 \ w2" - unfolding marked.sucs.h.morph marked.sucs.h.pow_morph marked.h.morph marked.h.pow_morph \h\<^sub>m (\ w') = w2\ + unfolding marked.sucs.h.morph marked.sucs.h.pow_morph hm.morph hm.pow_morph \h\<^sub>m (\ w') = w2\ \_def[symmetric] gb_def[symmetric] \w1 = \ \ (\ \ \) \<^sup>@ j\.. ultimately show " \w'. w' \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\ \ h\<^sub>m (\ w') = w1 \ w2" by blast qed show thesis proof (cases) assume "\\<^sub>h \ h\<^sub>m q m (\ ([1-a1]\<^sup>@Suc t))" - from ssuf_extD[OF this[unfolded bgb_q[symmetric] marked.sucs.h.pow_morph q21 gb_def marked.h.pow_morph]] - have "k' + k < Suc t" - unfolding marked.sucs.h.pow_morph[symmetric] using comp_pows_ssuf by blast + from ssuf_extD[OF this[unfolded bgb_q[symmetric] marked.sucs.h.pow_morph q21 gb_def hm.pow_morph]] + have "k' + k < Suc t" + unfolding marked.sucs.h.pow_morph[symmetric] using comp_pows_ssuf by blast have "\ q \s \ ([1-a1]\<^sup>@t)" unfolding marked.sucs.h.pow_morph using exp_min. hence "t \ k" unfolding marked.sucs.h.pow_morph q21 q_def shift_pow - using comp_pows_not_suf by blast + using comp_pows_not_suf by blast hence "t = k" and "k' = 0" using \k' + k < Suc t\ by force+ from bgb_q[folded \t = k\, unfolded \k' = 0\] have "\ \ (\ \ \) \<^sup>@ t = \\<^sub>h \ h\<^sub>m q" by simp have "q \s \ [1 - a1] \<^sup>@ Suc t" - unfolding q_def \t = k\ q21 pow_Suc shift_pow by force + unfolding q_def \t = k\ q21 pow_Suc shift_pow by force have "\ = h q1 \ \\<^sub>h" - using \\ \ (\ \ \)\<^sup>@k' = h q1 \ \\<^sub>h\[unfolded \k' = 0\ clean_pows]. - from gb_def[unfolded q21 marked.h.morph this h.marked_version_conjugates[symmetric]] - have "\ \ \\<^sub>h = h\<^sub>m q2" + using \\ \ (\ \ \)\<^sup>@k' = h q1 \ \\<^sub>h\[unfolded \k' = 0\ cow_simps]. + from gb_def[unfolded q21 hm.morph this h.marked_version_conjugates[symmetric]] + have "\ \ \\<^sub>h = h\<^sub>m q2" by force from h.marked_version_conjugates[of q2, folded this] have "h ((\ [1 - a1] \<^sup>@ Suc t)\<^sup><\q) = \\<^sub>h \ \" unfolding q_def \t = k\ q21 pow_Suc shift_pow rassoc rq_triv by force have apply_h0: "h ((q \ \ (w \ [a1] \ [1 - a1] \<^sup>@ Suc t))\<^sup><\q) = \ \ (\ \ \)\<^sup>@t \ h\<^sub>m (\ w) \ \ \ \" for w proof- have "\ \ (\ \ \)\<^sup>@t \ h\<^sub>m (\ w) \ \ \ \ = \\<^sub>h \ h\<^sub>m (q \ \ (w \ [a1])) \ \" - unfolding marked.h.morph marked.sucs.h.morph \_def lassoc cancel_right \\ \ (\ \ \) \<^sup>@ t = \\<^sub>h \ h\<^sub>m q\.. - also have "... = h (q \ \ (w \ [a1])) \ h ((\ [1 - a1] \<^sup>@ Suc t)\<^sup><\q)" + unfolding hm.morph marked.sucs.h.morph \_def lassoc cancel_right \\ \ (\ \ \) \<^sup>@ t = \\<^sub>h \ h\<^sub>m q\.. + also have "... = h (q \ \ (w \ [a1])) \ h ((\ [1 - a1] \<^sup>@ Suc t)\<^sup><\q)" unfolding lassoc h.marked_version_conjugates unfolding \h ((\ [1 - a1] \<^sup>@ Suc t)\<^sup><\q) = \\<^sub>h \ \\ rassoc.. - finally show ?thesis + finally show ?thesis unfolding h.morph[symmetric] marked.sucs.h.morph marked.sucs.h.pow_morph - rq_reassoc[OF \q \s \ [1 - a1] \<^sup>@ Suc t\, of "q \ \ w \ \ [a1]"] + rq_reassoc[OF \q \s \ [1 - a1] \<^sup>@ Suc t\, of "q \ \ w \ \ [a1]"] unfolding rassoc by argo qed have inf_part_equal: "{(h \ (\x. (q \ x)\<^sup><\q ) \ \) (w \ [a1] \ [1 - a1] \<^sup>@ Suc t) |w. w \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\} = {\ \ (\ \ \) \<^sup>@ t \ w \ \ \ \ |w. w \ \{\ \ (\ \ \) \<^sup>@ i |i. i \ t}\}" (is "?I = ?E") proof show "?I \ ?E" proof fix x assume "x \ ?I" then obtain w where "x = h ((q \ \ (w \ [a1] \ [1 - a1] \<^sup>@ Suc t))\<^sup><\q )" and "w \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\" unfolding mem_Collect_eq o_apply by blast from this(1)[unfolded apply_h0] w_decode[OF this(2)] show "x \ ?E" by blast qed next show "?E \ ?I" proof fix x assume "x \ ?E" then obtain w where x: "x = \ \ (\ \ \) \<^sup>@ t \ w \ \ \ \" and " w \ \{\ \ (\ \ \) \<^sup>@ i |i. i \ t}\" by blast from w_decode'[OF this(2)] obtain w' where "w' \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\" and "h\<^sub>m (\ w') = w" by blast from x[folded this(2), folded apply_h0[of w']] this(1) - show "x \ ?I" + show "x \ ?I" unfolding o_apply by blast - qed + qed qed from that(4)[OF \\ \ \\ \\ \ \ \ \\ \hd \ \ hd (\ \ \)\, unfolded int', of t, unfolded inter, folded inf_part_equal bg_def', unfolded \_explicit] - show thesis - by blast + show thesis + by blast next assume "\ \\<^sub>h \ h\<^sub>m q m (\ ([1-a1]\<^sup>@Suc t))" note not_suf = this[unfolded marked.sucs.h.pow_morph q21] have "\\<^sub>h \ h\<^sub>m q \s (\\<^sub>h \ h\<^sub>m q) \ h\<^sub>m ((q2 \ q1) \<^sup>@ Suc t)" - unfolding q_def shift_pow rassoc marked.h.morph[symmetric] pows_comm[of _ k] - unfolding marked.h.morph lassoc suf_cancel_conv - unfolding rassoc marked.h.morph[symmetric] shift_pow[symmetric] - unfolding marked.h.morph lassoc suf_cancel_conv + unfolding q_def shift_pow rassoc hm.morph[symmetric] pows_comm[of _ k] + unfolding hm.morph lassoc suf_cancel_conv + unfolding rassoc hm.morph[symmetric] shift_pow[symmetric] + unfolding hm.morph lassoc suf_cancel_conv unfolding h.marked_version_conjugates by blast from ruler[reversed, of "\\<^sub>h \ h\<^sub>m q" _ "h\<^sub>m ((q2 \ q1) \<^sup>@ Suc t)", OF _ triv_suf, - of "\\<^sub>h \ h\<^sub>m q", OF this] - have "h\<^sub>m ((q2\q1)\<^sup>@Suc t) \s \\<^sub>h \ h\<^sub>m q" - unfolding marked.sucs.h.pow_morph q21 using not_suf by force - from this[unfolded q_def shift_pow marked.h.morph, unfolded marked.h.pow_morph, folded gb_def[unfolded q21], unfolded lassoc, + of "\\<^sub>h \ h\<^sub>m q", OF this] + have "h\<^sub>m ((q2\q1)\<^sup>@Suc t) \s \\<^sub>h \ h\<^sub>m q" + unfolding marked.sucs.h.pow_morph q21 using not_suf by force + from this[unfolded q_def shift_pow hm.morph, unfolded hm.pow_morph, folded gb_def[unfolded q21], unfolded lassoc, folded k'[folded h.marked_version_conjugates], unfolded rassoc add_exps[symmetric]] have "Suc t \ k' + k" using comp_pows_suf'[OF \\ \ \\] by blast from le_add_diff_inverse2[OF this] have split: "\ \ (\ \ \) \<^sup>@ (k' + k) = \ \ (\ \ \) \<^sup>@ (k' + k - Suc t) \ (\ \ \) \<^sup>@ Suc t" - unfolding add_exps[symmetric] by argo + unfolding add_exps[symmetric] by argo have "\\<^sub>h \ h\<^sub>m q = \ \ (\ \ \) \<^sup>@ (k' + k)" - unfolding q_def shift_pow marked.h.morph - unfolding marked.h.pow_morph gb_def[symmetric, unfolded q21] lassoc k'[folded h.marked_version_conjugates, symmetric] - unfolding rassoc add_exps.. + unfolding q_def shift_pow hm.morph + unfolding hm.pow_morph gb_def[symmetric, unfolded q21] lassoc k'[folded h.marked_version_conjugates, symmetric] + unfolding rassoc add_exps.. have q_suf: "q \s \ ([a1] \ [1 - a1] \<^sup>@ Suc t)" - unfolding q_suf_conv by blast + unfolding q_suf_conv by blast have q_suf': "q \s q \ \ ((w \ [a1]) \ [1 - a1] \<^sup>@ Suc t)" for w - using suf_ext[OF q_suf, of "q \ \ w"] unfolding marked.sucs.h.morph rassoc. + using suf_ext[OF q_suf, of "q \ \ w"] unfolding marked.sucs.h.morph rassoc. - note long = rich_block_suf_snd'[of \ "1-a1", unfolded clean_emp binsimp, OF coin_exp] + note long = rich_block_suf_snd'[of \ "1-a1", unfolded emp_simps binA_simps, OF coin_exp] - have delta_suf: "(\ \ (\ \ \) \<^sup>@ (k' + k - Suc t)) \s \" - using long unfolding bgb_q[symmetric] \_def marked.sucs.h.morph marked.sucs.h.pow_morph q21 marked.h.morph - unfolding marked.h.pow_morph gb_def[unfolded q21,symmetric] split + have delta_suf: "(\ \ (\ \ \) \<^sup>@ (k' + k - Suc t)) \s \" + using long unfolding bgb_q[symmetric] \_def marked.sucs.h.morph marked.sucs.h.pow_morph q21 hm.morph + unfolding hm.pow_morph gb_def[unfolded q21,symmetric] split unfolding lassoc suf_cancel_conv. - have apply_h0: "h ((q \ \ (w \ [a1] \ [1 - a1] \<^sup>@ Suc t))\<^sup><\q) + have apply_h0: "h ((q \ \ (w \ [a1] \ [1 - a1] \<^sup>@ Suc t))\<^sup><\q) = \ \ (\ \ \) \<^sup>@ (k' + k) \ h\<^sub>m (\ w) \ \\<^sup><\(\ \ (\ \ \) \<^sup>@ (k' + k - Suc t))" for w - unfolding cancel_right[symmetric, of "h ((q \ \ (w \ [a1] \ [1 - a1] \<^sup>@ Suc t))\<^sup><\q)" _ "(\ \ (\ \ \) \<^sup>@ (k' + k - Suc t))"] - unfolding rassoc rq_suf[OF delta_suf] - unfolding cancel_right[symmetric, of _ "\ \ (\ \ \) \<^sup>@ (k' + k) \ h\<^sub>m (\ w) \ \" "(\ \ \) \<^sup>@ Suc t"] + unfolding cancel_right[symmetric, of "h ((q \ \ (w \ [a1] \ [1 - a1] \<^sup>@ Suc t))\<^sup><\q)" _ "(\ \ (\ \ \) \<^sup>@ (k' + k - Suc t))"] + unfolding rassoc rq_suf[OF delta_suf] + unfolding cancel_right[symmetric, of _ "\ \ (\ \ \) \<^sup>@ (k' + k) \ h\<^sub>m (\ w) \ \" "(\ \ \) \<^sup>@ Suc t"] unfolding rassoc add_exps[symmetric] \k' + k - Suc t + Suc t = k' + k\ bgb_q[unfolded h.marked_version_conjugates] unfolding lassoc h.morph[symmetric] unfolding rassoc rq_suf[OF q_suf', unfolded rassoc, of w] - unfolding h.marked_version_conjugates[symmetric] marked.h.morph marked.sucs.h.morph - unfolding lassoc bgb_q unfolding rassoc \_def gb_def marked.h.pow_morph marked.sucs.h.pow_morph.. - + unfolding h.marked_version_conjugates[symmetric] hm.morph marked.sucs.h.morph + unfolding lassoc bgb_q unfolding rassoc \_def gb_def hm.pow_morph marked.sucs.h.pow_morph.. + have inf_part_equal: "{(h \ (\x. (q \ x)\<^sup><\q ) \ \) (w \ [a1] \ [1 - a1] \<^sup>@ Suc t) |w. w \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\} = {\ \ (\ \ \) \<^sup>@ (k' + k) \ w \ \\<^sup><\(\ \ (\ \ \) \<^sup>@ (k' + k - Suc t)) |w. w \ \{\ \ (\ \ \) \<^sup>@ i |i. i \ t}\}" (is "?I = ?E") proof show "?I \ ?E" proof fix x assume "x \ ?I" then obtain w where "x = h ((q \ \ (w \ [a1] \ [1 - a1] \<^sup>@ Suc t))\<^sup><\q )" and "w \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\" unfolding mem_Collect_eq o_apply apply_h0 by blast from this(1)[unfolded apply_h0] w_decode[OF this(2)] show "x \ ?E" by blast qed next show "?E \ ?I" proof fix x assume "x \ ?E" then obtain w where x: "x = \ \ (\ \ \) \<^sup>@ (k' + k) \ w \ \\<^sup><\(\ \ (\ \ \) \<^sup>@ (k' + k - Suc t))" and " w \ \{\ \ (\ \ \) \<^sup>@ i |i. i \ t}\" by blast from w_decode'[OF this(2)] obtain w' where "w' \ \{[a1] \ [1 - a1] \<^sup>@ i |i. i \ t}\" and "h\<^sub>m (\ w') = w" by blast - from x[folded this(2), folded apply_h0[of w']] this(1) + from x[folded this(2), folded apply_h0[of w']] this(1) show "x\ ?I" unfolding o_apply by blast - qed + qed qed - have "1 \ Suc t \ Suc t \ k' + k" using \Suc t \ k' + k\ by simp - from that(5)[OF \\ \ \\ \\ \ \ \ \\ \hd \ \ hd (\ \ \)\ this] - show thesis + have "1 \ Suc t \ Suc t \ k' + k" using \Suc t \ k' + k\ by simp + from that(5)[OF \\ \ \\ \\ \ \ \ \\ \hd \ \ hd (\ \ \)\ this] + show thesis unfolding diff_Suc_1 unfolding int' unfolding inter \_explicit bg_def'[symmetric] - unfolding inf_part_equal[symmetric] by blast + unfolding inf_part_equal[symmetric] by blast qed qed qed qed qed -end \ No newline at end of file +end