Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

Sign up
Here's how it works:
  1. Anybody can ask a question
  2. Anybody can answer
  3. The best answers are voted up and rise to the top

enter image description here

Here is a start.

MapIndexed[Text[Reverse[First[RealDigits[Pi,10,252]]][[Tr@#2]],#]&,
 Table[{t Cos[t],t Sin[t]},{t,0,16Pi,0.2}]]//Graphics
share|improve this question
1  
There is a link on mypiday site that leads to lab with an example that produces similar result. – swish Mar 14 at 11:49
1  
closely related: How can I wrap text around a circle? – Kuba Mar 14 at 11:50
    
Preliminary (but no time to finish it now): dropbox.com/s/w8ulcltrrhztob6/… – Szabolcs Mar 14 at 14:38
    
    
@Szabolcs It looks like you might be able to answer my related question. :) – Martin Ender Mar 14 at 14:56
up vote 63 down vote accepted

My original code was crashing when you used too many digits because apparently Mathematica can handle only so many different font sizes. To fix it, I had to borrow george2079's PDF trick to turn each character into a vectorised graphics primitive. I couldn't have solved this issue myself, so give his answer an upvote please. The rest of the code is still my original approach.

numbers = 
  Translate[#, {-4.5, -10}] & /@ 
     First[First[
       ImportString[ExportString[
         Style[#, FontSize -> 24, FontFamily -> "Arial"], 
       "PDF"], "PDF", "TextMode" -> "Outlines"]
     ]] & /@ {"."}~Join~CharacterRange["0", "9"];

With[{fontsize = 0.0655, digits = 10000},
  Graphics[
    MapIndexed[
      With[{angle = (-(#2[[1]] - 2) + 
              Switch[#2[[1]], 1, -0.1, 2, 0, _, 0.6]) fontsize},
        With[{scale = (1 - 1.5 fontsize)^(-angle/(2 Pi))},
          GeometricTransformation[
            numbers[[# + 2]],
            RightComposition[
              ScalingTransform[{1, 1} 0.1 fontsize*scale],
              TranslationTransform[{0, scale}],
              RotationTransform[Pi/4 + angle]
            ]
          ]
        ]
      ] &,
      Insert[First@RealDigits[Pi, 10, digits], -1, 2]
    ], 
    PlotRange -> {{-1.1, 1.1}, {-1.1, 1.1}}
  ]
]

enter image description here

Note that the output is a vector image, so you can drag it as big as you like to increase the resolution and be able to see more digits in the centre. The above screenshot is actually a lot bigger. Click to view it at full resolution.

There are some magic numbers in the code, but in principle you should be able to tweak the size of the sπral simply by changing the fontsize parameter at the top and the length by changing digits. All the other length scales seem to work reasonably well. I've chosen 0.0665 as the font size (as well as all the other parameters) because it seems to match up almost exactly with your own example (including the font).

There's some fiddling with the Switch to set the angles around . manually, because otherwise they'd look to big. I'm not a typographer, so if you still cringe at the kerning, I apologise.

As for how it actually works:

  • The angle of each digit depends linearly on its index (i.e. there's a fixed angle decrement between consecutive digits). Since the size of the numbers scale linearly with radius, we also want their spacing around the circle to scale linearly with radius, and that just means we want to use constant offsets in angle. This offset depends on the fontsize parameter.
  • To get a clean scaling of the radius to ensure that the gaps between subsequent turns are consistent (and that the spiral is self-similar), we determine the scaling based on the angle, such that each full turn scales the radius as well as the font size by a constant factor. Since the angle between consecutive digits is constant, we could also make this scaling factor linearly dependent on the index, but using the angle makes it a bit nicer, because we can directly set the relative scale from one turn to the next (which clearly must be at least one font size smaller to avoid overlap).
  • To get each digit into its position, we first move it a first scale it according to both the initial font size and the current scale factor. Then we move it along the positive y-axis according to the same scale factor, such that the ratio of font size to radius is constant. Finally, we rotate it about the origin by the linearly increasing angle. I've offset the angle by $\pi/4$ so that the the number starts in the top left as in your example.
share|improve this answer
10  
That's awesome! "sπral" – Jeel Shah Mar 14 at 14:19
1  
I think I've managed to track down the source of the error, but I haven't found a workaround yet. I've asked a separate question with a minimal example, in case anyone wants to help out. – Martin Ender Mar 14 at 14:54
3  
Looks excellent :-) – Szabolcs Mar 14 at 20:37

Avoid the too many font sizes issue by convert characters to graphics primitives:

numbers = 
  Translate[#, {-4.5, -10}] & /@ 
     First[First[
       ImportString[
        ExportString[Style[#, FontSize -> 24, FontFamily -> "Times"], 
         "PDF"], "PDF", "TextMode" -> "Outlines"]]] & /@ 
   CharacterRange["0", "9"];

borrowed from here: http://mathematica.stackexchange.com/a/638/2079

n = 10000;
d = First[RealDigits[Pi, 10, n]];

Graphics[{a = 0; r = 150; i = 0; 
  Reap[While[r > 2, i = i + 1; scale = .7 (1 - .99 (i/n)^(.2)); 
     r = r - .8 scale/(2 Pi);
     a = a - 10 scale/r ; 
     Sow[Rotate[
       Translate[
        Scale[{EdgeForm[], FaceForm[Black], numbers[[d[[i]] + 1]]}, 
         scale], {0, r}],
        a, {0, 0}]]]][[2, 1]]}, 
 PlotRange -> {{-200, 200}, {-200, 200}}]

enter image description here

share|improve this answer
    
This code crashes Mathematica (it just quits) 10.2.0 student edition on my Mac (El Capitan). I was able to pinpoint the problem to ExportString. ExportString["0","PDF"] crashes, as well as ExportString["0","SVG"]. Any idea why that would be? – freddieknets Mar 15 at 19:16
    
@freddieknets you might post that as a new question. My guess is all you can do is report it to support. If you really need this there are some other methods for getting character outlines in the linked question. – george2079 Mar 15 at 19:27

This calculates the height, width and inter-character spacings for each number, keeping the same proportion as it winds down. That (I believe) is what the picture at the question does. f determines the "frequency" of the spiral and can be changed at will as everything is set up accordingly.

Wow! I am using this trick here at least since 2012

ClearAll[height, nbr, width, nextt, w, angles, list, f, digits];
f          = 50;
digits     = 3000;
s          = -5/4 Pi;
nbrSpacing = 12/10;
list       = First@RealDigits[Pi, 10, digits];

w[nbr_] := w[nbr] = Cases[First[First[ImportString[ExportString[
       Style[ToString@nbr, FontFamily -> "Courier", FontSize -> 10], "PDF"],
       "TextMode" -> "Outlines"]]], 
                       FilledCurve[a__] :> {EdgeForm[Black], FilledCurve[a]}, Infinity]

parmsFont = {Min@#, Max@#} & /@ Transpose[w[1][[1, 2, 2, 1]]];
{aspectRatio, center, origHeight} = {Divide @@ (Subtract @@@ #), Mean[#[[1]]], 
                                    -Subtract @@ (#[[2]])} &@parmsFont;

height[t_] := E^(t/f) - E^((t - 2 Pi)/f) // N

nbr[n_, t_] := {GeometricTransformation[w[n], 
   Composition[TranslationTransform[E^(t/f) {Cos[t], Sin[t]}], 
               ScalingTransform[height[t]/origHeight {1, 1}], 
               RotationTransform[t - Pi/2]]]}

width[t_] := aspectRatio height[t]
nextt[t_] := nextt[t] = (t - nbrSpacing  width[t] E^(s/f)/E^(t/f))
angles = NestList[nextt, s, digits - 1] // N;

Graphics@MapThread[nbr, {list, angles}]

enter image description here

With f = 80

enter image description here

With f = 25

enter image description here

share|improve this answer

Just blatantly ripping off the code linked to by swish, and modifying slightly, you can get

With[{ndig = 2000},
 angle = 0;
 digits = First[RealDigits[Pi, 10, ndig]];
 Graphics@Table[
   r = .1 + .01 angle/2;
   angle += .4 (80000/r)^.3;
   fontsize = 4 (800 (.1 + r)^1.25)/ndig^1.5;
   g = Rotate[
     Style[
      Text[
       Reverse[digits][[n]],
       {0, r^1.2}, {0, 0}],
      fontsize],
     angle Degree, {0, 0}],
   {n, 0, ndig}]
 ]

enter image description here

To get closer to the intended image, you'll have to adjust how the radius and fontsize scale with increasing n.

share|improve this answer
    
Why does this get so wobbly in the middle? – Brad Mar 16 at 16:42

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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