Hi,

It is by the way indeed interesting to use graphs to visualise this:

Graph[# -> Total[IntegerDigits[#]^2] & /@ Range[10000]]

It turns out that there is a skeleton that is relatively stable.

GraphPlot[# -> Total[IntegerDigits[#]^2] & /@ Range[1000], Method -> "CircularEmbedding"]

and this

GraphPlot[# -> Total[IntegerDigits[#]^2] & /@ Range[200], Method -> "LinearEmbedding"]

look pretty, too, and have a meaning. I think, however, that the Layered Graph is the best visualisation:

LayeredGraphPlot[# -> Total[IntegerDigits[#]^2] & /@ Range[200]]

The upper graph contains the sad numbers and the lower one the happy ones. This also explains why you always reach one out of nine numbers. The lower graph has a fixed point. You always get to "1" and then stay there - that's happy. If you carefully look at the other graph you see that there is a cycle of eight vertices.

If you want to see that cycle you can use:

g = Graph[# -> Total[IntegerDigits[#]^2] & /@ Range[1000]];
cycle=FindCycle[g]
(*{{4 -> 16, 16 -> 37, 37-> 58, 58-> 89, 89-> 145, 145 -> 42, 42-> 20, 20-> 4}}*)

This can be used to highlight the subgraph:

HighlightGraph[g, cycle]

If you compare that to the table of my first reply all numbers are accounted for.

Cheers,

Marco

Any forecast of this behavior - which is ratio of vertex number of happy and unhappy?

gfun[n_] := Graph[# <-> Total[IntegerDigits[#]^2] & /@ Range[n]]

data = ParallelTable[N[Divide @@ (Length /@ ConnectedComponents[gfun[k]])], {k, 500, 10000}];

ListLinePlot[data, PlotTheme -> "Detailed", AspectRatio -> 1/4, PlotRange -> All]

Hi Sander

First of all, thank you for reminding me to use IntegerDigits instead of the other stuff.

I'm sorry that my questions are a bit confusing. The code you've presented wasn't exactly what I was looking for. I wanted to have a plot where all numbers are connected with each other. But I like your code because you can choose the starting number and watch what happens next. So thank you very much! :)

Cheers,

Not sure if it goes to a constant... it seems to be increasing:

Value for 5*10^6: 6.1007

Value for 10^7: 6.04794

Value for 2*10^7: 6.17541

Value for 5*10^7: 6.15794

......

Perhaps use the following code:

GraphPlot[
 Rule @@@ DeleteDuplicates[
   Partition[NestList[Total[IntegerDigits[#]^2] &, 4, 99], 2, 1]
   ]
]

Depending on the version you have you can use Subsequences[...,{2}] rather than Partition[...,2,1], Also you could probably use FindTransientRepeat in a nice way.

I'm not sure if I understand your question. But using ToString, Characters and ToExpression is definitely not fast, using IntegerDigits should be much much faster!