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$ Jun 27, 2015 at 5:40
  • 1
    $\begingroup$ Or perhaps Graph@Table[DirectedEdge[n, Tr[IntegerDigits[n]^2]], {n, 100}] $\endgroup$ Jun 27, 2015 at 5:41
  • $\begingroup$ @belisarius Thank you, just what I was looking for. $\endgroup$ Jun 27, 2015 at 5:44

2 Answers 2


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!)

  • $\begingroup$ Yes this is what I was looking for. I was unaware that they had a term for them. $\endgroup$ Jun 27, 2015 at 20:28
  • $\begingroup$ @J.M. ubpdqnmathematica.wordpress.com/2013/10/03/happy-numbers $\endgroup$
    – ubpdqn
    Jun 28, 2015 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$ Jun 28, 2015 at 11:34
  • $\begingroup$ I'm not sure is you had "interpreted the question a bit differently". Methinks our results are the same... $\endgroup$ Jul 6, 2015 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


Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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