Reproducing the xkcd "Self-Description" comic

Question

Trying to brush up on my programming, I wanted to see if I can reproduce at least the first two panels of the following comic in Mathematica:

The contents of any one panel are dependent on the contents of every panel including itself. The graph of panel dependencies is complete and bidirectional, and each node has a loop. The mouseover text has two hundred and forty-two characters.

I have some code for trying to reproduce the first panel, but I think it could be improved a lot:

pie[bw_] :=
PieChart[bw, BaseStyle -> GrayLevel[0, 1], 
             ChartBaseStyle -> EdgeForm[Directive[Thick, GrayLevel[0, 1]]], 
             ChartLabels -> Placed[{"fraction of\nblack", "fraction of\nwhite"}, 
             "RadialCallout"], ChartStyle -> {Black, White}, SectorOrigin -> -5 Pi/6]

FixedPoint[N[Normalize[ImageLevels[Binarize[Rasterize[pie[#], "Image",
                       ImageSize -> Large]]][[All, 2]], Total]] &, {0.1, 1}] // pie

My problem has been in trying to add the second panel, and making sure the FixedPoint accounts for the amount of black and white in both panels. I tried using Row and Framed with Histogram, but I could not make it look decent. Can you all help me remake this comic?

I will be happy with just the first two panels, but I will of course be very impressed if you can somehow manage the third!

Hihi, I have seen it, but I am more interested in the self-referential nature on the image, so I used FixedPoint. I guess that is for postprocessing however. — Mayumi Itō, Jul 21 '16 at 07:04
Yes, I was referring to "but I think it could be improved a lot:", which I got wrong ;) — Kuba, Jul 21 '16 at 07:15
There is an excellent article on this very question on the Wolfram Blog. Follow this link — m_goldberg, Jul 21 '16 at 13:28
@shrx. my comment will take the OP to a page were he/she will find an answer, but it is not an answer in itself. Link only answers are not the kind of answers we want on this site. — m_goldberg, Jul 22 '16 at 14:57

score 11 · Answer 1 · edited Apr 13 '17 at 12:55

Here is a slightly improved/updated version of the solution developed by Peter Frentrup and published at Jan 15, 2010 on the xkcd forum. The changes I have made are to put "Image" as the second argument for Rasterize, explicitly convert the result to grayscale and use ImageData for extracting channel values (all these features were not present in Mathematica 6 with which the original code was developed).

The implementation:

d = 0.1;
pw = GoldenRatio - d/2;
font = "Comic Sans MS";

