[Math] Tupper’s self-referential formula with Mathematica

mathematica

When trying to reproduce the plot of Tupper's self-referential formula (original paper is available here) with Mathematica I have faced unexpected difficulties.

First of all, the algorithm does not give the image shown and I was forced to find the right way by myself (code for Mathematica):

k = 960939379918958884971672962127852754715004339660129306651505519271\
7028023952664246896428421743507181212671537827706233559932372808741443\
0789132596394133772348785773574982392662971551717371699516523289053822\
1612403238855866184013235585136048828693337902491454229288667081096184\
4960917051834540678277315517054053816273809676025656250169814820834187\
8316384911559022561000365235137034387446184837873723819822484986346503\
3159410054974700593138339226497249461751545728366702369745461014655997\
933798537483143786841806593422227898388722980000748404719;
tb = Table[
   1/2 < Floor[
     Mod[Floor[y/17]*2^(-17 Floor[x] - Mod[Floor[y], 17]), 2]], {y, 
    k + 17, k, -1}, {x, 106, 0, -1}];
g = Graphics[Raster[tb /. {True -> 0, False -> 1}], 
  ImagePadding -> None, PlotRangePadding -> None]

But even after this I get artefacts on the bottom of the image produced. Why this happens? Is this an error in the original description or in my mind? The correct image can be produced by the following code (where sh may be any rational number of the form 1/n):

k = 960939379918958884971672962127852754715004339660129306651505519271\
7028023952664246896428421743507181212671537827706233559932372808741443\
0789132596394133772348785773574982392662971551717371699516523289053822\
1612403238855866184013235585136048828693337902491454229288667081096184\
4960917051834540678277315517054053816273809676025656250169814820834187\
8316384911559022561000365235137034387446184837873723819822484986346503\
3159410054974700593138339226497249461751545728366702369745461014655997\
933798537483143786841806593422227898388722980000748404719;
sh = 1;
tb = Table[
   1/2 < Floor[
     Mod[Floor[y/17]*2^(-17 Floor[x] - Mod[Floor[y], 17]), 2]], {y, 
    k + 17 - sh, k, -sh}, {x, 106 - sh, 0, -sh}];
g = Graphics[Raster[tb /. {True -> 0, False -> 1}], 
  ImagePadding -> None, PlotRangePadding -> None]

And I also cannot decode the k directly into an image in the right way. Here is my code:

g=Graphics[Raster[Transpose@
(Partition[IntegerDigits[k/17,2]/.{1->0,0->1},17])],
ImagePadding->None,PlotRangePadding->None]

What am I doing wrong?

EDIT:

I have found a way to decode the constant k. The problem was that the original binary representation of the encoded image was truncated when converting to the number due to dropping leading zeros. We should also take into account that Tupper encoded black pixels as "1" and white pixels as "0". So we need to pad the binary representation of k with "1" at the start. Here is the solution (for Mathematica 7+):

Image[Transpose[
  Reverse@Partition[Reverse[1 - IntegerDigits[k/17, 2]], 17, 17, 1, 
    1]], Magnification -> 4]

Here is also more elegant code for plotting Tupper's function:

Image[Table[
  1 - Boole[
    1/2 < Floor[
      Mod[Floor[y/17] 2^(-17 Floor[x] - Mod[Floor[y], 17]), 2]]], {y, 
   k, k + 16}, {x, 105, 0, -1}], Magnification -> 4]

Best Answer

At the risk of sounding gauche, I presume you've tried out the Mathematica notebook here and found it wanting?

Related Question