A351386 Sequence of balanced, multiplicative binary words, starting with a(1)=1, a(2)=10; for j > 2, if j is a prime, then a(j) is obtained by appending 0 at the end of a(j-1); otherwise, a(j) is obtained by appending a single digit at the end of a(j-1) such that the new word is multiplicative, but if the obtained a(j) is not balanced, then we change the digit at the rightmost possible prime position (and, eventually, some digits at following nonprime positions to maintain multiplicativity) so that a(j) becomes balanced.
1, 10, 100, 1001, 10010, 100101, 1001010, 10010110, 100101101, 1001010011, 10010100110, 100101001110, 1001010011100, 10010100111001, 100101001110011, 1001010011000111, 10010100110001110, 100101001100011110, 1001010011000111100, 10010100110001111010, 100101001100011110101
Offset: 1
Keywords
Examples
a(15) = 100101001110011. To obtain the 16th term we arbitrarily choose a nontrivial decomposition of 16, for example, 2*8. The second (2) digit in a(15) is 0 and the eighth (8) digit is 0, so as the last digit of a(16) we append 1. We obtain a(16) = 1001010011100111, which is not balanced. Changing the 13th digit in a(16) (0 to 1) only decreases balance, so we check the next possible prime: changing the 11th digit (1 to 0) results in a balanced a(16) = 1001010011000111. It is sufficient to test just one factorization - multiplicativity of the word guarantees that every factorization gives us the same result.
Links
- Jaroslaw Grytczuk, From the 1-2-3 conjecture to the Riemann hypothesis, European Journal of Combinatorics 91/1 (2021), 1-10.
- Jaroslaw Grytczuk, Hubert Kordulewski, and Artur Niewiadomski, Extremal Square-Free Words, Electronic J. Combinatorics, 27 (1), 2020, #1.48.
Programs
-
Mathematica
a = "1"; list = {a}; For[j = 2, j <= 100, j++, If[PrimeQ[j] == True, a = a <> "0", i = 2; While[IntegerQ[j/i] == False, i++]; a1 = ToExpression[StringTake[a, {i}]]; a2 = ToExpression[StringTake[a, {j/i}]]; If[a1 == a2, b = a <> "1", b = a <> "0"]; If[Abs[StringCount[b, "0"] - StringCount[b, "1"]] < 2, a = b, For[k = j - 1, k >= 2, k = k - 1, If[PrimeQ[k] == True, c = StringTake[b, k - 1] <> ToString[1 - ToExpression[StringTake[b, {k}]]] <> StringTake[b, -(j - k)]; For[l = k + 1, l <= j, l++, If[PrimeQ[l] == False, li = 2; While[IntegerQ[l/li] == False, li++]; la1 = ToExpression[StringTake[c, {li}]]; la2 = ToExpression[StringTake[c, {l/li}]]; If[la1 == la2, c = StringTake[c, l - 1] <> "1" <> StringTake[c, -(j - l)], c = StringTake[c, l - 1] <> "0" <> StringTake[c, -(j - l)]] ]]; If[Abs[StringCount[c, "0"] - StringCount[c, "1"]] < 2, a = c; Break[]] ] ]; If[b == c, Print["STOP"]; Break[]] ] ]; list = Append[list, a]] ; Print[list]
Comments