b2g[g_, b1_, b2_, b3_] := Graphics[{Thick,
   (* panel frames *)
   Table[With[{x = i*(pw + d)}, 
     Line[{{x, 0}, {x + pw, 0}, {x + pw, 1}, {x, 1}, {x, 0}}]], {i, 0, 2}],
   {(* left panel *)
    With[{cx = pw - 0.5, cy = 0.5},
     {Circle[{cx, cy}, 0.4],
      Disk[{cx, cy}, 0.4, 7/6 \[Pi] + {-\[Pi], \[Pi]} ((b1 + b2 + b3)/3)],
      With[{c = Cos[7/6 \[Pi]], s = Sin[7/6 \[Pi]]},
       {Line[{{cx, cy}, {cx + 0.55 c, cy + 0.55 s}, {d, cy + 0.55 s}}],
        White,
        Line[{{cx + 0.4 c, cy + 0.4 s}, {cx + 0.3 c, cy + 0.3 s}}]}],
      With[{c = Cos[3/4 \[Pi]], s = Sin[3/4 \[Pi]]},
       Line[{{cx + 0.3 c, cy + 0.3 s}, {cx + 0.5 c, cy + 0.5 s}, {d, 
          cy + 0.5 s}}]],
      Text[Style["FRACTION OF\nTHIS IMAGE  \nWHICH IS BLACK",
        Background -> White,
        FontWeight -> Bold,
        FontFamily -> font,
        TextAlignment -> Left,
        FontSize -> Scaled[0.05/(3*pw + 2*d)]], {d/2, d/2}, {-1, -1}],
      Text[Style["FRACTION OF\nTHIS IMAGE  \nWHICH IS WHITE",
        Background -> White,
        FontWeight -> Bold,
        FontFamily -> font,
        TextAlignment -> Left,
        FontSize -> Scaled[0.05/(3*pw + 2*d)]],
       {d/2, 1 - d/2}, {-1, 1}]}]
    },
   {(* middle panel*)
    With[{lef = pw + 3 d, rig = 2 pw, bot = 1.5 d, top = 1 - 3 d},
     {Line[{{lef, top}, {lef, bot}, {rig, bot}}],
      Table[With[{w = 0.3 (rig - lef)},
        With[{x = lef + i * w - w/3},
         {Rectangle[{x, bot}, {x + w/3, 
            bot + (top - bot)*{b1, b2, b3}[[i]]/(Max[b1, b2, b3]*1.2)}],
          Text[Style[i,
            FontWeight -> Bold,
            FontFamily -> font,
            TextAlignment -> Left,
            FontSize -> Scaled[0.06/(3*pw + 2*d)]],
           {x + w/6, bot - d/4}, {0, 1}]}]],
       {i, 3}],
      Text[Style["AMOUNT OF\nBLACK INK\nBY PANEL:",
        FontWeight -> Bold,
        FontFamily -> font,
        TextAlignment -> Left,
        FontSize -> Scaled[0.05/(3*pw + 2*d)]],
       {pw + 1.5 d, 1 - 0.5 d}, {-1, 1}]
      }]
    },
   {(* right panel *)
    With[{lef = 2 pw + 4 d, rig = 3 pw + d, w = 3 pw + 2 d},
     With[{y0 = 0.4 - (rig - lef)/(2 w), h = (rig - lef)/w, dd = d/3},
      {Arrowheads[0.01],
       Arrow[{{lef - dd, y0 - dd}, {lef - dd, y0 + h + 2 dd}}],
       Arrow[{{lef - dd, y0 - dd}, {rig + 2 dd, y0 - dd}}],
       Line[{{lef - 1.3 dd, y0}, {lef - 0.7 dd, y0}}],
       Line[{{lef, y0 - 1.3 dd}, {lef, y0 - 0.7 dd}}],
       Text[Style["0",
         FontWeight -> Bold,
         FontFamily -> font,
         TextAlignment -> Left,
         FontSize -> Scaled[0.05/(3*pw + 2*d)]],
        {lef - 2 dd, y0}, {1, 0}],
       Text[Style["0",
         FontWeight -> Bold,
         FontFamily -> font,
         TextAlignment -> Left,
         FontSize -> Scaled[0.05/(3*pw + 2*d)]],
        {lef, y0 - 2 dd}, {0, 1}],
       Inset[g, {lef, y0}, {0, 0}, Scaled[{1, 1}*h]],
       Text[Style["LOCATION OF\nBLACK INK IN\nTHIS IMAGE",
         Background -> White,
         FontWeight -> Bold,
         FontFamily -> font,
         TextAlignment -> Left,
         FontSize -> Scaled[0.05/(3*pw + 2*d)]],
        {2 pw + 3 d, 1 - d/2}, {-1, 1}]}]
     ]
    }}]

step[{g_, b1_, b2_, b3_}] := Module[{g2, pix},
  g2 = ColorConvert[Rasterize[b2g[g, b1, b2, b3], "Image", ImageSize -> 1000],
     "Grayscale"];
  pix = ImageData[g2];
  {g2,
   1 - Mean[
     Flatten[pix[[All, ;; \[LeftCeiling]Length[pix[[1]]]/3\[RightCeiling]]]]],
   1 - Mean[
     Flatten[pix[[
       All, \[LeftFloor]Length[pix[[1]]]/3\[RightFloor] ;; \[LeftCeiling](
         2 Length[pix[[1]]])/3\[RightCeiling]]]]],
   1 - Mean[
     Flatten[pix[[All, \[LeftFloor](2 Length[pix[[1]]])/3\[RightFloor] ;;]]]]}
  ]

Creating the image:

First@FixedPoint[step, {Graphics[{}], 0.5, 0.5, 0.5}, 
  SameTest -> (Norm[Rest[#1 - #2]] < 1*^-3 &)]

shrx · Answer 2 · 2016-07-21T08:39:32.777

A quick example how to generate the first two frames. Just the basic layout, no fancy annotations, but you should get the idea.

First, define the functions that draw the frames:

frame1[{int1_, int2_}] := 
 PieChart[{(int1 + int2)/2, 1 - (int1 + int2)/2}, 
  ChartStyle -> {Black, White}, PerformanceGoal -> "Speed", 
  ChartBaseStyle -> EdgeForm[Directive[Opacity[1], Thick]], 
  ImageSize -> 150, Frame -> True, FrameTicks -> None, 
  FrameStyle -> Thick]
frame2[{int1_, int2_}] := 
 Framed[BarChart[{int1, int2}, ChartStyle -> Black, 
   PerformanceGoal -> "Speed", BarSpacing -> 0.8, Ticks -> None, 
   AxesStyle -> Directive[Black, Thick], ImageMargins -> 10, 
   AspectRatio -> 1
   ], FrameStyle -> Thick, ImageSize -> {150, 148}]

Then, iterate over the objective function, which in this case computes the intensity (gray level) of the frames:

FixedPoint[(1 - 
      ImageMeasurements[Rasterize@#, "MeanIntensity"] & /@ {
     frame1[#], frame2[#]
     }) &, {0.5, 0.5}]
Row[{frame1[%], frame2[%]}]

{0.239555, 0.404095}

Reproducing the xkcd "Self-Description" comic

2 Answers2