I am trying to make a graph that depicts integers $< 100$ mapping to the sum of their digits squared. I can do this for one iteration, but I don't know how to do it for more than one, or until the new integer $n$ maps to itself. What I have is:

TreePlot[Table[i -> ((Mod[i, 10])^2 + ((i - Mod[i, 10])/10)^2), {i, 99}]]

I'm a Mathematica beginner so forgive me if this is an obvious or easily answered question.

my attempt

  • $\begingroup$ Perhaps I don't understand the question,but Graph@Table[DirectedEdge[n, Tr@IntegerDigits@n^2], {n, 100}] $\endgroup$ – Dr. belisarius Jun 27 '15 at 5:40
  • 1
    $\begingroup$ Or perhaps Graph@Table[DirectedEdge[n, Tr[IntegerDigits[n]^2]], {n, 100}] $\endgroup$ – Dr. belisarius Jun 27 '15 at 5:41
  • $\begingroup$ @belisarius Thank you, just what I was looking for. $\endgroup$ – mysatellite Jun 27 '15 at 5:44

I had interpreted the question a bit differently. The word "iterative" in the question led me to think that OP might want to see the graphs connecting the happy numbers and unhappy numbers in Mathematica. Here's how to get the two graphs:

nums = Table[NestWhileList[Composition[#.# &, IntegerDigits], k,
                           (FreeQ @@ Through[{Most, Last}[{##}]]) &, All],
             {k, 99}];
happy = Select[nums, MemberQ[#, 1] &];
unhappy = Complement[nums, happy];

happyGraph = Graph[Union[Flatten[(DirectedEdge @@@ Partition[#, 2, 1]) & /@

happy number graph

unhappyGraph = Graph[Union[Flatten[(DirectedEdge @@@ Partition[#, 2, 1]) & /@

unhappy number graph

Note the number cycle which the unhappy numbers tend to.

(I had elected to omit the formatting options I used, as they were quite ad hoc and annoying to tweak. If anybody can produce better layouts of these graphs, feel free to edit my post!)

| improve this answer | |
  • $\begingroup$ Yes this is what I was looking for. I was unaware that they had a term for them. $\endgroup$ – mysatellite Jun 27 '15 at 20:28
  • $\begingroup$ @J.M. ubpdqnmathematica.wordpress.com/2013/10/03/happy-numbers $\endgroup$ – ubpdqn Jun 28 '15 at 11:28
  • $\begingroup$ @ubpdqn, very cute! Tho, the graph embedding algorithms leave something to be desired in this case; the overlapping in some places is annoying. $\endgroup$ – J. M.'s technical difficulties Jun 28 '15 at 11:34
  • $\begingroup$ I'm not sure is you had "interpreted the question a bit differently". Methinks our results are the same... $\endgroup$ – Dr. belisarius Jul 6 '15 at 20:49

Just to ensure this one isn't going to engross the unanswered internal bag. As I said in a comment the following might work for two "iterations":

base = List /@ Range@100;
base1 = {#, Tr[IntegerDigits[#]^2]} & /@ base[[All, -1]];
base2 = {#, Tr[IntegerDigits[#]^2]} & /@ base1[[All, -1]];
DirectedEdge @@@ Union[base1, base2];
Graph[%, GraphLayout -> "LayeredEmbedding"]

Mathematica graphics

So the expression for the nth iteration is:

f[base_, n_] := Graph[
  DirectedEdge @@@ 
   Union @@ 
    Rest@NestList[{#, Tr[IntegerDigits[#]^2]} & /@ #[[All, -1]] &, 
      base, n], GraphLayout -> "LayeredEmbedding"]

Invoke as

f[List /@ Range@200, 3]

Mathematica graphics

| improve this answer | |

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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