OFFSET
1
COMMENTS
Let s = (s(n)) be a strictly increasing sequence of positive integers with infinite complement, t = (t(n)). For n >=1, let s'(n) be the number of s(i) that are <= n-1 and let t'(n) be the number of t(i) that are <= n-1. Define w(1) = 0, w(t(1)) = 1, and w(n) = 0w(s'(n)) if n is in s, and w(n) = 1w(t'(n)) if n is in t. Then (w(n)) is the "s-induced ordering" of all 01-words.
For a guide to related sequences, see the Mathematica program and A341256.
EXAMPLE
The first 20 words: 0,1,00,01,10,000,11,001,010,100,0000,011,101,0001,110,0010,0100,1000,00000,111.
MATHEMATICA
z = 250; r = GoldenRatio;
"The sequence s; " (* A000201 *)
s = Table[Floor[n r], {n, 1, z}]
"The sequence t:" (* A001950 *)
t = Complement[Range[Max[s]], s]
s1[n_] := Length[Intersection[Range[n - 1], s]];
t1[n_] := n - 1 - s1[n];
"The sequence s1: A005206"
Table[s1[n], {n, 1, z}]
"The sequence t1: A060144"
Table[t1[n], {n, 1, z}]
w[1] = {0}; w[t[[1]]] = {1};
w[n_] := If[MemberQ[s, n], Join[{0}, w[s1[n]]], Join[{1}, w[t1[n]]]]
"List tt of all binary words:"
tt = Table[w[n], {n, 1, z}] (* all the binary words *)
"All the words, concatenated:"
Flatten[tt] (* A341258 words, concatenated *)
"Map of Union onto the words:"
Map[Union, tt]
"Length of w[n]: A112310"
Map[Length, tt]
"Positions of words in which #0's = #1's: A344950"
"This and the next two sequences partition N."
Select[Range[Length[tt]],
Count[tt[[#]], 0] == Count[tt[[#]], 1] &]
"Positions of words in which #0's < #1's: A344951"
Select[Range[Length[tt]], Count[tt[[#]], 0] < Count[tt[[#]], 1] &]
"Positions of words in which #0's > #1's: A344952"
Select[Range[Length[tt]], Count[tt[[#]], 0] > Count[tt[[#]], 1] &]
"Positions of words ending with 0: A133512 send comment"
Select[Range[Length[tt]], Last[tt[[#]]] == 0 &]
"Positions of words ending with 1: A344953"
Select[Range[Length[tt]], Last[tt[[#]]] == 1 &]
"Positions of words starting and ending with same digit: A344954"
Select[Range[Length[tt]], First[tt[[#]]] == Last[tt[[#]]] &]
"Positions of words starting and ending with opposite digits: A344955"
Select[Range[Length[tt]], First[tt[[#]]] != Last[tt[[#]]] &]
"Positions of words starting with 0 and ending with 0: A344956"
Select[Range[Length[tt]],
First[tt[[#]]] == 0 && Last[tt[[#]]] == 0 &]
"Positions of words starting with 0 and ending with 1: A344957"
Select[Range[Length[tt]],
First[tt[[#]]] == 0 && Last[tt[[#]]] == 1 &]
"Positions of words starting with 1 and ending with 0: A344958"
Select[Range[Length[tt]],
First[tt[[#]]] == 1 && Last[tt[[#]]] == 0 &]
"Positions of words starting with 1 and ending with 1: A344959"
Select[Range[Length[tt]],
First[tt[[#]]] == 1 && Last[tt[[#]]] == 1 &]
"Position of n-th positive integer (base 2) in tt: A344988"
d[n_] := If[First[w[n]] == 1, FromDigits[w[n], 2]];
Flatten[Table[Position[Table[d[n], {n, 1, 200}], n], {n, 1, 200}]]
"Position of binary complement of w(n): A344960"
comp = Flatten[Table[Position[tt, 1 - w[n]], {n, 1, 100}]]
"Sum of digits of w(n): A206650"
Table[Total[w[n]], {n, 1, 100}]
"Number of runs in w(n): A344961"
Map[Length, Table[Map[Length, Split[w[n]]], {n, 1, 100}]]
"Palindromes:"
Select[tt, # == Reverse[#] &]
"Positions of palindromes: A341333"
Select[Range[Length[tt]], tt[[#]] == Reverse[tt[[#]]] &]
"Positions of words in which #0's - #1's is odd: A095879"
Select[Range[Length[tt]],
OddQ[Count[w[#], 0] - Count[w[#], 1]] &]
"Positions of words in which #0's - #1's is even: A095880"
Select[Range[Length[tt]], EvenQ[Count[w[#], 0] - Count[w[#], 1]] &]
"Position of the reversal of the n-th word: A344962"
u21 = Flatten[Table[Position[tt, Reverse[w[n]]], {n, 1, 150}]]
CROSSREFS
KEYWORD
nonn
AUTHOR
Clark Kimberling, Mar 16 2021
STATUS
approved