1
$\begingroup$

I have two letters A,B. I want to generate all words say up to length 22 with the following properties. There is no "canonical" list so any such list will suffice, though there are many possiblities.

  1. No two words are cyclic permutations of each other ($A^2BAB^2,BAB^2A^2$ are cyclic permutations of each other)
  2. No two words are mirrors of each other (Say $A^2BAB^2,B^2ABA^2$ are mirrors of each other)
  3. No word can be attained by substitution using any of the other words.(More complicated to find this which is not a combination of 1,2 but consider $A^2BAB^2$ and $B^2ABA^2$ and perform the substitution $B\to A^2BAB^2$, after cyclic permutations, we get the words $A^4BAB^2A^3BAB^2A^2BAB^2$ and $A^4BAB^2A^2BAB^2A^3BAB^2$ only one of these words should appear on the list).
  4. No words should be equal under the combination of 1,2,3

List satisfying 1. is just Lyndon words and that can be found efficiently. However, how do I quickly check for 2,3 and 4? The problem is 4. Individually checking 2,3 should not be too hard but looking for words that can be achieved through combinations of 1,2,3 seems impossible to do in a clever way. But perhaps I am wrong and just not seeing the trick. Any help would be appreciated.

I have been asked to provide my code for 1. so here is my rough idea:

a[i_, k_, j_] := 
 StringJoin[StringRepeat["A", i], 
  StringJoin["B", Tuples[{"A", "B"}, k][[j]]]]
Flatten[Table[
  Flatten[Table[a[t, k, j], {k, 1, 4 - t}, {j, 1, 2^k}]], {t, 1, 3}]]

I bet it can be done cleaner but it does the job. All Lyndon words up to length 5.

Building on Pierre's code I can do 1 and 2.:

cycofmirror[n_] := 
 Table[StringRotateRight[StringReverse[n], i], {i, 1, 
   StringLength[n]}]
f[m_] := Piecewise[
  {{"Normal", Intersection[cycofmirror[m], wordList] == {m}}}, 
  "Weird"]
list = GroupBy[wordList, f]
weirds = list["Weird"]
Do[If[MemberQ[weirds, Intersection[cycofmirror[i], weirds][[1]]], 
   weirds = Delete[weirds, Position[weirds, i]]];
 
 , {i, list["Weird"]}]
Lyndonnomirror = Union[list["Normal"], weirds]

Not elegant I know... I was struggling to figure out how to pick out one mirror and remove it from the list. I resorted to removing all mirror pairs, and then adding one of them.

$\endgroup$
12
  • 1
    $\begingroup$ What have you tried so far? You say that the first step can be done efficiently. Please include the MMA code you have for that, and any further attempts you have. $\endgroup$
    – MarcoB
    Jun 19, 2022 at 12:46
  • $\begingroup$ @MarcoB I added my rudimentary code for generating Lyndon Words. $\endgroup$
    – 2132123
    Jun 19, 2022 at 13:26
  • $\begingroup$ I have trouble understanding the definition, in particular in item 3 I am confused by "no word can be attained by..." which does not quite fit with "...only one of these words should appear on the list". A more formal definition would help. Here is an attempt, please correct: Let $\Sigma_n = \{A,B\}^n$ be the words of length $n$ and let $\Sigma = \sqcup_{n>0} \Sigma_n$ be all (nonempty) words. Left rotation $\text{RotateLeft}: \Sigma \to \Sigma$ and mirror operation $\text{Reverse}: \Sigma \to \Sigma$ are clear. (...) $\endgroup$
    – user293787
    Jun 19, 2022 at 17:27
  • 2
    $\begingroup$ Have you found the number of such words of length 1, 2, and 3 by hand? Did you look this up the the OEIS? $\endgroup$
    – Somos
    Jun 19, 2022 at 18:59
  • 2
    $\begingroup$ Your code to produce Lyndon words up to length-5 does not produce length-1 ("A","B") and length-2 ("AB") words. Your length 4 includes "ABAB", which is not a Lyndon word since it is periodic (repeated string of length 2 or more). Also "AABA"and "AABB" are rotations of already listed words. There are only 3 length-4 Lyndon words (not 6). Same problems with length-5. Thre are 6 length-5 Lyndon words (not 14). What am I missing? $\endgroup$ Jun 20, 2022 at 13:42

