Ulam spiral to appear on Sept. 2013 cover of Math Horizons

Posted 5 years ago
22220 Views
|
8 Replies
|
28 Total Likes
|
 The cover image will show an Ulam spiral with the twin primes highlighted. It's actually a Graphics3D -- a pyramid viewed from above. The code is below for those who wish to play with it. NOTE: This appeared at the end of another discussion "Text in front of objects in Graphics3D" on Graphics and Visualization. I wanted to share the final result more broadly. Clear[s, e, n, w, dir, tab, m, \[Delta], positions, allPrimes,    twinPrimes, sph, ulam]; m = 20; (* m is the no. of spiral "laps", so (2m)^2 numbers will be \ displayed *) \[Delta] = .1; (* \[Delta] = vertical depth added to \ pyramid for each number *)  dir = {s, e, n, w}; (* directions: south, east, north, west *) tab = {};Do[dir = RotateLeft[dir]; AppendTo[tab, Table[First[dir], {k}]];  dir = RotateLeft[dir];   AppendTo[tab, Table[First[dir], {k}]], {k, 1, 2 m}];positions =   FoldList[Plus, {0, 0, 0},    Take[Flatten[tab], 4 m^2 - 1] /. {e -> {\[Delta], -1, 0},      n -> {\[Delta], 0, 1}, w -> {\[Delta], 1, 0},      s -> {\[Delta], 0, -1}}];allPrimes = PrimeQ[Range[4 m^2]];twinPrimes =   MapThread[   Or, {MapThread[     And, {allPrimes, Join[{False, False}, Drop[allPrimes, -2]]}],     MapThread[     And, {allPrimes, Join[Drop[allPrimes, 2], {False, False}]}]}];sph[k_, pos_, highlight_] :=   Translate[   SphericalPlot3D[.3, {\[Theta], 0, Pi}, {\[Phi], 0, 2 Pi},      Mesh -> None,      PlotStyle ->       Texture[Graphics[        Style[Text[k, {0, 0}, {0, 0}, {0, 1}], 128,          FontFamily -> "Optima"], AspectRatio -> 2,         Background ->          If[highlight, RGBColor[1., 1., 0.],           RGBColor[.5, .5, .5]], ImageSize -> 400]],      TextureCoordinateFunction -> ({#4, #5} &)][[1]], pos];ulam = Graphics3D[{    {Gray, Tube[positions, .05]},    MapThread[sph, {Range[4 m^2], positions, twinPrimes}]    }, ViewPoint -> {-1.8, 0, 0}, PlotRangePadding -> None,    Boxed -> False, Lighting -> "Neutral", ImageSize -> 5200,    Background -> Black];
8 Replies
Sort By:
Posted 5 years ago
 This looks great! We'd be interested in sharing this on our social media and elsewhere--when the journal goes out, could you send us an email at community@wolfram.com?
Posted 5 years ago
 I just realized that the September issue of Math Horizons is live and the cover looks beautiful - congratulations, Bruce!
Posted 5 years ago
 Primes, and compositeness of integers can create interesting patterns on spirals. In the one below, series of highly composite numbers show as dark streaks of varying locations and curvatures. Figuring out what these arcs correspond to can be quite an intellectual challenge. More you look at it (preferably at original resolution), more you can find these patterns.With[{size = {1920, 1200}, numbers = 100000, r = 4/(3 GoldenRatio)}, Graphics[{White,    Table[Disk[RotationTransform[Pi (3 - Sqrt[5]) n][{Sqrt[n], 0}],      r/Max[1, PrimeOmega[n]]], {n, numbers}]},   PlotRange -> (r/3) (# {-1, 1}/2 & /@ size), ImagePadding -> None,   ImageSize -> size, Background -> Black]]
Posted 5 years ago
 Hello,This is such a lovely image, that I decided to play with colors and opacity with it.Here is the image (I converted to numeric to speed up the computation a little) r = 4/(3 GoldenRatio); radii = N@Table[r/Max[1, PrimeOmega[n]], {n, 100000}]; {minrad, maxrad} = Through[{Min, Max}[radii]];  Graphics[Table[   {Opacity[0.25],    {     ColorData[       "DarkRainbow"][(radii[[n]] - minrad)/(maxrad - minrad)],    Disk[RotationTransform[N@Pi (3 - Sqrt[5]) n][{Sqrt[n], 0}],      4 radii[[n]]]    }   }  , {n, 100000}]]One thing that stuck me here is that the render is fairly slow (even if Opacity is not used).For Graphics3D, Sphere can take a list of centers: Sphere[{{x1,y1,z1},....., {xn,yn,zn}},r] which  (J. Fultz tells me) speeds up rendering for large n.  Disk doesn't have such an option...
Posted 5 years ago
 Another reason for slowness might be that coordinates are actually precise, instead of machine-precision reals. That's not really necessary for graphics like this...
Posted 5 years ago
 Craig - nice idea, these are my reflections of it with some modifications and Jari's advise. Besides some tricks with scaling to make less frequent numbers more prominent, I think most important is to keep Background to be black when using opacity. White shines through translucent objects and makes them duller. r = 4/(3 GoldenRatio); radii = N@Table[r/Max[1, PrimeOmega[n]], {n, 100000}]; {minrad, maxrad} = Through[{Min, Max}[radii]];   Graphics[ParallelTable[{Opacity[.7], {ColorData["BrightBands"][      Sin[N[(radii[[n]] - minrad)/(maxrad - minrad)] Pi/2]^.4],      Disk[RotationTransform[N@Pi (3 - Sqrt[5]) n][{Sqrt[n], 0}],       2 (1 - Sin[radii[[n]] Pi/2]^.4)]}}, {n, 15000}], ImageSize -> 1000, Background -> Black]