6
$\begingroup$

For those who are not familiar with Tupper's self-referential formula, here is the wiki link.

My interest was to plot it. I tried the naive approach using RegionPlot, which did not work very well. There was some overflow warning. So I then tried the lazy way and Googled it. I found this.

The version from the .nb files was relatively old. I picked up the "shortest" version:

k=960939379918958884971672962127852754715004339660129306651505519271702802395266424689642842174350718121267153782770623355993237280874144307891325963941337723487857735749823926629715517173716995165232890538221612403238855866184013235585136048828693337902491454229288667081096184496091705183454067827731551705405381627380967602565625016981482083418783163849115590225610003652351370343874461848378737238198224849863465033159410054974700593138339226497249461751545728366702369745461014655997933798537483143786841806593422227898388722980000748404719;

Length[IntegerDigits[k]]

Now, the exciting line:

ArrayPlot[Table[Boole[
        Floor[
        Mod[
        Floor[y/17]*2^(-17*Floor[x]-Mod[Floor[y],17])
        ,2]
        ]>1/2
    ]
    , {y, k, k + 16}
    , {x, 106, 0, -1}
    ]
    ,PixelConstrained -> True
    ,Frame -> False
    ,ImageSize -> 800
]

This was the plot: enter image description here

The two lines

    ,{y, k, k + 16}
    ,{x, 106, 0, -1}

did confuses me at first (the order they occur), but then I compared with the graph on wiki, I am happy about it. We are just plotting x in reverse order.

Question:

If you read here, the author talks about the wrong N (k in here). We have "changed" the code to "make" it work according to the author. The only difference is that we have swapped the axes?

I would really be interested to understand how ArrayPlot plots the x and y.

Something really strange now, if I do

ArrayPlot[Table[Boole[
        Floor[
        Mod[
        Floor[y/17]*2^(-17*Floor[x]-Mod[Floor[y],17])
        ,2]
        ]>1/2
    ]
    ,{y, k, k + 16}
    ,{x, 106, 0, -1}
    ]
    ,PixelConstrained -> True
    ,Frame -> False
    ,ImageSize -> 800
    ,Axes -> True
]

Only last line, Axes -> True, is new. The graph becomes:

enter image description here

As a comparison, I have taken a screenshot:

enter image description here

The second graph is missing some of the right hand side as well as some the top. What happened?

How do I plot this graph easily WITH axes label? And if possible, on the y axes, using labels like k and k+16 (17)?

Improve this question
$\endgroup$
5
  • $\begingroup$ Get rid of the PixelConstrained option. It seems to fix the rest of the plot, and I cannot see a difference with or without anyway. $\endgroup$
    – MarcoB
    Jul 10, 2015 at 21:47
  • $\begingroup$ @MarcoB Just to be clear, when you say you cannot see the difference, do you mean between the graphs or something else? For the two screen shots, they are EXACTLY as they are presented on the screen. That is, the second graph has some parts MISSING on the right hand side. $\endgroup$
    – Chen Stats Yu
    Jul 10, 2015 at 22:10
  • $\begingroup$ @MarcoB See the third picture. $\endgroup$
    – Chen Stats Yu
    Jul 10, 2015 at 22:13
  • $\begingroup$ @MarcoB Just to confirm what you commented, if I take out the PixelConstrained, then yes, they are the same. $\endgroup$
    – Chen Stats Yu
    Jul 10, 2015 at 22:25
  • 1
    $\begingroup$ Have you tried using a relative ImageSize specification, such as ImageSize -> Scaled[0.75], to make sure that the image is not simply too large for your window? $\endgroup$
    – MarcoB
    Jul 10, 2015 at 22:30

1 Answer 1

Reset to default
8
$\begingroup$

Perhaps Frame and FrameTicks will allow you to achieve your aim.

f[x_, y_] := 
 Boole[1/2 < 
   Floor[Mod[Floor[y/17] 2^(-17 Floor[x] - Mod[Floor[y], 17]), 2]]]
ctm[nu_] := 
 ArrayPlot[Table[f[j, k], {k, nu, nu + 16}, {j, 106, 0, -1}], 
  Frame -> True, FrameTicks -> All, Mesh -> True]

In the following the Tupper number has been plotted:

enter image description here

You can specify your desired tick marks.

Note the "higher resolution" self referential formula (with number here):

g[x_, y_] := 
 Boole[Mod[Floor[Floor[y/61] 2^(-61 x - Mod[y, 61])], 2] == 1]
w[nu_] := 
 ArrayPlot[Table[g[j, k], {k, nu + 60, nu, -1}, {j, 0, 375}], 
  Frame -> True, FrameTicks -> All]

Applying to number:

enter image description here

Note: for ArrayPlot the input array is plotted (as suggested by FrameTicks are as per matrix entries: row 1 is top row, left column is first column etc), vs the post in hyperlink of OP and the better resolution in which {x,y} are as per plot and hence the "double flip" (see iterators of table and reverse vertical frame ticks).

I have not "corrected" the FrameTicks to illustrate matters.

For play you can rasterize text and get the number. This question helped me correct an error with my own musings.

Improve this answer
$\endgroup$

Your Answer

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

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