2 Answers 2

2
$\begingroup$

Here is a bit of code, in case anyone wants to improve on this. Perhaps it also helps clarify what the exact statement of interest is. All code below is completely ad-hoc.

(Note that unlike the answer of @Jean-Pierre just submitted, I ignore the fact that the OP even mentions Lyndon words. The OP will have to clarify what exactly one is looking for here.)

$01$-words. I will use $0$ instead of $A$ and $1$ instead of $B$, and I will represent them as lists such as {0,0,1,0,1} and not as strings.

Bracelets. Classes of 01-words up to RotateLeft and Reverse are called bracelets according to A000029 (OEIS).

Here is code to pick a canonical representative, using Sort, and a random representative:

braceletNormalForms[{}]={};
braceletNormalForm[x_List]:=First[Sort[NestList[RotateLeft,x,Length[x]-1]//Join[#,Map[Reverse,#]]&]];
braceletRandomRepresentative[{}]={};
braceletRandomRepresentative[x_List]:=RandomChoice[{Identity,Reverse}][RotateLeft[x,RandomInteger[{0,Length[x]-1}]]];

Here is code to generate all bracelets with a given number n0 of zeros and n1 of ones, as well as for a given value of the length n0+n1:

bracelets[n0_,n1_]:=bracelets[n0,n1]=DeleteDuplicates[Map[braceletNormalForm,Map[ReplacePart[ConstantArray[0,n0+n1],Alternatives@@#->1]&,Subsets[Range[1,n0+n1],{n1}]]]];
bracelets[n_]:=Join@@Table[bracelets[n0,n-n0],{n0,0,n}];

For example

Table[Length[bracelets[n]],{n,0,15}]

yields

{1,2,3,4,6,8,13,18,30,46,78,126,224,380,687,1224}

and equals the first few entries of A000029 (OEIS).

Substitution. Given $01$-words W and X we define substitution as follows:

subs[x:0|1,W_List][X_List] := Flatten[Replace[X,x->W,{1}],1];

Denoting by n0W, n1W, n0X, n1X the number of zeros and ones in W and X respectively, then the number of zeros and ones in subs[0,W][X] is given by

n0==n0X*n0W
n1==n0X*n1W+n1X

The following code can be used to construct all {{n0W,n1W},{n0X,n1X}} given n0 and n1:

all4tuples[0][n0_/;n0>=1,n1_/;n1>=1]:=all4tuples[n0,n1]=Flatten[Table[
  With[{n0X=n0Xn0W[[1]],n0W=n0Xn0W[[2]]},
   Table[With[{n1X=n1-n0X*n1W},{{n0W,n1W},{n0X,n1X}}],
     {n1W,0,Floor[n1/n0X]}]],{n0Xn0W,factorizations[n0]}],1];
all4tuples[1][n0_/;n0>=1,n1_/;n1>=1]:=all4tuples[0][n1,n0][[;;,;;,{2,1}]];
factorizations[n_/;n>=1]:=factorizations[n]=Map[{#,n/#}&,Divisors[n]];

For example, all4tuples[0][2,3] is

{{{2,0},{1,3}},{{2,1},{1,2}},{{2,2},{1,1}},
 {{2,3},{1,0}},{{1,0},{2,3}},{{1,1},{2,1}}}

The following code is procedural. We start from the bracelet equivalence-classes:

nmax = 18;
Do[With[{n0=n0,n1=n1},
     currentClasses[n0,n1]=Map[{#}&,bracelets[n0,n1]]],{n0,0,nmax},{n1,0,nmax-n0}];

Think of currentClasses as mutable. We are going to try to merge classes in currentClasses into bigger classes, using substitution, assuming the formulation in the comments to the question.

Randomly select a known equivalence:

randomGetTwoEquivalentWords[n0_,n1_] := With[{randClass=RandomChoice[currentClasses[n0,n1]]},
   Array[braceletRandomRepresentative[RandomChoice[randClass]]&,2]];

Generate a new equivalence using substitution:

randomGenerateEquivalenceBySubstitution[n0_,n1_] := With[{x=RandomChoice[{0,1}]},
 With[{ns=RandomChoice[all4tuples[x][n0,n1]]},
   With[{Xs=randomGetTwoEquivalentWords@@ns[[2]],
     W=braceletRandomRepresentative[RandomChoice[bracelets@@ns[[1]]]]},
       {x,W,Xs,Map[braceletNormalForm,Map[subs[x,W],Xs]]}]]];

The following function is called to update currentClasses if the two words W1 and W2 are a new equivalence. It returns False if the two words were already known to be equivalent, True if it is a new equivalence.

installEquivalence[{W1_List,W2_List}] /; (Sort[W1]===Sort[W2]) := With[{n0=Count[W1,0],n1=Count[W1,1]},
  If[braceletNormalForm[W1]===braceletNormalForm[W2],False,
    With[{is=Map[First[First[Position[currentClasses[n0,n1],#,{2}]]]&,{W1,W2}]},
      With[{i1=is[[1]],i2=is[[2]]},If[i1===i2,False,
         currentClasses[n0,n1]=ReplacePart[Drop[currentClasses[n0,n1],{Max[i1,i2]}],
                 Min[i1,i2]->Join[currentClasses[n0,n1][[i1]],currentClasses[n0,n1][[i2]]]];
         True
   ]]]]];

Code to run this:

run[n0_,n1_,reps_] := Do[With[{r=randomGenerateEquivalenceBySubstitution[n0,n1]},
  If[installEquivalence[r[[4]]],
      Print["Substituting "<>ToString[r[[1]]]<>" -> "<>tostring[r[[2]]]<>" in "<>tostring[r[[3,1]]]<>" ~ "<>tostring[r[[3,2]]]<>" gives the new "<>tostring[r[[4,1]]]<>" ~ "<>tostring[r[[4,2]]]<>"."]];
],{reps}];
tostring[W_List] := StringJoin@@Map[ToString,W];

In particular, SeedRandom[1]; run[6,9,100000] gives

Substituting 1 -> 1101 in 101100 ~ 001101 gives the new 001011101101011 ~ 001011010111011.

From such random runs, which of course are not conclusive and whose reliability would have to be analyzed, the values n0 = 6 and n1 = 9 seem to give the smallest n0+n1 for which a new equivalence is generated. And it seems that for n0+n1 == 15 exactly two new equivalence are generated, the one shown above and the analogous one for n0 = 9 and n1 = 6 by symmetry.

So this finds new equivalences due to substitution of length 15. Perhaps length 15 is the smallest length where equivalence via substitution starts differing from bracelets? The OP mentions 22 but I do not know what role that number is supposed to play. Would be nice to know the context of the question, and perhaps someone has relevant links if this is a known combinatorial problem.

$\endgroup$
1
$\begingroup$

In order to start somewhere, here is my code to generate Lyndon words. First, the following function returns the number of words for a particular n (from oeis.org):

f[n_] := Block[{d = Divisors@n}, Plus @@ (MoebiusMu[n/d]*2^d/n)]

The code below uses this function to determine how many times to go through the loop:

n = 6;
wordList = {"A"};
Do[
  w = Last[wordList];
  newWord = StringRepeat[w, n, n];
  newWord = 
   NestWhile[StringDrop[#, -1] &, 
    newWord, (StringLength[#] > 0 && Last[Characters[#]] == "B" &)];
  If[StringLength[newWord] > 0, 
   newWord = StringDrop[newWord, -1] ~~ "B"];
  AppendTo[wordList, newWord];
  , Total[Table[f[i], {i, 1, n}]]];
Column@Sort[GatherBy[wordList, StringLength]]

enter image description here

$\endgroup$
2
  • $\begingroup$ Here's a shorter way to define your f[]: f[n_Integer] := DirichletConvolve[2^d, MoebiusMu[d], d, n]/n. $\endgroup$ Jun 20, 2022 at 16:59
  • $\begingroup$ Thank you! I used your code to add further reduce the list by applying 2. to your list. it's messy but it works! $\endgroup$
    – 2132123
    Jun 21, 2022 at 18:25

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.