Self-generating Oldenburger-Kolakoski sequence

Staff Picks
, , , ,
1

The Kolakoski Sequence was recently in the news. It starts out as

1 2 2 1 1 2 1 2 2 1 2 2 1 1 2 1 1 2 2 1 2 1 1 2 1 2 2 1 1 2 1 1 2 1 2 2 1 2 2 1 1 2 1 2 2 1 2 1 1 2 1 1 2 2 1 2 2 1 1 2 1 2 2 1 2 2 1 1 2 1 1 2 1 2 2 1 2 1 1 2 2 1 2 2 1 1 2 1 2 2 1 2 2 1 1 2 1 1 2 2 1 2 1 1 2 1 2 2 1 2 2 1 1 2 1 1 2 1 2 . . .

n = 10;  ko = Prepend[Nest[Flatten[Partition[#, 2] /. 
{{2, 2} -> {2, 2, 1, 1}, {2, 1} -> {2, 2, 1}, {1, 2} -> {2, 1, 1}, {1, 1} -> {2, 1}}] &, {2, 2}, n], 1];

Try doing

Length/@Split[ko]

on that, and you get the same sequence. It is self-descriptive. I bumped the code up to n=32 to get 1058436 terms. What is the behavior of 1 and 2 over that range?

 ListPlot[FoldList[Plus, 0, 2 (ko - 3/2)], Joined -> True, AspectRatio -> 1/7]

kolakowski.jpg
kolakowski.jpg1390×205 74.5 KB

Seems pretty chaotic.

7 Likes
2

Thanks for sharing! So what about the 1-to-2 ratio? The long running average looks like:

lra = Accumulate[N[ko]]/Range[Length[ko]];
ListPlot[lra[[;; ;; 10000]], DataRange -> {0, Length[ko]},Joined -> True]

ScreenShot2017-07-28at11.56.08.png
ScreenShot2017-07-28at11.56.08.png750×456 31.3 KB

This result is for n=40. Pretty close to 1.5 indeed…

6 Likes
3

Thanks for sharing this sequence. I wonder if this isn’t obvious somehow, but the blocks of size larger than 1 are not equally distributed. For size 2, it is about twice as likely to not have a repeat,

n = 15; ko = 
 Prepend[Nest[
   Flatten[Partition[#, 
       2] /. {{2, 2} -> {2, 2, 1, 1}, {2, 1} -> {2, 2, 1}, {1, 
         2} -> {2, 1, 1}, {1, 1} -> {2, 1}}] &, {2, 2}, n], 1];

Tally[Subsequences[ko, {2}]] 
    (*{{{1, 2}, 359}, {{2, 2}, 178}, {{2, 1}, 359}, {{1, 1}, 182}}*)

and for size three, the counts are almost the same but some cases are completely missing.

Complement[Tuples[{1, 2}, 3], Subsequences[ko, {3}]]
(*{{1, 1, 1}, {2, 2, 2}}*)

The other thing I am thinking about is what is a good way to code the other definition, starting from self-describing via Split, maybe something involving Table like

Nest[Flatten[Mod[MapIndexed[Table[#2[[1]], #] &, #], 2, 1]] &, {2, 2}, 10]

which seems to have some problem I can’t identify.

5 Likes
4

Thanks for pointing out this excinting sequence! I could not resist playing around!

Using Mathematica I am always amazed how much one can do with how little code:
Using the code above

kolakoskiSeq[iter_Integer] := Prepend[Nest[Flatten[Partition[#, 2] /. {{2, 2} -> {2, 2, 1, 1}, {2, 1} -> {2, 2, 1}, {1, 2} -> {2, 1, 1}, {1, 1} -> {2, 1}}] &, {2, 2}, iter], 1]

then with

kHead[l_] := Length[#] @@ # & /@ SplitBy[l, Head]
koH = Length[#] @@ # & /@ Split[kolakoskiSeq[9]];
koTree = Nest[kHead, koH, 14];
Manipulate[TreeForm["Kolakoski" @@ Level[koTree, {level}], ImageSize -> 900, PlotStyle -> Blue], {level, 16, 3, -1}]

one gets:

KolakoskiTree1.gif

@Todd Rowland: I like very much your approach of coding it differently! This seems to work:

kolakoskiStep[seq_List] := Flatten@MapIndexed[ConstantArray[Mod[First[#2] + First[seq], 2] + 1, #1] &, seq]
kSeq = Nest[kolakoskiStep, {1, 2}, 9]

With this it becomes obvious that there are only two possible sequences of this type, one starting with the “seed” {1,2}, the other one with {2}.

4 Likes
5

news-congrads-kkluyshnik-02-04-19.jpg – you have earned Featured Contributor Badge 2015-11-02_10-07-11.png

Your exceptional post has been selected for our editorial column Staff Picks http://wolfr.am/StaffPicks and Your Profile is now distinguished by a Featured Contributor Badge and is displayed on the Featured Contributor Board. Thank you!

6

A simple introduction to the sequence in Numberphile YouTube video:

Open in Wolfram Cloud ↗
3 Likes